source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 !-----------------------------------------------------------------------------
  33 ! commom.calc common/calc/
  34 !-----------------------------------------------------------------------------
  35 ! commom.contacts
  36 !      common /contacts/
  37 ! Change 12/1/95 - common block CONTACTS1 included.
  38 !      common /contacts1/
  39       integer,dimension(:),allocatable :: num_cont      !(maxres)
  40       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  41       real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres)
  42       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  43 !
  44 ! 12/26/95 - H-bonding contacts
  45 !      common /contacts_hb/
  46       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  47        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  48       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  49         ees0m,d_cont    !(maxconts,maxres)
  50       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  51       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  52 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  53 !         interactions
  54 ! 7/25/08 commented out; not needed when cumulants used
  55 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  56 !  common /dipint/
  57       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  58          dipderg        !(4,maxconts,maxres)
  59       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  60 ! 10/30/99 Added other pre-computed vectors and matrices needed
  61 !          to calculate three - six-order el-loc correlation terms
  62 ! common /rotat/
  63       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  64       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  65        obrot2_der       !(2,maxres)
  66 !
  67 ! This common block contains vectors and matrices dependent on a single
  68 ! amino-acid residue.
  69 !      common /precomp1/
  70       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  71        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  72       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  73        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  74 ! This common block contains vectors and matrices dependent on two
  75 ! consecutive amino-acid residues.
  76 !      common /precomp2/
  77       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  78        CUgb2,CUgb2der   !(2,maxres)
  79       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  80        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  81       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  82        DtUg2EUgder      !(2,2,2,maxres)
  83 !      common /rotat_old/
  84       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  85        costab2,sintab2  !(maxres)
  86 ! This common block contains dipole-interaction matrices and their
  87 ! Cartesian derivatives.
  88 !      common /dipmat/
  89       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  90       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  91 !      common /diploc/
  92       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  93        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  94       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
  95        ADtEA1derg,AEAb2derg
  96       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
  97        AECAderx,ADtEAderx,ADtEA1derx
  98       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
  99       real(kind=8),dimension(3,2) :: g_contij
 100       real(kind=8) :: ekont
 101 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 102 !   RE: Parallelization of 4th and higher order loc-el correlations
 103 !      common /contdistrib/
 104       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 105 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 106 !-----------------------------------------------------------------------------
 107 ! commom.deriv;
 108 !      common /derivat/
 109 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 110 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 111 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 112       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 113         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 114         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 115         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres)
 116 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 117       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 118         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 119       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 120         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 121         g_corr6_loc     !(maxvar)
 122       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 123       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 124 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 125       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 126 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 127 !      integer :: nfl,icg
 128 !      common /deriv_loc/
 129       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 130 !      common /deriv_scloc/
 131       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 132        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 133        dZZ_XYZtab       !(3,maxres)
 134 !-----------------------------------------------------------------------------
 135 ! common.maxgrad
 136 !      common /maxgrad/
 137       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 138        gradb_max,ghpbc_max,&
 139        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 140        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 141        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 142        gsccorx_max,gsclocx_max
 143 !-----------------------------------------------------------------------------
 144 ! common.MD
 145 !      common /back_constr/
 146       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 147       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 148 !      common /qmeas/
 149       real(kind=8) :: Ucdfrag,Ucdpair
 150       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 151        dqwol,dxqwol     !(3,0:MAXRES)
 152 !-----------------------------------------------------------------------------
 153 ! common.sbridge
 154 !      common /dyn_ssbond/
 155       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 156 !-----------------------------------------------------------------------------
 157 ! common.sccor
 158 ! Parameters of the SCCOR term
 159 !      common/sccor/
 160       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 161        dcosomicron,domicron     !(3,3,3,maxres2)
 162 !-----------------------------------------------------------------------------
 163 ! common.vectors
 164 !      common /vectors/
 165       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 166       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 167 !-----------------------------------------------------------------------------
 168 ! common /przechowalnia/
 169       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 170       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 171 !-----------------------------------------------------------------------------
 172 !-----------------------------------------------------------------------------
 173 !
 174 !
 175 !-----------------------------------------------------------------------------
 176       contains
 177 !-----------------------------------------------------------------------------
 178 ! energy_p_new_barrier.F
 179 !-----------------------------------------------------------------------------
 180       subroutine etotal(energia)
 181 !      implicit real*8 (a-h,o-z)
 182 !      include 'DIMENSIONS'
 183       use MD_data
 184 #ifndef ISNAN
 185       external proc_proc
 186 #ifdef WINPGI
 187 !MS$ATTRIBUTES C ::  proc_proc
 188 #endif
 189 #endif
 190 #ifdef MPI
 191       include "mpif.h"
 192 #endif
 193 !      include 'COMMON.SETUP'
 194 !      include 'COMMON.IOUNITS'
 195       real(kind=8),dimension(0:n_ene) :: energia
 196 !      include 'COMMON.LOCAL'
 197 !      include 'COMMON.FFIELD'
 198 !      include 'COMMON.DERIV'
 199 !      include 'COMMON.INTERACT'
 200 !      include 'COMMON.SBRIDGE'
 201 !      include 'COMMON.CHAIN'
 202 !      include 'COMMON.VAR'
 203 !      include 'COMMON.MD'
 204 !      include 'COMMON.CONTROL'
 205 !      include 'COMMON.TIME1'
 206       real(kind=8) :: time00
 207 !el local variables
 208       integer :: n_corr,n_corr1,ierror
 209       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 210       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 211       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe
 212       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 213
 214 #ifdef MPI
 215       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 216 ! shielding effect varibles for MPI
 217 !      real(kind=8)   fac_shieldbuf(maxres),
 218 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 219 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 220 !     & grad_shieldbuf(3,-1:maxres)
 221 !       integer ishield_listbuf(maxres),
 222 !     &shield_listbuf(maxcontsshi,maxres)
 223
 224 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 225 !     & " nfgtasks",nfgtasks
 226       if (nfgtasks.gt.1) then
 227         time00=MPI_Wtime()
 228 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 229         if (fg_rank.eq.0) then
 230           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 231 !          print *,"Processor",myrank," BROADCAST iorder"
 232 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 233 ! FG slaves as WEIGHTS array.
 234           weights_(1)=wsc
 235           weights_(2)=wscp
 236           weights_(3)=welec
 237           weights_(4)=wcorr
 238           weights_(5)=wcorr5
 239           weights_(6)=wcorr6
 240           weights_(7)=wel_loc
 241           weights_(8)=wturn3
 242           weights_(9)=wturn4
 243           weights_(10)=wturn6
 244           weights_(11)=wang
 245           weights_(12)=wscloc
 246           weights_(13)=wtor
 247           weights_(14)=wtor_d
 248           weights_(15)=wstrain
 249           weights_(16)=wvdwpp
 250           weights_(17)=wbond
 251           weights_(18)=scal14
 252           weights_(21)=wsccor
 253 ! FG Master broadcasts the WEIGHTS_ array
 254           call MPI_Bcast(weights_(1),n_ene,&
 255              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 256         else
 257 ! FG slaves receive the WEIGHTS array
 258           call MPI_Bcast(weights(1),n_ene,&
 259               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 260           wsc=weights(1)
 261           wscp=weights(2)
 262           welec=weights(3)
 263           wcorr=weights(4)
 264           wcorr5=weights(5)
 265           wcorr6=weights(6)
 266           wel_loc=weights(7)
 267           wturn3=weights(8)
 268           wturn4=weights(9)
 269           wturn6=weights(10)
 270           wang=weights(11)
 271           wscloc=weights(12)
 272           wtor=weights(13)
 273           wtor_d=weights(14)
 274           wstrain=weights(15)
 275           wvdwpp=weights(16)
 276           wbond=weights(17)
 277           scal14=weights(18)
 278           wsccor=weights(21)
 279         endif
 280         time_Bcast=time_Bcast+MPI_Wtime()-time00
 281         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 282 !        call chainbuild_cart
 283       endif
 284 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 285 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 286 #else
 287 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 288 !        call int_from_cart1(.false.)
 289 !      endif
 290 #endif
 291 #ifdef TIMING
 292       time00=MPI_Wtime()
 293 #endif
 294 !
 295 ! Compute the side-chain and electrostatic interaction energy
 296 !
 297 !      goto (101,102,103,104,105,106) ipot
 298       select case(ipot)
 299 ! Lennard-Jones potential.
 300 !  101 call elj(evdw)
 301        case (1)
 302          call elj(evdw)
 303 !d    print '(a)','Exit ELJcall el'
 304 !      goto 107
 305 ! Lennard-Jones-Kihara potential (shifted).
 306 !  102 call eljk(evdw)
 307        case (2)
 308          call eljk(evdw)
 309 !      goto 107
 310 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 311 !  103 call ebp(evdw)
 312        case (3)
 313          call ebp(evdw)
 314 !      goto 107
 315 ! Gay-Berne potential (shifted LJ, angular dependence).
 316 !  104 call egb(evdw)
 317        case (4)
 318          call egb(evdw)
 319 !      goto 107
 320 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 321 !  105 call egbv(evdw)
 322        case (5)
 323          call egbv(evdw)
 324 !      goto 107
 325 ! Soft-sphere potential
 326 !  106 call e_softsphere(evdw)
 327        case (6)
 328          call e_softsphere(evdw)
 329 !
 330 ! Calculate electrostatic (H-bonding) energy of the main chain.
 331 !
 332 !  107 continue
 333        case default
 334          write(iout,*)"Wrong ipot"
 335 !         return
 336 !   50 continue
 337       end select
 338 !      continue
 339
 340 !mc
 341 !mc Sep-06: egb takes care of dynamic ss bonds too
 342 !mc
 343 !      if (dyn_ss) call dyn_set_nss
 344 !      print *,"Processor",myrank," computed USCSC"
 345 #ifdef TIMING
 346       time01=MPI_Wtime()
 347 #endif
 348       call vec_and_deriv
 349 #ifdef TIMING
 350       time_vec=time_vec+MPI_Wtime()-time01
 351 #endif
 352 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 353       if (ipot.lt.6) then
 354 #ifdef SPLITELE
 355          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 356              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 357              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 358              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 359 #else
 360          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 361              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 362              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 363              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 364 #endif
 365             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 366 !        write (iout,*) "ELEC calc"
 367          else
 368             ees=0.0d0
 369             evdw1=0.0d0
 370             eel_loc=0.0d0
 371             eello_turn3=0.0d0
 372             eello_turn4=0.0d0
 373          endif
 374       else
 375 !        write (iout,*) "Soft-spheer ELEC potential"
 376         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 377          eello_turn4)
 378       endif
 379 !      print *,"Processor",myrank," computed UELEC"
 380 !
 381 ! Calculate excluded-volume interaction energy between peptide groups
 382 ! and side chains.
 383 !
 384 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 385
 386       if (ipot.lt.6) then
 387        if(wscp.gt.0d0) then
 388         call escp(evdw2,evdw2_14)
 389        else
 390         evdw2=0
 391         evdw2_14=0
 392        endif
 393       else
 394 !        write (iout,*) "Soft-sphere SCP potential"
 395         call escp_soft_sphere(evdw2,evdw2_14)
 396       endif
 397 !elwrite(iout,*) "in etotal before ebond",ipot
 398
 399 !
 400 ! Calculate the bond-stretching energy
 401 !
 402       call ebond(estr)
 403 !elwrite(iout,*) "in etotal afer ebond",ipot
 404
 405 !
 406 ! Calculate the disulfide-bridge and other energy and the contributions
 407 ! from other distance constraints.
 408 !      print *,'Calling EHPB'
 409       call edis(ehpb)
 410 !elwrite(iout,*) "in etotal afer edis",ipot
 411 !      print *,'EHPB exitted succesfully.'
 412 !
 413 ! Calculate the virtual-bond-angle energy.
 414 !
 415       if (wang.gt.0d0) then
 416         call ebend(ebe)
 417       else
 418         ebe=0
 419       endif
 420 !      print *,"Processor",myrank," computed UB"
 421 !
 422 ! Calculate the SC local energy.
 423 !
 424       call esc(escloc)
 425 !elwrite(iout,*) "in etotal afer esc",ipot
 426 !      print *,"Processor",myrank," computed USC"
 427 !
 428 ! Calculate the virtual-bond torsional energy.
 429 !
 430 !d    print *,'nterm=',nterm
 431       if (wtor.gt.0) then
 432        call etor(etors,edihcnstr)
 433       else
 434        etors=0
 435        edihcnstr=0
 436       endif
 437 !      print *,"Processor",myrank," computed Utor"
 438 !
 439 ! 6/23/01 Calculate double-torsional energy
 440 !
 441 !elwrite(iout,*) "in etotal",ipot
 442       if (wtor_d.gt.0) then
 443        call etor_d(etors_d)
 444       else
 445        etors_d=0
 446       endif
 447 !      print *,"Processor",myrank," computed Utord"
 448 !
 449 ! 21/5/07 Calculate local sicdechain correlation energy
 450 !
 451       if (wsccor.gt.0.0d0) then
 452         call eback_sc_corr(esccor)
 453       else
 454         esccor=0.0d0
 455       endif
 456 !      print *,"Processor",myrank," computed Usccorr"
 457 !
 458 ! 12/1/95 Multi-body terms
 459 !
 460       n_corr=0
 461       n_corr1=0
 462       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 463           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 464          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 465 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 466 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 467       else
 468          ecorr=0.0d0
 469          ecorr5=0.0d0
 470          ecorr6=0.0d0
 471          eturn6=0.0d0
 472       endif
 473 !elwrite(iout,*) "in etotal",ipot
 474       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 475          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 476 !d         write (iout,*) "multibody_hb ecorr",ecorr
 477       endif
 478 !elwrite(iout,*) "afeter  multibody hb"
 479
 480 !      print *,"Processor",myrank," computed Ucorr"
 481 !
 482 ! If performing constraint dynamics, call the constraint energy
 483 !  after the equilibration time
 484       if(usampl.and.totT.gt.eq_time) then
 485 !elwrite(iout,*) "afeter  multibody hb"
 486          call EconstrQ
 487 !elwrite(iout,*) "afeter  multibody hb"
 488          call Econstr_back
 489 !elwrite(iout,*) "afeter  multibody hb"
 490       else
 491          Uconst=0.0d0
 492          Uconst_back=0.0d0
 493       endif
 494 !elwrite(iout,*) "after Econstr"
 495
 496 #ifdef TIMING
 497       time_enecalc=time_enecalc+MPI_Wtime()-time00
 498 #endif
 499 !      print *,"Processor",myrank," computed Uconstr"
 500 #ifdef TIMING
 501       time00=MPI_Wtime()
 502 #endif
 503 !
 504 ! Sum the energies
 505 !
 506       energia(1)=evdw
 507 #ifdef SCP14
 508       energia(2)=evdw2-evdw2_14
 509       energia(18)=evdw2_14
 510 #else
 511       energia(2)=evdw2
 512       energia(18)=0.0d0
 513 #endif
 514 #ifdef SPLITELE
 515       energia(3)=ees
 516       energia(16)=evdw1
 517 #else
 518       energia(3)=ees+evdw1
 519       energia(16)=0.0d0
 520 #endif
 521       energia(4)=ecorr
 522       energia(5)=ecorr5
 523       energia(6)=ecorr6
 524       energia(7)=eel_loc
 525       energia(8)=eello_turn3
 526       energia(9)=eello_turn4
 527       energia(10)=eturn6
 528       energia(11)=ebe
 529       energia(12)=escloc
 530       energia(13)=etors
 531       energia(14)=etors_d
 532       energia(15)=ehpb
 533       energia(19)=edihcnstr
 534       energia(17)=estr
 535       energia(20)=Uconst+Uconst_back
 536       energia(21)=esccor
 537 !    Here are the energies showed per procesor if the are more processors
 538 !    per molecule then we sum it up in sum_energy subroutine
 539 !      print *," Processor",myrank," calls SUM_ENERGY"
 540       call sum_energy(energia,.true.)
 541       if (dyn_ss) call dyn_set_nss
 542 !      print *," Processor",myrank," left SUM_ENERGY"
 543 #ifdef TIMING
 544       time_sumene=time_sumene+MPI_Wtime()-time00
 545 #endif
 546 !el        call enerprint(energia)
 547 !elwrite(iout,*)"finish etotal"
 548       return
 549       end subroutine etotal
 550 !-----------------------------------------------------------------------------
 551       subroutine sum_energy(energia,reduce)
 552 !      implicit real*8 (a-h,o-z)
 553 !      include 'DIMENSIONS'
 554 #ifndef ISNAN
 555       external proc_proc
 556 #ifdef WINPGI
 557 !MS$ATTRIBUTES C ::  proc_proc
 558 #endif
 559 #endif
 560 #ifdef MPI
 561       include "mpif.h"
 562 #endif
 563 !      include 'COMMON.SETUP'
 564 !      include 'COMMON.IOUNITS'
 565       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 566 !      include 'COMMON.FFIELD'
 567 !      include 'COMMON.DERIV'
 568 !      include 'COMMON.INTERACT'
 569 !      include 'COMMON.SBRIDGE'
 570 !      include 'COMMON.CHAIN'
 571 !      include 'COMMON.VAR'
 572 !      include 'COMMON.CONTROL'
 573 !      include 'COMMON.TIME1'
 574       logical :: reduce
 575       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 576       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 577       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 578       integer :: i
 579 #ifdef MPI
 580       integer :: ierr
 581       real(kind=8) :: time00
 582       if (nfgtasks.gt.1 .and. reduce) then
 583
 584 #ifdef DEBUG
 585         write (iout,*) "energies before REDUCE"
 586         call enerprint(energia)
 587         call flush(iout)
 588 #endif
 589         do i=0,n_ene
 590           enebuff(i)=energia(i)
 591         enddo
 592         time00=MPI_Wtime()
 593         call MPI_Barrier(FG_COMM,IERR)
 594         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 595         time00=MPI_Wtime()
 596         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 597           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 598 #ifdef DEBUG
 599         write (iout,*) "energies after REDUCE"
 600         call enerprint(energia)
 601         call flush(iout)
 602 #endif
 603         time_Reduce=time_Reduce+MPI_Wtime()-time00
 604       endif
 605       if (fg_rank.eq.0) then
 606 #endif
 607       evdw=energia(1)
 608 #ifdef SCP14
 609       evdw2=energia(2)+energia(18)
 610       evdw2_14=energia(18)
 611 #else
 612       evdw2=energia(2)
 613 #endif
 614 #ifdef SPLITELE
 615       ees=energia(3)
 616       evdw1=energia(16)
 617 #else
 618       ees=energia(3)
 619       evdw1=0.0d0
 620 #endif
 621       ecorr=energia(4)
 622       ecorr5=energia(5)
 623       ecorr6=energia(6)
 624       eel_loc=energia(7)
 625       eello_turn3=energia(8)
 626       eello_turn4=energia(9)
 627       eturn6=energia(10)
 628       ebe=energia(11)
 629       escloc=energia(12)
 630       etors=energia(13)
 631       etors_d=energia(14)
 632       ehpb=energia(15)
 633       edihcnstr=energia(19)
 634       estr=energia(17)
 635       Uconst=energia(20)
 636       esccor=energia(21)
 637 #ifdef SPLITELE
 638       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 639        +wang*ebe+wtor*etors+wscloc*escloc &
 640        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 641        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 642        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 643        +wbond*estr+Uconst+wsccor*esccor
 644 #else
 645       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 646        +wang*ebe+wtor*etors+wscloc*escloc &
 647        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 648        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 649        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 650        +wbond*estr+Uconst+wsccor*esccor
 651 #endif
 652       energia(0)=etot
 653 ! detecting NaNQ
 654 #ifdef ISNAN
 655 #ifdef AIX
 656       if (isnan(etot).ne.0) energia(0)=1.0d+99
 657 #else
 658       if (isnan(etot)) energia(0)=1.0d+99
 659 #endif
 660 #else
 661       i=0
 662 #ifdef WINPGI
 663       idumm=proc_proc(etot,i)
 664 #else
 665       call proc_proc(etot,i)
 666 #endif
 667       if(i.eq.1)energia(0)=1.0d+99
 668 #endif
 669 #ifdef MPI
 670       endif
 671 #endif
 672 !      call enerprint(energia)
 673       call flush(iout)
 674       return
 675       end subroutine sum_energy
 676 !-----------------------------------------------------------------------------
 677       subroutine rescale_weights(t_bath)
 678 !      implicit real*8 (a-h,o-z)
 679 #ifdef MPI
 680       include 'mpif.h'
 681 #endif
 682 !      include 'DIMENSIONS'
 683 !      include 'COMMON.IOUNITS'
 684 !      include 'COMMON.FFIELD'
 685 !      include 'COMMON.SBRIDGE'
 686       real(kind=8) :: kfac=2.4d0
 687       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 688 !el local variables
 689       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 690       real(kind=8) :: T0=3.0d2
 691       integer :: ierror
 692 !      facT=temp0/t_bath
 693 !      facT=2*temp0/(t_bath+temp0)
 694       if (rescale_mode.eq.0) then
 695         facT(1)=1.0d0
 696         facT(2)=1.0d0
 697         facT(3)=1.0d0
 698         facT(4)=1.0d0
 699         facT(5)=1.0d0
 700         facT(6)=1.0d0
 701       else if (rescale_mode.eq.1) then
 702         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 703         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 704         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 705         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 706         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 707 #ifdef WHAM_RUN
 708 !#if defined(WHAM_RUN) || defined(CLUSTER)
 709 #if defined(FUNCTH)
 710 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 711         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 712 #elif defined(FUNCT)
 713         facT(6)=t_bath/T0
 714 #else
 715         facT(6)=1.0d0
 716 #endif
 717 #endif
 718       else if (rescale_mode.eq.2) then
 719         x=t_bath/temp0
 720         x2=x*x
 721         x3=x2*x
 722         x4=x3*x
 723         x5=x4*x
 724         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 725         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 726         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 727         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 728         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 729 #ifdef WHAM_RUN
 730 !#if defined(WHAM_RUN) || defined(CLUSTER)
 731 #if defined(FUNCTH)
 732         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 733 #elif defined(FUNCT)
 734         facT(6)=t_bath/T0
 735 #else
 736         facT(6)=1.0d0
 737 #endif
 738 #endif
 739       else
 740         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 741         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 742 #ifdef MPI
 743        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 744 #endif
 745        stop 555
 746       endif
 747       welec=weights(3)*fact(1)
 748       wcorr=weights(4)*fact(3)
 749       wcorr5=weights(5)*fact(4)
 750       wcorr6=weights(6)*fact(5)
 751       wel_loc=weights(7)*fact(2)
 752       wturn3=weights(8)*fact(2)
 753       wturn4=weights(9)*fact(3)
 754       wturn6=weights(10)*fact(5)
 755       wtor=weights(13)*fact(1)
 756       wtor_d=weights(14)*fact(2)
 757       wsccor=weights(21)*fact(1)
 758
 759       return
 760       end subroutine rescale_weights
 761 !-----------------------------------------------------------------------------
 762       subroutine enerprint(energia)
 763 !      implicit real*8 (a-h,o-z)
 764 !      include 'DIMENSIONS'
 765 !      include 'COMMON.IOUNITS'
 766 !      include 'COMMON.FFIELD'
 767 !      include 'COMMON.SBRIDGE'
 768 !      include 'COMMON.MD'
 769       real(kind=8) :: energia(0:n_ene)
 770 !el local variables
 771       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 772       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 773       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 774
 775       etot=energia(0)
 776       evdw=energia(1)
 777       evdw2=energia(2)
 778 #ifdef SCP14
 779       evdw2=energia(2)+energia(18)
 780 #else
 781       evdw2=energia(2)
 782 #endif
 783       ees=energia(3)
 784 #ifdef SPLITELE
 785       evdw1=energia(16)
 786 #endif
 787       ecorr=energia(4)
 788       ecorr5=energia(5)
 789       ecorr6=energia(6)
 790       eel_loc=energia(7)
 791       eello_turn3=energia(8)
 792       eello_turn4=energia(9)
 793       eello_turn6=energia(10)
 794       ebe=energia(11)
 795       escloc=energia(12)
 796       etors=energia(13)
 797       etors_d=energia(14)
 798       ehpb=energia(15)
 799       edihcnstr=energia(19)
 800       estr=energia(17)
 801       Uconst=energia(20)
 802       esccor=energia(21)
 803 #ifdef SPLITELE
 804       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 805         estr,wbond,ebe,wang,&
 806         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 807         ecorr,wcorr,&
 808         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 809         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 810         edihcnstr,ebr*nss,&
 811         Uconst,etot
 812    10 format (/'Virtual-chain energies:'// &
 813        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 814        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 815        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 816        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 817        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 818        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 819        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 820        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 821        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 822        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 823        ' (SS bridges & dist. cnstr.)'/ &
 824        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 825        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 826        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 827        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 828        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 829        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 830        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 831        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 832        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 833        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 834        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 835        'ETOT=  ',1pE16.6,' (total)')
 836 #else
 837       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 838         estr,wbond,ebe,wang,&
 839         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 840         ecorr,wcorr,&
 841         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 842         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 843         ebr*nss,Uconst,etot
 844    10 format (/'Virtual-chain energies:'// &
 845        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 846        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 847        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 848        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 849        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 850        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 851        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 852        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 853        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 854        ' (SS bridges & dist. cnstr.)'/ &
 855        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 856        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 857        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 858        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 859        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 860        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 861        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 862        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 863        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 864        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 865        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 866        'ETOT=  ',1pE16.6,' (total)')
 867 #endif
 868       return
 869       end subroutine enerprint
 870 !-----------------------------------------------------------------------------
 871       subroutine elj(evdw)
 872 !
 873 ! This subroutine calculates the interaction energy of nonbonded side chains
 874 ! assuming the LJ potential of interaction.
 875 !
 876 !      implicit real*8 (a-h,o-z)
 877 !      include 'DIMENSIONS'
 878       real(kind=8),parameter :: accur=1.0d-10
 879 !      include 'COMMON.GEO'
 880 !      include 'COMMON.VAR'
 881 !      include 'COMMON.LOCAL'
 882 !      include 'COMMON.CHAIN'
 883 !      include 'COMMON.DERIV'
 884 !      include 'COMMON.INTERACT'
 885 !      include 'COMMON.TORSION'
 886 !      include 'COMMON.SBRIDGE'
 887 !      include 'COMMON.NAMES'
 888 !      include 'COMMON.IOUNITS'
 889 !      include 'COMMON.CONTACTS'
 890       real(kind=8),dimension(3) :: gg
 891       integer :: num_conti
 892 !el local variables
 893       integer :: i,itypi,iint,j,itypi1,itypj,k
 894       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 895       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 896       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 897
 898 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 899       evdw=0.0D0
 900 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 901 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 902 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 903 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 904
 905       do i=iatsc_s,iatsc_e
 906         itypi=iabs(itype(i))
 907         if (itypi.eq.ntyp1) cycle
 908         itypi1=iabs(itype(i+1))
 909         xi=c(1,nres+i)
 910         yi=c(2,nres+i)
 911         zi=c(3,nres+i)
 912 ! Change 12/1/95
 913         num_conti=0
 914 !
 915 ! Calculate SC interaction energy.
 916 !
 917         do iint=1,nint_gr(i)
 918 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 919 !d   &                  'iend=',iend(i,iint)
 920           do j=istart(i,iint),iend(i,iint)
 921             itypj=iabs(itype(j))
 922             if (itypj.eq.ntyp1) cycle
 923             xj=c(1,nres+j)-xi
 924             yj=c(2,nres+j)-yi
 925             zj=c(3,nres+j)-zi
 926 ! Change 12/1/95 to calculate four-body interactions
 927             rij=xj*xj+yj*yj+zj*zj
 928             rrij=1.0D0/rij
 929 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 930             eps0ij=eps(itypi,itypj)
 931             fac=rrij**expon2
 932             e1=fac*fac*aa(itypi,itypj)
 933             e2=fac*bb(itypi,itypj)
 934             evdwij=e1+e2
 935 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 936 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 937 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 938 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 939 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 940 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 941             evdw=evdw+evdwij
 942 !
 943 ! Calculate the components of the gradient in DC and X
 944 !
 945             fac=-rrij*(e1+evdwij)
 946             gg(1)=xj*fac
 947             gg(2)=yj*fac
 948             gg(3)=zj*fac
 949             do k=1,3
 950               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 951               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 952               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 953               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 954             enddo
 955 !grad            do k=i,j-1
 956 !grad              do l=1,3
 957 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 958 !grad              enddo
 959 !grad            enddo
 960 !
 961 ! 12/1/95, revised on 5/20/97
 962 !
 963 ! Calculate the contact function. The ith column of the array JCONT will
 964 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 965 ! greater than I). The arrays FACONT and GACONT will contain the values of
 966 ! the contact function and its derivative.
 967 !
 968 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 969 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 970 ! Uncomment next line, if the correlation interactions are contact function only
 971             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 972               rij=dsqrt(rij)
 973               sigij=sigma(itypi,itypj)
 974               r0ij=rs0(itypi,itypj)
 975 !
 976 ! Check whether the SC's are not too far to make a contact.
 977 !
 978               rcut=1.5d0*r0ij
 979               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 980 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 981 !
 982               if (fcont.gt.0.0D0) then
 983 ! If the SC-SC distance if close to sigma, apply spline.
 984 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 985 !Adam &             fcont1,fprimcont1)
 986 !Adam           fcont1=1.0d0-fcont1
 987 !Adam           if (fcont1.gt.0.0d0) then
 988 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 989 !Adam             fcont=fcont*fcont1
 990 !Adam           endif
 991 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 992 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 993 !ga             do k=1,3
 994 !ga               gg(k)=gg(k)*eps0ij
 995 !ga             enddo
 996 !ga             eps0ij=-evdwij*eps0ij
 997 ! Uncomment for AL's type of SC correlation interactions.
 998 !adam           eps0ij=-evdwij
 999                 num_conti=num_conti+1
1000                 jcont(num_conti,i)=j
1001                 facont(num_conti,i)=fcont*eps0ij
1002                 fprimcont=eps0ij*fprimcont/rij
1003                 fcont=expon*fcont
1004 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1005 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1006 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1007 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1008                 gacont(1,num_conti,i)=-fprimcont*xj
1009                 gacont(2,num_conti,i)=-fprimcont*yj
1010                 gacont(3,num_conti,i)=-fprimcont*zj
1011 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1012 !d              write (iout,'(2i3,3f10.5)')
1013 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1014               endif
1015             endif
1016           enddo      ! j
1017         enddo        ! iint
1018 ! Change 12/1/95
1019         num_cont(i)=num_conti
1020       enddo          ! i
1021       do i=1,nct
1022         do j=1,3
1023           gvdwc(j,i)=expon*gvdwc(j,i)
1024           gvdwx(j,i)=expon*gvdwx(j,i)
1025         enddo
1026       enddo
1027 !******************************************************************************
1028 !
1029 !                              N O T E !!!
1030 !
1031 ! To save time, the factor of EXPON has been extracted from ALL components
1032 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1033 ! use!
1034 !
1035 !******************************************************************************
1036       return
1037       end subroutine elj
1038 !-----------------------------------------------------------------------------
1039       subroutine eljk(evdw)
1040 !
1041 ! This subroutine calculates the interaction energy of nonbonded side chains
1042 ! assuming the LJK potential of interaction.
1043 !
1044 !      implicit real*8 (a-h,o-z)
1045 !      include 'DIMENSIONS'
1046 !      include 'COMMON.GEO'
1047 !      include 'COMMON.VAR'
1048 !      include 'COMMON.LOCAL'
1049 !      include 'COMMON.CHAIN'
1050 !      include 'COMMON.DERIV'
1051 !      include 'COMMON.INTERACT'
1052 !      include 'COMMON.IOUNITS'
1053 !      include 'COMMON.NAMES'
1054       real(kind=8),dimension(3) :: gg
1055       logical :: scheck
1056 !el local variables
1057       integer :: i,iint,j,itypi,itypi1,k,itypj
1058       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1059       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1060
1061 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 !
1071 ! Calculate SC interaction energy.
1072 !
1073         do iint=1,nint_gr(i)
1074           do j=istart(i,iint),iend(i,iint)
1075             itypj=iabs(itype(j))
1076             if (itypj.eq.ntyp1) cycle
1077             xj=c(1,nres+j)-xi
1078             yj=c(2,nres+j)-yi
1079             zj=c(3,nres+j)-zi
1080             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1081             fac_augm=rrij**expon
1082             e_augm=augm(itypi,itypj)*fac_augm
1083             r_inv_ij=dsqrt(rrij)
1084             rij=1.0D0/r_inv_ij
1085             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1086             fac=r_shift_inv**expon
1087             e1=fac*fac*aa(itypi,itypj)
1088             e2=fac*bb(itypi,itypj)
1089             evdwij=e_augm+e1+e2
1090 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1091 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1092 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1093 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1094 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1095 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1096 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1097             evdw=evdw+evdwij
1098 !
1099 ! Calculate the components of the gradient in DC and X
1100 !
1101             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1102             gg(1)=xj*fac
1103             gg(2)=yj*fac
1104             gg(3)=zj*fac
1105             do k=1,3
1106               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1107               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1108               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1109               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1110             enddo
1111 !grad            do k=i,j-1
1112 !grad              do l=1,3
1113 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1114 !grad              enddo
1115 !grad            enddo
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       do i=1,nct
1120         do j=1,3
1121           gvdwc(j,i)=expon*gvdwc(j,i)
1122           gvdwx(j,i)=expon*gvdwx(j,i)
1123         enddo
1124       enddo
1125       return
1126       end subroutine eljk
1127 !-----------------------------------------------------------------------------
1128       subroutine ebp(evdw)
1129 !
1130 ! This subroutine calculates the interaction energy of nonbonded side chains
1131 ! assuming the Berne-Pechukas potential of interaction.
1132 !
1133       use comm_srutu
1134       use calc_data
1135 !      implicit real*8 (a-h,o-z)
1136 !      include 'DIMENSIONS'
1137 !      include 'COMMON.GEO'
1138 !      include 'COMMON.VAR'
1139 !      include 'COMMON.LOCAL'
1140 !      include 'COMMON.CHAIN'
1141 !      include 'COMMON.DERIV'
1142 !      include 'COMMON.NAMES'
1143 !      include 'COMMON.INTERACT'
1144 !      include 'COMMON.IOUNITS'
1145 !      include 'COMMON.CALC'
1146       use comm_srutu
1147 !el      integer :: icall
1148 !el      common /srutu/ icall
1149 !     double precision rrsave(maxdim)
1150       logical :: lprn
1151 !el local variables
1152       integer :: iint,itypi,itypi1,itypj
1153       real(kind=8) :: rrij,xi,yi,zi
1154       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1155
1156 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1157       evdw=0.0D0
1158 !     if (icall.eq.0) then
1159 !       lprn=.true.
1160 !     else
1161         lprn=.false.
1162 !     endif
1163 !el      ind=0
1164       do i=iatsc_s,iatsc_e
1165         itypi=iabs(itype(i))
1166         if (itypi.eq.ntyp1) cycle
1167         itypi1=iabs(itype(i+1))
1168         xi=c(1,nres+i)
1169         yi=c(2,nres+i)
1170         zi=c(3,nres+i)
1171         dxi=dc_norm(1,nres+i)
1172         dyi=dc_norm(2,nres+i)
1173         dzi=dc_norm(3,nres+i)
1174 !        dsci_inv=dsc_inv(itypi)
1175         dsci_inv=vbld_inv(i+nres)
1176 !
1177 ! Calculate SC interaction energy.
1178 !
1179         do iint=1,nint_gr(i)
1180           do j=istart(i,iint),iend(i,iint)
1181 !el            ind=ind+1
1182             itypj=iabs(itype(j))
1183             if (itypj.eq.ntyp1) cycle
1184 !            dscj_inv=dsc_inv(itypj)
1185             dscj_inv=vbld_inv(j+nres)
1186             chi1=chi(itypi,itypj)
1187             chi2=chi(itypj,itypi)
1188             chi12=chi1*chi2
1189             chip1=chip(itypi)
1190             chip2=chip(itypj)
1191             chip12=chip1*chip2
1192             alf1=alp(itypi)
1193             alf2=alp(itypj)
1194             alf12=0.5D0*(alf1+alf2)
1195 ! For diagnostics only!!!
1196 !           chi1=0.0D0
1197 !           chi2=0.0D0
1198 !           chi12=0.0D0
1199 !           chip1=0.0D0
1200 !           chip2=0.0D0
1201 !           chip12=0.0D0
1202 !           alf1=0.0D0
1203 !           alf2=0.0D0
1204 !           alf12=0.0D0
1205             xj=c(1,nres+j)-xi
1206             yj=c(2,nres+j)-yi
1207             zj=c(3,nres+j)-zi
1208             dxj=dc_norm(1,nres+j)
1209             dyj=dc_norm(2,nres+j)
1210             dzj=dc_norm(3,nres+j)
1211             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1212 !d          if (icall.eq.0) then
1213 !d            rrsave(ind)=rrij
1214 !d          else
1215 !d            rrij=rrsave(ind)
1216 !d          endif
1217             rij=dsqrt(rrij)
1218 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1219             call sc_angular
1220 ! Calculate whole angle-dependent part of epsilon and contributions
1221 ! to its derivatives
1222             fac=(rrij*sigsq)**expon2
1223             e1=fac*fac*aa(itypi,itypj)
1224             e2=fac*bb(itypi,itypj)
1225             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1226             eps2der=evdwij*eps3rt
1227             eps3der=evdwij*eps2rt
1228             evdwij=evdwij*eps2rt*eps3rt
1229             evdw=evdw+evdwij
1230             if (lprn) then
1231             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1232             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1233 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1234 !d     &        restyp(itypi),i,restyp(itypj),j,
1235 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1236 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1237 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1238 !d     &        evdwij
1239             endif
1240 ! Calculate gradient components.
1241             e1=e1*eps1*eps2rt**2*eps3rt**2
1242             fac=-expon*(e1+evdwij)
1243             sigder=fac/sigsq
1244             fac=rrij*fac
1245 ! Calculate radial part of the gradient
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249 ! Calculate the angular part of the gradient and sum add the contributions
1250 ! to the appropriate components of the Cartesian gradient.
1251             call sc_grad
1252           enddo      ! j
1253         enddo        ! iint
1254       enddo          ! i
1255 !     stop
1256       return
1257       end subroutine ebp
1258 !-----------------------------------------------------------------------------
1259       subroutine egb(evdw)
1260 !
1261 ! This subroutine calculates the interaction energy of nonbonded side chains
1262 ! assuming the Gay-Berne potential of interaction.
1263 !
1264       use calc_data
1265 !      implicit real*8 (a-h,o-z)
1266 !      include 'DIMENSIONS'
1267 !      include 'COMMON.GEO'
1268 !      include 'COMMON.VAR'
1269 !      include 'COMMON.LOCAL'
1270 !      include 'COMMON.CHAIN'
1271 !      include 'COMMON.DERIV'
1272 !      include 'COMMON.NAMES'
1273 !      include 'COMMON.INTERACT'
1274 !      include 'COMMON.IOUNITS'
1275 !      include 'COMMON.CALC'
1276 !      include 'COMMON.CONTROL'
1277 !      include 'COMMON.SBRIDGE'
1278       logical :: lprn
1279 !el local variables
1280       integer :: iint,itypi,itypi1,itypj,subchap
1281       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1282       real(kind=8) :: evdw,sig0ij
1283       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1284                     dist_temp, dist_init
1285       integer :: ii
1286 !cccc      energy_dec=.false.
1287 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1288       evdw=0.0D0
1289       lprn=.false.
1290 !     if (icall.eq.0) lprn=.false.
1291 !el      ind=0
1292       do i=iatsc_s,iatsc_e
1293         itypi=iabs(itype(i))
1294         if (itypi.eq.ntyp1) cycle
1295         itypi1=iabs(itype(i+1))
1296         xi=c(1,nres+i)
1297         yi=c(2,nres+i)
1298         zi=c(3,nres+i)
1299           xi=dmod(xi,boxxsize)
1300           if (xi.lt.0) xi=xi+boxxsize
1301           yi=dmod(yi,boxysize)
1302           if (yi.lt.0) yi=yi+boxysize
1303           zi=dmod(zi,boxzsize)
1304           if (zi.lt.0) zi=zi+boxzsize
1305
1306         dxi=dc_norm(1,nres+i)
1307         dyi=dc_norm(2,nres+i)
1308         dzi=dc_norm(3,nres+i)
1309 !        dsci_inv=dsc_inv(itypi)
1310         dsci_inv=vbld_inv(i+nres)
1311 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1312 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1313 !
1314 ! Calculate SC interaction energy.
1315 !
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1319               call dyn_ssbond_ene(i,j,evdwij)
1320               evdw=evdw+evdwij
1321               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1322                               'evdw',i,j,evdwij,' ss'
1323 !              if (energy_dec) write (iout,*) &
1324 !                              'evdw',i,j,evdwij,' ss'
1325             ELSE
1326 !el            ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 !            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1332 !              1.0d0/vbld(j+nres) !d
1333 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1334             sig0ij=sigma(itypi,itypj)
1335             chi1=chi(itypi,itypj)
1336             chi2=chi(itypj,itypi)
1337             chi12=chi1*chi2
1338             chip1=chip(itypi)
1339             chip2=chip(itypj)
1340             chip12=chip1*chip2
1341             alf1=alp(itypi)
1342             alf2=alp(itypj)
1343             alf12=0.5D0*(alf1+alf2)
1344 ! For diagnostics only!!!
1345 !           chi1=0.0D0
1346 !           chi2=0.0D0
1347 !           chi12=0.0D0
1348 !           chip1=0.0D0
1349 !           chip2=0.0D0
1350 !           chip12=0.0D0
1351 !           alf1=0.0D0
1352 !           alf2=0.0D0
1353 !           alf12=0.0D0
1354            xj=c(1,nres+j)
1355            yj=c(2,nres+j)
1356            zj=c(3,nres+j)
1357           xj=dmod(xj,boxxsize)
1358           if (xj.lt.0) xj=xj+boxxsize
1359           yj=dmod(yj,boxysize)
1360           if (yj.lt.0) yj=yj+boxysize
1361           zj=dmod(zj,boxzsize)
1362           if (zj.lt.0) zj=zj+boxzsize
1363       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1364       xj_safe=xj
1365       yj_safe=yj
1366       zj_safe=zj
1367       subchap=0
1368       do xshift=-1,1
1369       do yshift=-1,1
1370       do zshift=-1,1
1371           xj=xj_safe+xshift*boxxsize
1372           yj=yj_safe+yshift*boxysize
1373           zj=zj_safe+zshift*boxzsize
1374           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1375           if(dist_temp.lt.dist_init) then
1376             dist_init=dist_temp
1377             xj_temp=xj
1378             yj_temp=yj
1379             zj_temp=zj
1380             subchap=1
1381           endif
1382        enddo
1383        enddo
1384        enddo
1385        if (subchap.eq.1) then
1386           xj=xj_temp-xi
1387           yj=yj_temp-yi
1388           zj=zj_temp-zi
1389        else
1390           xj=xj_safe-xi
1391           yj=yj_safe-yi
1392           zj=zj_safe-zi
1393        endif
1394             dxj=dc_norm(1,nres+j)
1395             dyj=dc_norm(2,nres+j)
1396             dzj=dc_norm(3,nres+j)
1397 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1398 !            write (iout,*) "j",j," dc_norm",& !d
1399 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1400 !          write(iout,*)"rrij ",rrij
1401 !          write(iout,*)"xj yj zj ", xj, yj, zj
1402 !          write(iout,*)"xi yi zi ", xi, yi, zi
1403 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1404             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1405             rij=dsqrt(rrij)
1406             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1407             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1408 !            print *,sss_ele_cut,sss_ele_grad,&
1409 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1410             if (sss_ele_cut.le.0.0) cycle
1411 ! Calculate angle-dependent terms of energy and contributions to their
1412 ! derivatives.
1413             call sc_angular
1414             sigsq=1.0D0/sigsq
1415             sig=sig0ij*dsqrt(sigsq)
1416             rij_shift=1.0D0/rij-sig+sig0ij
1417 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1418 !            "sig0ij",sig0ij
1419 ! for diagnostics; uncomment
1420 !            rij_shift=1.2*sig0ij
1421 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1422             if (rij_shift.le.0.0D0) then
1423               evdw=1.0D20
1424 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1425 !d     &        restyp(itypi),i,restyp(itypj),j,
1426 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1427               return
1428             endif
1429             sigder=-sig*sigsq
1430 !---------------------------------------------------------------
1431             rij_shift=1.0D0/rij_shift
1432             fac=rij_shift**expon
1433             e1=fac*fac*aa(itypi,itypj)
1434             e2=fac*bb(itypi,itypj)
1435             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1436             eps2der=evdwij*eps3rt
1437             eps3der=evdwij*eps2rt
1438 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1439 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1440 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1441             evdwij=evdwij*eps2rt*eps3rt
1442             evdw=evdw+evdwij*sss_ele_cut
1443             if (lprn) then
1444             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1445             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1446             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1447               restyp(itypi),i,restyp(itypj),j, &
1448               epsi,sigm,chi1,chi2,chip1,chip2, &
1449               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1450               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1451               evdwij
1452             endif
1453
1454             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1455                              'evdw',i,j,evdwij !,"egb"
1456 !            if (energy_dec) write (iout,*) &
1457 !                             'evdw',i,j,evdwij
1458
1459 ! Calculate gradient components.
1460             e1=e1*eps1*eps2rt**2*eps3rt**2
1461             fac=-expon*(e1+evdwij)*rij_shift
1462             sigder=fac*sigder
1463             fac=rij*fac
1464 !            print *,'before fac',fac,rij,evdwij
1465             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1466             /sigma(itypi,itypj)*rij
1467 !            print *,'grad part scale',fac,   &
1468 !             evdwij*sss_ele_grad/sss_ele_cut &
1469 !            /sigma(itypi,itypj)*rij
1470 !            fac=0.0d0
1471 ! Calculate the radial part of the gradient
1472             gg(1)=xj*fac
1473             gg(2)=yj*fac
1474             gg(3)=zj*fac
1475 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1476 ! Calculate angular part of the gradient.
1477             call sc_grad
1478             ENDIF    ! dyn_ss
1479           enddo      ! j
1480         enddo        ! iint
1481       enddo          ! i
1482 !      write (iout,*) "Number of loop steps in EGB:",ind
1483 !ccc      energy_dec=.false.
1484       return
1485       end subroutine egb
1486 !-----------------------------------------------------------------------------
1487       subroutine egbv(evdw)
1488 !
1489 ! This subroutine calculates the interaction energy of nonbonded side chains
1490 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1491 !
1492       use comm_srutu
1493       use calc_data
1494 !      implicit real*8 (a-h,o-z)
1495 !      include 'DIMENSIONS'
1496 !      include 'COMMON.GEO'
1497 !      include 'COMMON.VAR'
1498 !      include 'COMMON.LOCAL'
1499 !      include 'COMMON.CHAIN'
1500 !      include 'COMMON.DERIV'
1501 !      include 'COMMON.NAMES'
1502 !      include 'COMMON.INTERACT'
1503 !      include 'COMMON.IOUNITS'
1504 !      include 'COMMON.CALC'
1505       use comm_srutu
1506 !el      integer :: icall
1507 !el      common /srutu/ icall
1508       logical :: lprn
1509 !el local variables
1510       integer :: iint,itypi,itypi1,itypj
1511       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1512       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1513
1514 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       lprn=.false.
1517 !     if (icall.eq.0) lprn=.true.
1518 !el      ind=0
1519       do i=iatsc_s,iatsc_e
1520         itypi=iabs(itype(i))
1521         if (itypi.eq.ntyp1) cycle
1522         itypi1=iabs(itype(i+1))
1523         xi=c(1,nres+i)
1524         yi=c(2,nres+i)
1525         zi=c(3,nres+i)
1526         dxi=dc_norm(1,nres+i)
1527         dyi=dc_norm(2,nres+i)
1528         dzi=dc_norm(3,nres+i)
1529 !        dsci_inv=dsc_inv(itypi)
1530         dsci_inv=vbld_inv(i+nres)
1531 !
1532 ! Calculate SC interaction energy.
1533 !
1534         do iint=1,nint_gr(i)
1535           do j=istart(i,iint),iend(i,iint)
1536 !el            ind=ind+1
1537             itypj=iabs(itype(j))
1538             if (itypj.eq.ntyp1) cycle
1539 !            dscj_inv=dsc_inv(itypj)
1540             dscj_inv=vbld_inv(j+nres)
1541             sig0ij=sigma(itypi,itypj)
1542             r0ij=r0(itypi,itypj)
1543             chi1=chi(itypi,itypj)
1544             chi2=chi(itypj,itypi)
1545             chi12=chi1*chi2
1546             chip1=chip(itypi)
1547             chip2=chip(itypj)
1548             chip12=chip1*chip2
1549             alf1=alp(itypi)
1550             alf2=alp(itypj)
1551             alf12=0.5D0*(alf1+alf2)
1552 ! For diagnostics only!!!
1553 !           chi1=0.0D0
1554 !           chi2=0.0D0
1555 !           chi12=0.0D0
1556 !           chip1=0.0D0
1557 !           chip2=0.0D0
1558 !           chip12=0.0D0
1559 !           alf1=0.0D0
1560 !           alf2=0.0D0
1561 !           alf12=0.0D0
1562             xj=c(1,nres+j)-xi
1563             yj=c(2,nres+j)-yi
1564             zj=c(3,nres+j)-zi
1565             dxj=dc_norm(1,nres+j)
1566             dyj=dc_norm(2,nres+j)
1567             dzj=dc_norm(3,nres+j)
1568             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1569             rij=dsqrt(rrij)
1570 ! Calculate angle-dependent terms of energy and contributions to their
1571 ! derivatives.
1572             call sc_angular
1573             sigsq=1.0D0/sigsq
1574             sig=sig0ij*dsqrt(sigsq)
1575             rij_shift=1.0D0/rij-sig+r0ij
1576 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1577             if (rij_shift.le.0.0D0) then
1578               evdw=1.0D20
1579               return
1580             endif
1581             sigder=-sig*sigsq
1582 !---------------------------------------------------------------
1583             rij_shift=1.0D0/rij_shift
1584             fac=rij_shift**expon
1585             e1=fac*fac*aa(itypi,itypj)
1586             e2=fac*bb(itypi,itypj)
1587             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1588             eps2der=evdwij*eps3rt
1589             eps3der=evdwij*eps2rt
1590             fac_augm=rrij**expon
1591             e_augm=augm(itypi,itypj)*fac_augm
1592             evdwij=evdwij*eps2rt*eps3rt
1593             evdw=evdw+evdwij+e_augm
1594             if (lprn) then
1595             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1596             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1597             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1598               restyp(itypi),i,restyp(itypj),j,&
1599               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1600               chi1,chi2,chip1,chip2,&
1601               eps1,eps2rt**2,eps3rt**2,&
1602               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1603               evdwij+e_augm
1604             endif
1605 ! Calculate gradient components.
1606             e1=e1*eps1*eps2rt**2*eps3rt**2
1607             fac=-expon*(e1+evdwij)*rij_shift
1608             sigder=fac*sigder
1609             fac=rij*fac-2*expon*rrij*e_augm
1610 ! Calculate the radial part of the gradient
1611             gg(1)=xj*fac
1612             gg(2)=yj*fac
1613             gg(3)=zj*fac
1614 ! Calculate angular part of the gradient.
1615             call sc_grad
1616           enddo      ! j
1617         enddo        ! iint
1618       enddo          ! i
1619       end subroutine egbv
1620 !-----------------------------------------------------------------------------
1621 !el      subroutine sc_angular in module geometry
1622 !-----------------------------------------------------------------------------
1623       subroutine e_softsphere(evdw)
1624 !
1625 ! This subroutine calculates the interaction energy of nonbonded side chains
1626 ! assuming the LJ potential of interaction.
1627 !
1628 !      implicit real*8 (a-h,o-z)
1629 !      include 'DIMENSIONS'
1630       real(kind=8),parameter :: accur=1.0d-10
1631 !      include 'COMMON.GEO'
1632 !      include 'COMMON.VAR'
1633 !      include 'COMMON.LOCAL'
1634 !      include 'COMMON.CHAIN'
1635 !      include 'COMMON.DERIV'
1636 !      include 'COMMON.INTERACT'
1637 !      include 'COMMON.TORSION'
1638 !      include 'COMMON.SBRIDGE'
1639 !      include 'COMMON.NAMES'
1640 !      include 'COMMON.IOUNITS'
1641 !      include 'COMMON.CONTACTS'
1642       real(kind=8),dimension(3) :: gg
1643 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1644 !el local variables
1645       integer :: i,iint,j,itypi,itypi1,itypj,k
1646       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1647       real(kind=8) :: fac
1648
1649       evdw=0.0D0
1650       do i=iatsc_s,iatsc_e
1651         itypi=iabs(itype(i))
1652         if (itypi.eq.ntyp1) cycle
1653         itypi1=iabs(itype(i+1))
1654         xi=c(1,nres+i)
1655         yi=c(2,nres+i)
1656         zi=c(3,nres+i)
1657 !
1658 ! Calculate SC interaction energy.
1659 !
1660         do iint=1,nint_gr(i)
1661 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1662 !d   &                  'iend=',iend(i,iint)
1663           do j=istart(i,iint),iend(i,iint)
1664             itypj=iabs(itype(j))
1665             if (itypj.eq.ntyp1) cycle
1666             xj=c(1,nres+j)-xi
1667             yj=c(2,nres+j)-yi
1668             zj=c(3,nres+j)-zi
1669             rij=xj*xj+yj*yj+zj*zj
1670 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1671             r0ij=r0(itypi,itypj)
1672             r0ijsq=r0ij*r0ij
1673 !            print *,i,j,r0ij,dsqrt(rij)
1674             if (rij.lt.r0ijsq) then
1675               evdwij=0.25d0*(rij-r0ijsq)**2
1676               fac=rij-r0ijsq
1677             else
1678               evdwij=0.0d0
1679               fac=0.0d0
1680             endif
1681             evdw=evdw+evdwij
1682 !
1683 ! Calculate the components of the gradient in DC and X
1684 !
1685             gg(1)=xj*fac
1686             gg(2)=yj*fac
1687             gg(3)=zj*fac
1688             do k=1,3
1689               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1690               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1691               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1692               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1693             enddo
1694 !grad            do k=i,j-1
1695 !grad              do l=1,3
1696 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1697 !grad              enddo
1698 !grad            enddo
1699           enddo ! j
1700         enddo ! iint
1701       enddo ! i
1702       return
1703       end subroutine e_softsphere
1704 !-----------------------------------------------------------------------------
1705       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1706 !
1707 ! Soft-sphere potential of p-p interaction
1708 !
1709 !      implicit real*8 (a-h,o-z)
1710 !      include 'DIMENSIONS'
1711 !      include 'COMMON.CONTROL'
1712 !      include 'COMMON.IOUNITS'
1713 !      include 'COMMON.GEO'
1714 !      include 'COMMON.VAR'
1715 !      include 'COMMON.LOCAL'
1716 !      include 'COMMON.CHAIN'
1717 !      include 'COMMON.DERIV'
1718 !      include 'COMMON.INTERACT'
1719 !      include 'COMMON.CONTACTS'
1720 !      include 'COMMON.TORSION'
1721 !      include 'COMMON.VECTORS'
1722 !      include 'COMMON.FFIELD'
1723       real(kind=8),dimension(3) :: ggg
1724 !d      write(iout,*) 'In EELEC_soft_sphere'
1725 !el local variables
1726       integer :: i,j,k,num_conti,iteli,itelj
1727       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1728       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1729       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1730
1731       ees=0.0D0
1732       evdw1=0.0D0
1733       eel_loc=0.0d0
1734       eello_turn3=0.0d0
1735       eello_turn4=0.0d0
1736 !el      ind=0
1737       do i=iatel_s,iatel_e
1738         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1739         dxi=dc(1,i)
1740         dyi=dc(2,i)
1741         dzi=dc(3,i)
1742         xmedi=c(1,i)+0.5d0*dxi
1743         ymedi=c(2,i)+0.5d0*dyi
1744         zmedi=c(3,i)+0.5d0*dzi
1745         num_conti=0
1746 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1747         do j=ielstart(i),ielend(i)
1748           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1749 !el          ind=ind+1
1750           iteli=itel(i)
1751           itelj=itel(j)
1752           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1753           r0ij=rpp(iteli,itelj)
1754           r0ijsq=r0ij*r0ij
1755           dxj=dc(1,j)
1756           dyj=dc(2,j)
1757           dzj=dc(3,j)
1758           xj=c(1,j)+0.5D0*dxj-xmedi
1759           yj=c(2,j)+0.5D0*dyj-ymedi
1760           zj=c(3,j)+0.5D0*dzj-zmedi
1761           rij=xj*xj+yj*yj+zj*zj
1762           if (rij.lt.r0ijsq) then
1763             evdw1ij=0.25d0*(rij-r0ijsq)**2
1764             fac=rij-r0ijsq
1765           else
1766             evdw1ij=0.0d0
1767             fac=0.0d0
1768           endif
1769           evdw1=evdw1+evdw1ij
1770 !
1771 ! Calculate contributions to the Cartesian gradient.
1772 !
1773           ggg(1)=fac*xj
1774           ggg(2)=fac*yj
1775           ggg(3)=fac*zj
1776           do k=1,3
1777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1778             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1779           enddo
1780 !
1781 ! Loop over residues i+1 thru j-1.
1782 !
1783 !grad          do k=i+1,j-1
1784 !grad            do l=1,3
1785 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1786 !grad            enddo
1787 !grad          enddo
1788         enddo ! j
1789       enddo   ! i
1790 !grad      do i=nnt,nct-1
1791 !grad        do k=1,3
1792 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1793 !grad        enddo
1794 !grad        do j=i+1,nct-1
1795 !grad          do k=1,3
1796 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1797 !grad          enddo
1798 !grad        enddo
1799 !grad      enddo
1800       return
1801       end subroutine eelec_soft_sphere
1802 !-----------------------------------------------------------------------------
1803       subroutine vec_and_deriv
1804 !      implicit real*8 (a-h,o-z)
1805 !      include 'DIMENSIONS'
1806 #ifdef MPI
1807       include 'mpif.h'
1808 #endif
1809 !      include 'COMMON.IOUNITS'
1810 !      include 'COMMON.GEO'
1811 !      include 'COMMON.VAR'
1812 !      include 'COMMON.LOCAL'
1813 !      include 'COMMON.CHAIN'
1814 !      include 'COMMON.VECTORS'
1815 !      include 'COMMON.SETUP'
1816 !      include 'COMMON.TIME1'
1817       real(kind=8),dimension(3,3,2) :: uyder,uzder
1818       real(kind=8),dimension(2) :: vbld_inv_temp
1819 ! Compute the local reference systems. For reference system (i), the
1820 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1821 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1822 !el local variables
1823       integer :: i,j,k,l
1824       real(kind=8) :: facy,fac,costh
1825
1826 #ifdef PARVEC
1827       do i=ivec_start,ivec_end
1828 #else
1829       do i=1,nres-1
1830 #endif
1831           if (i.eq.nres-1) then
1832 ! Case of the last full residue
1833 ! Compute the Z-axis
1834             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1835             costh=dcos(pi-theta(nres))
1836             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1837             do k=1,3
1838               uz(k,i)=fac*uz(k,i)
1839             enddo
1840 ! Compute the derivatives of uz
1841             uzder(1,1,1)= 0.0d0
1842             uzder(2,1,1)=-dc_norm(3,i-1)
1843             uzder(3,1,1)= dc_norm(2,i-1)
1844             uzder(1,2,1)= dc_norm(3,i-1)
1845             uzder(2,2,1)= 0.0d0
1846             uzder(3,2,1)=-dc_norm(1,i-1)
1847             uzder(1,3,1)=-dc_norm(2,i-1)
1848             uzder(2,3,1)= dc_norm(1,i-1)
1849             uzder(3,3,1)= 0.0d0
1850             uzder(1,1,2)= 0.0d0
1851             uzder(2,1,2)= dc_norm(3,i)
1852             uzder(3,1,2)=-dc_norm(2,i)
1853             uzder(1,2,2)=-dc_norm(3,i)
1854             uzder(2,2,2)= 0.0d0
1855             uzder(3,2,2)= dc_norm(1,i)
1856             uzder(1,3,2)= dc_norm(2,i)
1857             uzder(2,3,2)=-dc_norm(1,i)
1858             uzder(3,3,2)= 0.0d0
1859 ! Compute the Y-axis
1860             facy=fac
1861             do k=1,3
1862               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1863             enddo
1864 ! Compute the derivatives of uy
1865             do j=1,3
1866               do k=1,3
1867                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1868                               -dc_norm(k,i)*dc_norm(j,i-1)
1869                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1870               enddo
1871               uyder(j,j,1)=uyder(j,j,1)-costh
1872               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1873             enddo
1874             do j=1,2
1875               do k=1,3
1876                 do l=1,3
1877                   uygrad(l,k,j,i)=uyder(l,k,j)
1878                   uzgrad(l,k,j,i)=uzder(l,k,j)
1879                 enddo
1880               enddo
1881             enddo
1882             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1883             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1884             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1885             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1886           else
1887 ! Other residues
1888 ! Compute the Z-axis
1889             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1890             costh=dcos(pi-theta(i+2))
1891             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1892             do k=1,3
1893               uz(k,i)=fac*uz(k,i)
1894             enddo
1895 ! Compute the derivatives of uz
1896             uzder(1,1,1)= 0.0d0
1897             uzder(2,1,1)=-dc_norm(3,i+1)
1898             uzder(3,1,1)= dc_norm(2,i+1)
1899             uzder(1,2,1)= dc_norm(3,i+1)
1900             uzder(2,2,1)= 0.0d0
1901             uzder(3,2,1)=-dc_norm(1,i+1)
1902             uzder(1,3,1)=-dc_norm(2,i+1)
1903             uzder(2,3,1)= dc_norm(1,i+1)
1904             uzder(3,3,1)= 0.0d0
1905             uzder(1,1,2)= 0.0d0
1906             uzder(2,1,2)= dc_norm(3,i)
1907             uzder(3,1,2)=-dc_norm(2,i)
1908             uzder(1,2,2)=-dc_norm(3,i)
1909             uzder(2,2,2)= 0.0d0
1910             uzder(3,2,2)= dc_norm(1,i)
1911             uzder(1,3,2)= dc_norm(2,i)
1912             uzder(2,3,2)=-dc_norm(1,i)
1913             uzder(3,3,2)= 0.0d0
1914 ! Compute the Y-axis
1915             facy=fac
1916             do k=1,3
1917               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1918             enddo
1919 ! Compute the derivatives of uy
1920             do j=1,3
1921               do k=1,3
1922                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1923                               -dc_norm(k,i)*dc_norm(j,i+1)
1924                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1925               enddo
1926               uyder(j,j,1)=uyder(j,j,1)-costh
1927               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1928             enddo
1929             do j=1,2
1930               do k=1,3
1931                 do l=1,3
1932                   uygrad(l,k,j,i)=uyder(l,k,j)
1933                   uzgrad(l,k,j,i)=uzder(l,k,j)
1934                 enddo
1935               enddo
1936             enddo
1937             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1938             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1939             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1940             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1941           endif
1942       enddo
1943       do i=1,nres-1
1944         vbld_inv_temp(1)=vbld_inv(i+1)
1945         if (i.lt.nres-1) then
1946           vbld_inv_temp(2)=vbld_inv(i+2)
1947           else
1948           vbld_inv_temp(2)=vbld_inv(i)
1949           endif
1950         do j=1,2
1951           do k=1,3
1952             do l=1,3
1953               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1954               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1955             enddo
1956           enddo
1957         enddo
1958       enddo
1959 #if defined(PARVEC) && defined(MPI)
1960       if (nfgtasks1.gt.1) then
1961         time00=MPI_Wtime()
1962 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1963 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1964 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1965         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1966          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1967          FG_COMM1,IERR)
1968         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1969          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1970          FG_COMM1,IERR)
1971         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1972          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1973          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1974         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1975          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1976          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1977         time_gather=time_gather+MPI_Wtime()-time00
1978       endif
1979 !      if (fg_rank.eq.0) then
1980 !        write (iout,*) "Arrays UY and UZ"
1981 !        do i=1,nres-1
1982 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1983 !     &     (uz(k,i),k=1,3)
1984 !        enddo
1985 !      endif
1986 #endif
1987       return
1988       end subroutine vec_and_deriv
1989 !-----------------------------------------------------------------------------
1990       subroutine check_vecgrad
1991 !      implicit real*8 (a-h,o-z)
1992 !      include 'DIMENSIONS'
1993 !      include 'COMMON.IOUNITS'
1994 !      include 'COMMON.GEO'
1995 !      include 'COMMON.VAR'
1996 !      include 'COMMON.LOCAL'
1997 !      include 'COMMON.CHAIN'
1998 !      include 'COMMON.VECTORS'
1999       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2000       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2001       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2002       real(kind=8),dimension(3) :: erij
2003       real(kind=8) :: delta=1.0d-7
2004 !el local variables
2005       integer :: i,j,k,l
2006
2007       call vec_and_deriv
2008 !d      do i=1,nres
2009 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2010 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2011 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2012 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2013 !d     &     (dc_norm(if90,i),if90=1,3)
2014 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2015 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2016 !d          write(iout,'(a)')
2017 !d      enddo
2018       do i=1,nres
2019         do j=1,2
2020           do k=1,3
2021             do l=1,3
2022               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2023               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2024             enddo
2025           enddo
2026         enddo
2027       enddo
2028       call vec_and_deriv
2029       do i=1,nres
2030         do j=1,3
2031           uyt(j,i)=uy(j,i)
2032           uzt(j,i)=uz(j,i)
2033         enddo
2034       enddo
2035       do i=1,nres
2036 !d        write (iout,*) 'i=',i
2037         do k=1,3
2038           erij(k)=dc_norm(k,i)
2039         enddo
2040         do j=1,3
2041           do k=1,3
2042             dc_norm(k,i)=erij(k)
2043           enddo
2044           dc_norm(j,i)=dc_norm(j,i)+delta
2045 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2046 !          do k=1,3
2047 !            dc_norm(k,i)=dc_norm(k,i)/fac
2048 !          enddo
2049 !          write (iout,*) (dc_norm(k,i),k=1,3)
2050 !          write (iout,*) (erij(k),k=1,3)
2051           call vec_and_deriv
2052           do k=1,3
2053             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2054             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2055             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2056             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2057           enddo
2058 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2059 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2060 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2061         enddo
2062         do k=1,3
2063           dc_norm(k,i)=erij(k)
2064         enddo
2065 !d        do k=1,3
2066 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2067 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2068 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2069 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2070 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2071 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2072 !d          write (iout,'(a)')
2073 !d        enddo
2074       enddo
2075       return
2076       end subroutine check_vecgrad
2077 !-----------------------------------------------------------------------------
2078       subroutine set_matrices
2079 !      implicit real*8 (a-h,o-z)
2080 !      include 'DIMENSIONS'
2081 #ifdef MPI
2082       include "mpif.h"
2083 !      include "COMMON.SETUP"
2084       integer :: IERR
2085       integer :: status(MPI_STATUS_SIZE)
2086 #endif
2087 !      include 'COMMON.IOUNITS'
2088 !      include 'COMMON.GEO'
2089 !      include 'COMMON.VAR'
2090 !      include 'COMMON.LOCAL'
2091 !      include 'COMMON.CHAIN'
2092 !      include 'COMMON.DERIV'
2093 !      include 'COMMON.INTERACT'
2094 !      include 'COMMON.CONTACTS'
2095 !      include 'COMMON.TORSION'
2096 !      include 'COMMON.VECTORS'
2097 !      include 'COMMON.FFIELD'
2098       real(kind=8) :: auxvec(2),auxmat(2,2)
2099       integer :: i,iti1,iti,k,l
2100       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2101
2102 !
2103 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2104 ! to calculate the el-loc multibody terms of various order.
2105 !
2106 !AL el      mu=0.0d0
2107 #ifdef PARMAT
2108       do i=ivec_start+2,ivec_end+2
2109 #else
2110       do i=3,nres+1
2111 #endif
2112         if (i .lt. nres+1) then
2113           sin1=dsin(phi(i))
2114           cos1=dcos(phi(i))
2115           sintab(i-2)=sin1
2116           costab(i-2)=cos1
2117           obrot(1,i-2)=cos1
2118           obrot(2,i-2)=sin1
2119           sin2=dsin(2*phi(i))
2120           cos2=dcos(2*phi(i))
2121           sintab2(i-2)=sin2
2122           costab2(i-2)=cos2
2123           obrot2(1,i-2)=cos2
2124           obrot2(2,i-2)=sin2
2125           Ug(1,1,i-2)=-cos1
2126           Ug(1,2,i-2)=-sin1
2127           Ug(2,1,i-2)=-sin1
2128           Ug(2,2,i-2)= cos1
2129           Ug2(1,1,i-2)=-cos2
2130           Ug2(1,2,i-2)=-sin2
2131           Ug2(2,1,i-2)=-sin2
2132           Ug2(2,2,i-2)= cos2
2133         else
2134           costab(i-2)=1.0d0
2135           sintab(i-2)=0.0d0
2136           obrot(1,i-2)=1.0d0
2137           obrot(2,i-2)=0.0d0
2138           obrot2(1,i-2)=0.0d0
2139           obrot2(2,i-2)=0.0d0
2140           Ug(1,1,i-2)=1.0d0
2141           Ug(1,2,i-2)=0.0d0
2142           Ug(2,1,i-2)=0.0d0
2143           Ug(2,2,i-2)=1.0d0
2144           Ug2(1,1,i-2)=0.0d0
2145           Ug2(1,2,i-2)=0.0d0
2146           Ug2(2,1,i-2)=0.0d0
2147           Ug2(2,2,i-2)=0.0d0
2148         endif
2149         if (i .gt. 3 .and. i .lt. nres+1) then
2150           obrot_der(1,i-2)=-sin1
2151           obrot_der(2,i-2)= cos1
2152           Ugder(1,1,i-2)= sin1
2153           Ugder(1,2,i-2)=-cos1
2154           Ugder(2,1,i-2)=-cos1
2155           Ugder(2,2,i-2)=-sin1
2156           dwacos2=cos2+cos2
2157           dwasin2=sin2+sin2
2158           obrot2_der(1,i-2)=-dwasin2
2159           obrot2_der(2,i-2)= dwacos2
2160           Ug2der(1,1,i-2)= dwasin2
2161           Ug2der(1,2,i-2)=-dwacos2
2162           Ug2der(2,1,i-2)=-dwacos2
2163           Ug2der(2,2,i-2)=-dwasin2
2164         else
2165           obrot_der(1,i-2)=0.0d0
2166           obrot_der(2,i-2)=0.0d0
2167           Ugder(1,1,i-2)=0.0d0
2168           Ugder(1,2,i-2)=0.0d0
2169           Ugder(2,1,i-2)=0.0d0
2170           Ugder(2,2,i-2)=0.0d0
2171           obrot2_der(1,i-2)=0.0d0
2172           obrot2_der(2,i-2)=0.0d0
2173           Ug2der(1,1,i-2)=0.0d0
2174           Ug2der(1,2,i-2)=0.0d0
2175           Ug2der(2,1,i-2)=0.0d0
2176           Ug2der(2,2,i-2)=0.0d0
2177         endif
2178 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2179         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2180           iti = itortyp(itype(i-2))
2181         else
2182           iti=ntortyp+1
2183         endif
2184 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2185         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2186           iti1 = itortyp(itype(i-1))
2187         else
2188           iti1=ntortyp+1
2189         endif
2190 !d        write (iout,*) '*******i',i,' iti1',iti
2191 !d        write (iout,*) 'b1',b1(:,iti)
2192 !d        write (iout,*) 'b2',b2(:,iti)
2193 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2194 !        if (i .gt. iatel_s+2) then
2195         if (i .gt. nnt+2) then
2196           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2197           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2198           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2199           then
2200           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2201           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2202           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2203           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2204           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2205           endif
2206         else
2207           do k=1,2
2208             Ub2(k,i-2)=0.0d0
2209             Ctobr(k,i-2)=0.0d0
2210             Dtobr2(k,i-2)=0.0d0
2211             do l=1,2
2212               EUg(l,k,i-2)=0.0d0
2213               CUg(l,k,i-2)=0.0d0
2214               DUg(l,k,i-2)=0.0d0
2215               DtUg2(l,k,i-2)=0.0d0
2216             enddo
2217           enddo
2218         endif
2219         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2220         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2221         do k=1,2
2222           muder(k,i-2)=Ub2der(k,i-2)
2223         enddo
2224 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2225         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2226           if (itype(i-1).le.ntyp) then
2227             iti1 = itortyp(itype(i-1))
2228           else
2229             iti1=ntortyp+1
2230           endif
2231         else
2232           iti1=ntortyp+1
2233         endif
2234         do k=1,2
2235           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2236         enddo
2237 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2238 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2239 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2240 !d        write (iout,*) 'mu1',mu1(:,i-2)
2241 !d        write (iout,*) 'mu2',mu2(:,i-2)
2242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2243         then
2244         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2245         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2246         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2247         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2248         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2249 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2250         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2251         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2252         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2253         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2254         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2255         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2256         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2257         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2258         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2259         endif
2260       enddo
2261 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2262 ! The order of matrices is from left to right.
2263       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2264       then
2265 !      do i=max0(ivec_start,2),ivec_end
2266       do i=2,nres-1
2267         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2268         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2269         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2270         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2271         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2272         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2273         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2274         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2275       enddo
2276       endif
2277 #if defined(MPI) && defined(PARMAT)
2278 #ifdef DEBUG
2279 !      if (fg_rank.eq.0) then
2280         write (iout,*) "Arrays UG and UGDER before GATHER"
2281         do i=1,nres-1
2282           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2283            ((ug(l,k,i),l=1,2),k=1,2),&
2284            ((ugder(l,k,i),l=1,2),k=1,2)
2285         enddo
2286         write (iout,*) "Arrays UG2 and UG2DER"
2287         do i=1,nres-1
2288           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2289            ((ug2(l,k,i),l=1,2),k=1,2),&
2290            ((ug2der(l,k,i),l=1,2),k=1,2)
2291         enddo
2292         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2293         do i=1,nres-1
2294           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2295            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2296            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2297         enddo
2298         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2299         do i=1,nres-1
2300           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2301            costab(i),sintab(i),costab2(i),sintab2(i)
2302         enddo
2303         write (iout,*) "Array MUDER"
2304         do i=1,nres-1
2305           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2306         enddo
2307 !      endif
2308 #endif
2309       if (nfgtasks.gt.1) then
2310         time00=MPI_Wtime()
2311 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2312 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2313 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2314 #ifdef MATGATHER
2315         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2316          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2317          FG_COMM1,IERR)
2318         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2319          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2320          FG_COMM1,IERR)
2321         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2322          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2323          FG_COMM1,IERR)
2324         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2325          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2326          FG_COMM1,IERR)
2327         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2328          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2329          FG_COMM1,IERR)
2330         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2331          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2332          FG_COMM1,IERR)
2333         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2334          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2335          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2336         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2337          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2338          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2339         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2340          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2341          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2342         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2343          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2344          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2345         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2346         then
2347         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2348          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2349          FG_COMM1,IERR)
2350         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2351          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2352          FG_COMM1,IERR)
2353         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2354          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2355          FG_COMM1,IERR)
2356        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2357          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2358          FG_COMM1,IERR)
2359         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2360          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2361          FG_COMM1,IERR)
2362         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2363          ivec_count(fg_rank1),&
2364          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2365          FG_COMM1,IERR)
2366         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2367          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2368          FG_COMM1,IERR)
2369         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2370          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2371          FG_COMM1,IERR)
2372         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2373          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2374          FG_COMM1,IERR)
2375         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2376          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2377          FG_COMM1,IERR)
2378         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2379          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2380          FG_COMM1,IERR)
2381         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2382          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2383          FG_COMM1,IERR)
2384         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2385          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2386          FG_COMM1,IERR)
2387         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2388          ivec_count(fg_rank1),&
2389          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2390          FG_COMM1,IERR)
2391         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2392          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2393          FG_COMM1,IERR)
2394        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2395          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2396          FG_COMM1,IERR)
2397         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2398          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2399          FG_COMM1,IERR)
2400        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2401          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2402          FG_COMM1,IERR)
2403         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2404          ivec_count(fg_rank1),&
2405          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2406          FG_COMM1,IERR)
2407         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2408          ivec_count(fg_rank1),&
2409          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2410          FG_COMM1,IERR)
2411         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2412          ivec_count(fg_rank1),&
2413          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2414          MPI_MAT2,FG_COMM1,IERR)
2415         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2416          ivec_count(fg_rank1),&
2417          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2418          MPI_MAT2,FG_COMM1,IERR)
2419         endif
2420 #else
2421 ! Passes matrix info through the ring
2422       isend=fg_rank1
2423       irecv=fg_rank1-1
2424       if (irecv.lt.0) irecv=nfgtasks1-1
2425       iprev=irecv
2426       inext=fg_rank1+1
2427       if (inext.ge.nfgtasks1) inext=0
2428       do i=1,nfgtasks1-1
2429 !        write (iout,*) "isend",isend," irecv",irecv
2430 !        call flush(iout)
2431         lensend=lentyp(isend)
2432         lenrecv=lentyp(irecv)
2433 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2434 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2435 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2436 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2437 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2438 !        write (iout,*) "Gather ROTAT1"
2439 !        call flush(iout)
2440 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2441 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2442 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2443 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2444 !        write (iout,*) "Gather ROTAT2"
2445 !        call flush(iout)
2446         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2447          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2448          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2449          iprev,4400+irecv,FG_COMM,status,IERR)
2450 !        write (iout,*) "Gather ROTAT_OLD"
2451 !        call flush(iout)
2452         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2453          MPI_PRECOMP11(lensend),inext,5500+isend,&
2454          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2455          iprev,5500+irecv,FG_COMM,status,IERR)
2456 !        write (iout,*) "Gather PRECOMP11"
2457 !        call flush(iout)
2458         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2459          MPI_PRECOMP12(lensend),inext,6600+isend,&
2460          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2461          iprev,6600+irecv,FG_COMM,status,IERR)
2462 !        write (iout,*) "Gather PRECOMP12"
2463 !        call flush(iout)
2464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2465         then
2466         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2467          MPI_ROTAT2(lensend),inext,7700+isend,&
2468          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2469          iprev,7700+irecv,FG_COMM,status,IERR)
2470 !        write (iout,*) "Gather PRECOMP21"
2471 !        call flush(iout)
2472         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2473          MPI_PRECOMP22(lensend),inext,8800+isend,&
2474          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2475          iprev,8800+irecv,FG_COMM,status,IERR)
2476 !        write (iout,*) "Gather PRECOMP22"
2477 !        call flush(iout)
2478         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2479          MPI_PRECOMP23(lensend),inext,9900+isend,&
2480          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2481          MPI_PRECOMP23(lenrecv),&
2482          iprev,9900+irecv,FG_COMM,status,IERR)
2483 !        write (iout,*) "Gather PRECOMP23"
2484 !        call flush(iout)
2485         endif
2486         isend=irecv
2487         irecv=irecv-1
2488         if (irecv.lt.0) irecv=nfgtasks1-1
2489       enddo
2490 #endif
2491         time_gather=time_gather+MPI_Wtime()-time00
2492       endif
2493 #ifdef DEBUG
2494 !      if (fg_rank.eq.0) then
2495         write (iout,*) "Arrays UG and UGDER"
2496         do i=1,nres-1
2497           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2498            ((ug(l,k,i),l=1,2),k=1,2),&
2499            ((ugder(l,k,i),l=1,2),k=1,2)
2500         enddo
2501         write (iout,*) "Arrays UG2 and UG2DER"
2502         do i=1,nres-1
2503           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2504            ((ug2(l,k,i),l=1,2),k=1,2),&
2505            ((ug2der(l,k,i),l=1,2),k=1,2)
2506         enddo
2507         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2508         do i=1,nres-1
2509           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2510            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2511            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2512         enddo
2513         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2514         do i=1,nres-1
2515           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2516            costab(i),sintab(i),costab2(i),sintab2(i)
2517         enddo
2518         write (iout,*) "Array MUDER"
2519         do i=1,nres-1
2520           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2521         enddo
2522 !      endif
2523 #endif
2524 #endif
2525 !d      do i=1,nres
2526 !d        iti = itortyp(itype(i))
2527 !d        write (iout,*) i
2528 !d        do j=1,2
2529 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2530 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2531 !d        enddo
2532 !d      enddo
2533       return
2534       end subroutine set_matrices
2535 !-----------------------------------------------------------------------------
2536       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2537 !
2538 ! This subroutine calculates the average interaction energy and its gradient
2539 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2540 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2541 ! The potential depends both on the distance of peptide-group centers and on
2542 ! the orientation of the CA-CA virtual bonds.
2543 !
2544       use comm_locel
2545 !      implicit real*8 (a-h,o-z)
2546 #ifdef MPI
2547       include 'mpif.h'
2548 #endif
2549 !      include 'DIMENSIONS'
2550 !      include 'COMMON.CONTROL'
2551 !      include 'COMMON.SETUP'
2552 !      include 'COMMON.IOUNITS'
2553 !      include 'COMMON.GEO'
2554 !      include 'COMMON.VAR'
2555 !      include 'COMMON.LOCAL'
2556 !      include 'COMMON.CHAIN'
2557 !      include 'COMMON.DERIV'
2558 !      include 'COMMON.INTERACT'
2559 !      include 'COMMON.CONTACTS'
2560 !      include 'COMMON.TORSION'
2561 !      include 'COMMON.VECTORS'
2562 !      include 'COMMON.FFIELD'
2563 !      include 'COMMON.TIME1'
2564       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2565       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2566       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2567 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2568       real(kind=8),dimension(4) :: muij
2569 !el      integer :: num_conti,j1,j2
2570 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2571 !el        dz_normi,xmedi,ymedi,zmedi
2572
2573 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2574 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2575 !el          num_conti,j1,j2
2576
2577 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2578 #ifdef MOMENT
2579       real(kind=8) :: scal_el=1.0d0
2580 #else
2581       real(kind=8) :: scal_el=0.5d0
2582 #endif
2583 ! 12/13/98
2584 ! 13-go grudnia roku pamietnego...
2585       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2586                                              0.0d0,1.0d0,0.0d0,&
2587                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2588 !el local variables
2589       integer :: i,k,j
2590       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2591       real(kind=8) :: fac,t_eelecij
2592
2593
2594 !d      write(iout,*) 'In EELEC'
2595 !d      do i=1,nloctyp
2596 !d        write(iout,*) 'Type',i
2597 !d        write(iout,*) 'B1',B1(:,i)
2598 !d        write(iout,*) 'B2',B2(:,i)
2599 !d        write(iout,*) 'CC',CC(:,:,i)
2600 !d        write(iout,*) 'DD',DD(:,:,i)
2601 !d        write(iout,*) 'EE',EE(:,:,i)
2602 !d      enddo
2603 !d      call check_vecgrad
2604 !d      stop
2605 !      ees=0.0d0  !AS
2606 !      evdw1=0.0d0
2607 !      eel_loc=0.0d0
2608 !      eello_turn3=0.0d0
2609 !      eello_turn4=0.0d0
2610       t_eelecij=0.0d0
2611       ees=0.0D0
2612       evdw1=0.0D0
2613       eel_loc=0.0d0
2614       eello_turn3=0.0d0
2615       eello_turn4=0.0d0
2616 !
2617
2618       if (icheckgrad.eq.1) then
2619 !el
2620 !        do i=0,2*nres+2
2621 !          dc_norm(1,i)=0.0d0
2622 !          dc_norm(2,i)=0.0d0
2623 !          dc_norm(3,i)=0.0d0
2624 !        enddo
2625         do i=1,nres-1
2626           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2627           do k=1,3
2628             dc_norm(k,i)=dc(k,i)*fac
2629           enddo
2630 !          write (iout,*) 'i',i,' fac',fac
2631         enddo
2632       endif
2633       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2634           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2635           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2636 !        call vec_and_deriv
2637 #ifdef TIMING
2638         time01=MPI_Wtime()
2639 #endif
2640         call set_matrices
2641 #ifdef TIMING
2642         time_mat=time_mat+MPI_Wtime()-time01
2643 #endif
2644       endif
2645 !d      do i=1,nres-1
2646 !d        write (iout,*) 'i=',i
2647 !d        do k=1,3
2648 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2649 !d        enddo
2650 !d        do k=1,3
2651 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2652 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2653 !d        enddo
2654 !d      enddo
2655       t_eelecij=0.0d0
2656       ees=0.0D0
2657       evdw1=0.0D0
2658       eel_loc=0.0d0
2659       eello_turn3=0.0d0
2660       eello_turn4=0.0d0
2661 !el      ind=0
2662       do i=1,nres
2663         num_cont_hb(i)=0
2664       enddo
2665 !d      print '(a)','Enter EELEC'
2666 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2667 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2668 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2669       do i=1,nres
2670         gel_loc_loc(i)=0.0d0
2671         gcorr_loc(i)=0.0d0
2672       enddo
2673 !
2674 !
2675 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2676 !
2677 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2678 !
2679
2680
2681
2682       do i=iturn3_start,iturn3_end
2683         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2684         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2685         dxi=dc(1,i)
2686         dyi=dc(2,i)
2687         dzi=dc(3,i)
2688         dx_normi=dc_norm(1,i)
2689         dy_normi=dc_norm(2,i)
2690         dz_normi=dc_norm(3,i)
2691         xmedi=c(1,i)+0.5d0*dxi
2692         ymedi=c(2,i)+0.5d0*dyi
2693         zmedi=c(3,i)+0.5d0*dzi
2694           xmedi=dmod(xmedi,boxxsize)
2695           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2696           ymedi=dmod(ymedi,boxysize)
2697           if (ymedi.lt.0) ymedi=ymedi+boxysize
2698           zmedi=dmod(zmedi,boxzsize)
2699           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2700         num_conti=0
2701         call eelecij(i,i+2,ees,evdw1,eel_loc)
2702         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2703         num_cont_hb(i)=num_conti
2704       enddo
2705       do i=iturn4_start,iturn4_end
2706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2707           .or. itype(i+3).eq.ntyp1 &
2708           .or. itype(i+4).eq.ntyp1) cycle
2709         dxi=dc(1,i)
2710         dyi=dc(2,i)
2711         dzi=dc(3,i)
2712         dx_normi=dc_norm(1,i)
2713         dy_normi=dc_norm(2,i)
2714         dz_normi=dc_norm(3,i)
2715         xmedi=c(1,i)+0.5d0*dxi
2716         ymedi=c(2,i)+0.5d0*dyi
2717         zmedi=c(3,i)+0.5d0*dzi
2718           xmedi=dmod(xmedi,boxxsize)
2719           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2720           ymedi=dmod(ymedi,boxysize)
2721           if (ymedi.lt.0) ymedi=ymedi+boxysize
2722           zmedi=dmod(zmedi,boxzsize)
2723           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2724         num_conti=num_cont_hb(i)
2725         call eelecij(i,i+3,ees,evdw1,eel_loc)
2726         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2727          call eturn4(i,eello_turn4)
2728         num_cont_hb(i)=num_conti
2729       enddo   ! i
2730 !
2731 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2732 !
2733       do i=iatel_s,iatel_e
2734         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2735         dxi=dc(1,i)
2736         dyi=dc(2,i)
2737         dzi=dc(3,i)
2738         dx_normi=dc_norm(1,i)
2739         dy_normi=dc_norm(2,i)
2740         dz_normi=dc_norm(3,i)
2741         xmedi=c(1,i)+0.5d0*dxi
2742         ymedi=c(2,i)+0.5d0*dyi
2743         zmedi=c(3,i)+0.5d0*dzi
2744           xmedi=dmod(xmedi,boxxsize)
2745           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2746           ymedi=dmod(ymedi,boxysize)
2747           if (ymedi.lt.0) ymedi=ymedi+boxysize
2748           zmedi=dmod(zmedi,boxzsize)
2749           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2750
2751 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2752         num_conti=num_cont_hb(i)
2753         do j=ielstart(i),ielend(i)
2754 !          write (iout,*) i,j,itype(i),itype(j)
2755           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2756           call eelecij(i,j,ees,evdw1,eel_loc)
2757         enddo ! j
2758         num_cont_hb(i)=num_conti
2759       enddo   ! i
2760 !      write (iout,*) "Number of loop steps in EELEC:",ind
2761 !d      do i=1,nres
2762 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2763 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2764 !d      enddo
2765 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2766 !cc      eel_loc=eel_loc+eello_turn3
2767 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2768       return
2769       end subroutine eelec
2770 !-----------------------------------------------------------------------------
2771       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2772
2773       use comm_locel
2774 !      implicit real*8 (a-h,o-z)
2775 !      include 'DIMENSIONS'
2776 #ifdef MPI
2777       include "mpif.h"
2778 #endif
2779 !      include 'COMMON.CONTROL'
2780 !      include 'COMMON.IOUNITS'
2781 !      include 'COMMON.GEO'
2782 !      include 'COMMON.VAR'
2783 !      include 'COMMON.LOCAL'
2784 !      include 'COMMON.CHAIN'
2785 !      include 'COMMON.DERIV'
2786 !      include 'COMMON.INTERACT'
2787 !      include 'COMMON.CONTACTS'
2788 !      include 'COMMON.TORSION'
2789 !      include 'COMMON.VECTORS'
2790 !      include 'COMMON.FFIELD'
2791 !      include 'COMMON.TIME1'
2792       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
2793       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2794       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2795 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2796       real(kind=8),dimension(4) :: muij
2797       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2798                     dist_temp, dist_init
2799       integer xshift,yshift,zshift
2800 !el      integer :: num_conti,j1,j2
2801 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2802 !el        dz_normi,xmedi,ymedi,zmedi
2803
2804 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2805 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2806 !el          num_conti,j1,j2
2807
2808 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2809 #ifdef MOMENT
2810       real(kind=8) :: scal_el=1.0d0
2811 #else
2812       real(kind=8) :: scal_el=0.5d0
2813 #endif
2814 ! 12/13/98
2815 ! 13-go grudnia roku pamietnego...
2816       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2817                                              0.0d0,1.0d0,0.0d0,&
2818                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2819 !      integer :: maxconts=nres/4
2820 !el local variables
2821       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
2822       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2823       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2824       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2825                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2826                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2827                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2828                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2829                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2830                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2831                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2832 !      maxconts=nres/4
2833 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2834 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2835
2836 !          time00=MPI_Wtime()
2837 !d      write (iout,*) "eelecij",i,j
2838 !          ind=ind+1
2839           iteli=itel(i)
2840           itelj=itel(j)
2841           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2842           aaa=app(iteli,itelj)
2843           bbb=bpp(iteli,itelj)
2844           ael6i=ael6(iteli,itelj)
2845           ael3i=ael3(iteli,itelj)
2846           dxj=dc(1,j)
2847           dyj=dc(2,j)
2848           dzj=dc(3,j)
2849           dx_normj=dc_norm(1,j)
2850           dy_normj=dc_norm(2,j)
2851           dz_normj=dc_norm(3,j)
2852 !          xj=c(1,j)+0.5D0*dxj-xmedi
2853 !          yj=c(2,j)+0.5D0*dyj-ymedi
2854 !          zj=c(3,j)+0.5D0*dzj-zmedi
2855           xj=c(1,j)+0.5D0*dxj
2856           yj=c(2,j)+0.5D0*dyj
2857           zj=c(3,j)+0.5D0*dzj
2858           xj=mod(xj,boxxsize)
2859           if (xj.lt.0) xj=xj+boxxsize
2860           yj=mod(yj,boxysize)
2861           if (yj.lt.0) yj=yj+boxysize
2862           zj=mod(zj,boxzsize)
2863           if (zj.lt.0) zj=zj+boxzsize
2864       isubchap=0
2865       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2866       xj_safe=xj
2867       yj_safe=yj
2868       zj_safe=zj
2869       do xshift=-1,1
2870       do yshift=-1,1
2871       do zshift=-1,1
2872           xj=xj_safe+xshift*boxxsize
2873           yj=yj_safe+yshift*boxysize
2874           zj=zj_safe+zshift*boxzsize
2875           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2876           if(dist_temp.lt.dist_init) then
2877             dist_init=dist_temp
2878             xj_temp=xj
2879             yj_temp=yj
2880             zj_temp=zj
2881             isubchap=1
2882           endif
2883        enddo
2884        enddo
2885        enddo
2886        if (isubchap.eq.1) then
2887 !C          print *,i,j
2888           xj=xj_temp-xmedi
2889           yj=yj_temp-ymedi
2890           zj=zj_temp-zmedi
2891        else
2892           xj=xj_safe-xmedi
2893           yj=yj_safe-ymedi
2894           zj=zj_safe-zmedi
2895        endif
2896
2897           rij=xj*xj+yj*yj+zj*zj
2898           rrmij=1.0D0/rij
2899           rij=dsqrt(rij)
2900 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
2901             sss_ele_cut=sscale_ele(rij)
2902             sss_ele_grad=sscagrad_ele(rij)
2903 !             sss_ele_cut=1.0d0
2904 !             sss_ele_grad=0.0d0
2905 !            print *,sss_ele_cut,sss_ele_grad,&
2906 !            (rij),r_cut_ele,rlamb_ele
2907 !            if (sss_ele_cut.le.0.0) go to 128
2908
2909           rmij=1.0D0/rij
2910           r3ij=rrmij*rmij
2911           r6ij=r3ij*r3ij
2912           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2913           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2914           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2915           fac=cosa-3.0D0*cosb*cosg
2916           ev1=aaa*r6ij*r6ij
2917 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2918           if (j.eq.i+2) ev1=scal_el*ev1
2919           ev2=bbb*r6ij
2920           fac3=ael6i*r6ij
2921           fac4=ael3i*r3ij
2922           evdwij=ev1+ev2
2923           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2924           el2=fac4*fac
2925           eesij=el1+el2
2926 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2927           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2928           ees=ees+eesij*sss_ele_cut
2929           evdw1=evdw1+evdwij*sss_ele_cut
2930 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2931 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2932 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2933 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2934
2935           if (energy_dec) then
2936 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2937 !                  'evdw1',i,j,evdwij,&
2938 !                  iteli,itelj,aaa,evdw1
2939               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2940               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2941           endif
2942 !
2943 ! Calculate contributions to the Cartesian gradient.
2944 !
2945 #ifdef SPLITELE
2946           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut
2947           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
2948           fac1=fac
2949           erij(1)=xj*rmij
2950           erij(2)=yj*rmij
2951           erij(3)=zj*rmij
2952 !
2953 ! Radial derivatives. First process both termini of the fragment (i,j)
2954 !
2955           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
2956           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
2957           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
2958
2959 !          do k=1,3
2960 !            ghalf=0.5D0*ggg(k)
2961 !            gelc(k,i)=gelc(k,i)+ghalf
2962 !            gelc(k,j)=gelc(k,j)+ghalf
2963 !          enddo
2964 ! 9/28/08 AL Gradient compotents will be summed only at the end
2965           do k=1,3
2966             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2967             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2968           enddo
2969 !
2970 ! Loop over residues i+1 thru j-1.
2971 !
2972 !grad          do k=i+1,j-1
2973 !grad            do l=1,3
2974 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2975 !grad            enddo
2976 !grad          enddo
2977           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj
2978           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj
2979           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj
2980 !          do k=1,3
2981 !            ghalf=0.5D0*ggg(k)
2982 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2983 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2984 !          enddo
2985 ! 9/28/08 AL Gradient compotents will be summed only at the end
2986           do k=1,3
2987             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2988             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2989           enddo
2990 !
2991 ! Loop over residues i+1 thru j-1.
2992 !
2993 !grad          do k=i+1,j-1
2994 !grad            do l=1,3
2995 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2996 !grad            enddo
2997 !grad          enddo
2998 #else
2999           facvdw=(ev1+evdwij)*sss_ele_cut
3000           facel=(el1+eesij)*sss_ele_cut
3001           fac1=fac
3002           fac=-3*rrmij*(facvdw+facvdw+facel)
3003           erij(1)=xj*rmij
3004           erij(2)=yj*rmij
3005           erij(3)=zj*rmij
3006 !
3007 ! Radial derivatives. First process both termini of the fragment (i,j)
3008 !
3009           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3010           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3011           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3012 !          do k=1,3
3013 !            ghalf=0.5D0*ggg(k)
3014 !            gelc(k,i)=gelc(k,i)+ghalf
3015 !            gelc(k,j)=gelc(k,j)+ghalf
3016 !          enddo
3017 ! 9/28/08 AL Gradient compotents will be summed only at the end
3018           do k=1,3
3019             gelc_long(k,j)=gelc(k,j)+ggg(k)
3020             gelc_long(k,i)=gelc(k,i)-ggg(k)
3021           enddo
3022 !
3023 ! Loop over residues i+1 thru j-1.
3024 !
3025 !grad          do k=i+1,j-1
3026 !grad            do l=1,3
3027 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3028 !grad            enddo
3029 !grad          enddo
3030 ! 9/28/08 AL Gradient compotents will be summed only at the end
3031           ggg(1)=facvdw*xj
3032           ggg(2)=facvdw*yj
3033           ggg(3)=facvdw*zj
3034           do k=1,3
3035             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3036             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3037           enddo
3038 #endif
3039 !
3040 ! Angular part
3041 !
3042           ecosa=2.0D0*fac3*fac1+fac4
3043           fac4=-3.0D0*fac4
3044           fac3=-6.0D0*fac3
3045           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3046           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3047           do k=1,3
3048             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3049             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3050           enddo
3051 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3052 !d   &          (dcosg(k),k=1,3)
3053           do k=1,3
3054             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut
3055           enddo
3056 !          do k=1,3
3057 !            ghalf=0.5D0*ggg(k)
3058 !            gelc(k,i)=gelc(k,i)+ghalf
3059 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3060 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3061 !            gelc(k,j)=gelc(k,j)+ghalf
3062 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3063 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3064 !          enddo
3065 !grad          do k=i+1,j-1
3066 !grad            do l=1,3
3067 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3068 !grad            enddo
3069 !grad          enddo
3070           do k=1,3
3071             gelc(k,i)=gelc(k,i) &
3072                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3073                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3074                      *sss_ele_cut
3075             gelc(k,j)=gelc(k,j) &
3076                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3077                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3078                      *sss_ele_cut
3079             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3080             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3081           enddo
3082
3083           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3084               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3085               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3086 !
3087 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3088 !   energy of a peptide unit is assumed in the form of a second-order
3089 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3090 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3091 !   are computed for EVERY pair of non-contiguous peptide groups.
3092 !
3093           if (j.lt.nres-1) then
3094             j1=j+1
3095             j2=j-1
3096           else
3097             j1=j-1
3098             j2=j-2
3099           endif
3100           kkk=0
3101           do k=1,2
3102             do l=1,2
3103               kkk=kkk+1
3104               muij(kkk)=mu(k,i)*mu(l,j)
3105             enddo
3106           enddo
3107 !d         write (iout,*) 'EELEC: i',i,' j',j
3108 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3109 !d          write(iout,*) 'muij',muij
3110           ury=scalar(uy(1,i),erij)
3111           urz=scalar(uz(1,i),erij)
3112           vry=scalar(uy(1,j),erij)
3113           vrz=scalar(uz(1,j),erij)
3114           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3115           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3116           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3117           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3118           fac=dsqrt(-ael6i)*r3ij
3119           a22=a22*fac
3120           a23=a23*fac
3121           a32=a32*fac
3122           a33=a33*fac
3123 !d          write (iout,'(4i5,4f10.5)')
3124 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3125 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3126 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3127 !d     &      uy(:,j),uz(:,j)
3128 !d          write (iout,'(4f10.5)')
3129 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3130 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3131 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3132 !d           write (iout,'(9f10.5/)')
3133 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3134 ! Derivatives of the elements of A in virtual-bond vectors
3135           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3136           do k=1,3
3137             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3138             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3139             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3140             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3141             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3142             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3143             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3144             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3145             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3146             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3147             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3148             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3149           enddo
3150 ! Compute radial contributions to the gradient
3151           facr=-3.0d0*rrmij
3152           a22der=a22*facr
3153           a23der=a23*facr
3154           a32der=a32*facr
3155           a33der=a33*facr
3156           agg(1,1)=a22der*xj
3157           agg(2,1)=a22der*yj
3158           agg(3,1)=a22der*zj
3159           agg(1,2)=a23der*xj
3160           agg(2,2)=a23der*yj
3161           agg(3,2)=a23der*zj
3162           agg(1,3)=a32der*xj
3163           agg(2,3)=a32der*yj
3164           agg(3,3)=a32der*zj
3165           agg(1,4)=a33der*xj
3166           agg(2,4)=a33der*yj
3167           agg(3,4)=a33der*zj
3168 ! Add the contributions coming from er
3169           fac3=-3.0d0*fac
3170           do k=1,3
3171             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3172             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3173             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3174             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3175           enddo
3176           do k=1,3
3177 ! Derivatives in DC(i)
3178 !grad            ghalf1=0.5d0*agg(k,1)
3179 !grad            ghalf2=0.5d0*agg(k,2)
3180 !grad            ghalf3=0.5d0*agg(k,3)
3181 !grad            ghalf4=0.5d0*agg(k,4)
3182             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3183             -3.0d0*uryg(k,2)*vry)!+ghalf1
3184             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3185             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3186             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3187             -3.0d0*urzg(k,2)*vry)!+ghalf3
3188             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3189             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3190 ! Derivatives in DC(i+1)
3191             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3192             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3193             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3194             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3195             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3196             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3197             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3198             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3199 ! Derivatives in DC(j)
3200             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3201             -3.0d0*vryg(k,2)*ury)!+ghalf1
3202             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3203             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3204             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3205             -3.0d0*vryg(k,2)*urz)!+ghalf3
3206             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3207             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3208 ! Derivatives in DC(j+1) or DC(nres-1)
3209             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3210             -3.0d0*vryg(k,3)*ury)
3211             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3212             -3.0d0*vrzg(k,3)*ury)
3213             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3214             -3.0d0*vryg(k,3)*urz)
3215             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3216             -3.0d0*vrzg(k,3)*urz)
3217 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3218 !grad              do l=1,4
3219 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3220 !grad              enddo
3221 !grad            endif
3222           enddo
3223           acipa(1,1)=a22
3224           acipa(1,2)=a23
3225           acipa(2,1)=a32
3226           acipa(2,2)=a33
3227           a22=-a22
3228           a23=-a23
3229           do l=1,2
3230             do k=1,3
3231               agg(k,l)=-agg(k,l)
3232               aggi(k,l)=-aggi(k,l)
3233               aggi1(k,l)=-aggi1(k,l)
3234               aggj(k,l)=-aggj(k,l)
3235               aggj1(k,l)=-aggj1(k,l)
3236             enddo
3237           enddo
3238           if (j.lt.nres-1) then
3239             a22=-a22
3240             a32=-a32
3241             do l=1,3,2
3242               do k=1,3
3243                 agg(k,l)=-agg(k,l)
3244                 aggi(k,l)=-aggi(k,l)
3245                 aggi1(k,l)=-aggi1(k,l)
3246                 aggj(k,l)=-aggj(k,l)
3247                 aggj1(k,l)=-aggj1(k,l)
3248               enddo
3249             enddo
3250           else
3251             a22=-a22
3252             a23=-a23
3253             a32=-a32
3254             a33=-a33
3255             do l=1,4
3256               do k=1,3
3257                 agg(k,l)=-agg(k,l)
3258                 aggi(k,l)=-aggi(k,l)
3259                 aggi1(k,l)=-aggi1(k,l)
3260                 aggj(k,l)=-aggj(k,l)
3261                 aggj1(k,l)=-aggj1(k,l)
3262               enddo
3263             enddo
3264           endif
3265           ENDIF ! WCORR
3266           IF (wel_loc.gt.0.0d0) THEN
3267 ! Contribution to the local-electrostatic energy coming from the i-j pair
3268           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3269            +a33*muij(4)
3270 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3271 !           eel_loc_ij=0.0
3272           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3273                   'eelloc',i,j,eel_loc_ij
3274 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3275 !          if (energy_dec) write (iout,*) "muij",muij
3276 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3277
3278           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3279 ! Partial derivatives in virtual-bond dihedral angles gamma
3280           if (i.gt.1) &
3281           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3282                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3283                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3284                  *sss_ele_cut
3285           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3286                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3287                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3288                  *sss_ele_cut
3289 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3290 !          do l=1,3
3291 !            ggg(1)=(agg(1,1)*muij(1)+ &
3292 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3293 !            *sss_ele_cut &
3294 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3295 !            ggg(2)=(agg(2,1)*muij(1)+ &
3296 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3297 !            *sss_ele_cut &
3298 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3299 !            ggg(3)=(agg(3,1)*muij(1)+ &
3300 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3301 !            *sss_ele_cut &
3302 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3303            xtemp(1)=xj
3304            xtemp(2)=yj
3305            xtemp(3)=zj
3306
3307            do l=1,3
3308             ggg(l)=(agg(l,1)*muij(1)+ &
3309                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3310             *sss_ele_cut &
3311              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3312
3313             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3314             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3315 !grad            ghalf=0.5d0*ggg(l)
3316 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3317 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3318           enddo
3319 !grad          do k=i+1,j2
3320 !grad            do l=1,3
3321 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3322 !grad            enddo
3323 !grad          enddo
3324 ! Remaining derivatives of eello
3325           do l=1,3
3326             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3327                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3328             *sss_ele_cut
3329 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3330             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3331                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3332             +aggi1(l,4)*muij(4))&
3333             *sss_ele_cut
3334 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3335             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3336                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3337             *sss_ele_cut
3338 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3339             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3340                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3341             +aggj1(l,4)*muij(4))&
3342             *sss_ele_cut
3343 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3344           enddo
3345           ENDIF
3346 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3347 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3348           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3349              .and. num_conti.le.maxconts) then
3350 !            write (iout,*) i,j," entered corr"
3351 !
3352 ! Calculate the contact function. The ith column of the array JCONT will
3353 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3354 ! greater than I). The arrays FACONT and GACONT will contain the values of
3355 ! the contact function and its derivative.
3356 !           r0ij=1.02D0*rpp(iteli,itelj)
3357 !           r0ij=1.11D0*rpp(iteli,itelj)
3358             r0ij=2.20D0*rpp(iteli,itelj)
3359 !           r0ij=1.55D0*rpp(iteli,itelj)
3360             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3361 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3362             if (fcont.gt.0.0D0) then
3363               num_conti=num_conti+1
3364               if (num_conti.gt.maxconts) then
3365 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3366 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3367                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3368                                ' will skip next contacts for this conf.', num_conti
3369               else
3370                 jcont_hb(num_conti,i)=j
3371 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3372 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3373                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3374                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3375 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3376 !  terms.
3377                 d_cont(num_conti,i)=rij
3378 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3379 !     --- Electrostatic-interaction matrix ---
3380                 a_chuj(1,1,num_conti,i)=a22
3381                 a_chuj(1,2,num_conti,i)=a23
3382                 a_chuj(2,1,num_conti,i)=a32
3383                 a_chuj(2,2,num_conti,i)=a33
3384 !     --- Gradient of rij
3385                 do kkk=1,3
3386                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3387                 enddo
3388                 kkll=0
3389                 do k=1,2
3390                   do l=1,2
3391                     kkll=kkll+1
3392                     do m=1,3
3393                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3394                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3395                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3396                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3397                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3398                     enddo
3399                   enddo
3400                 enddo
3401                 ENDIF
3402                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3403 ! Calculate contact energies
3404                 cosa4=4.0D0*cosa
3405                 wij=cosa-3.0D0*cosb*cosg
3406                 cosbg1=cosb+cosg
3407                 cosbg2=cosb-cosg
3408 !               fac3=dsqrt(-ael6i)/r0ij**3
3409                 fac3=dsqrt(-ael6i)*r3ij
3410 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3411                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3412                 if (ees0tmp.gt.0) then
3413                   ees0pij=dsqrt(ees0tmp)
3414                 else
3415                   ees0pij=0
3416                 endif
3417 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3418                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3419                 if (ees0tmp.gt.0) then
3420                   ees0mij=dsqrt(ees0tmp)
3421                 else
3422                   ees0mij=0
3423                 endif
3424 !               ees0mij=0.0D0
3425                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3426                      *sss_ele_cut
3427
3428                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3429                      *sss_ele_cut
3430
3431 ! Diagnostics. Comment out or remove after debugging!
3432 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3433 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3434 !               ees0m(num_conti,i)=0.0D0
3435 ! End diagnostics.
3436 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3437 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3438 ! Angular derivatives of the contact function
3439                 ees0pij1=fac3/ees0pij
3440                 ees0mij1=fac3/ees0mij
3441                 fac3p=-3.0D0*fac3*rrmij
3442                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3443                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3444 !               ees0mij1=0.0D0
3445                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3446                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3447                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3448                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3449                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3450                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3451                 ecosap=ecosa1+ecosa2
3452                 ecosbp=ecosb1+ecosb2
3453                 ecosgp=ecosg1+ecosg2
3454                 ecosam=ecosa1-ecosa2
3455                 ecosbm=ecosb1-ecosb2
3456                 ecosgm=ecosg1-ecosg2
3457 ! Diagnostics
3458 !               ecosap=ecosa1
3459 !               ecosbp=ecosb1
3460 !               ecosgp=ecosg1
3461 !               ecosam=0.0D0
3462 !               ecosbm=0.0D0
3463 !               ecosgm=0.0D0
3464 ! End diagnostics
3465                 facont_hb(num_conti,i)=fcont
3466                 fprimcont=fprimcont/rij
3467 !d              facont_hb(num_conti,i)=1.0D0
3468 ! Following line is for diagnostics.
3469 !d              fprimcont=0.0D0
3470                 do k=1,3
3471                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3472                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3473                 enddo
3474                 do k=1,3
3475                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3476                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3477                 enddo
3478                 gggp(1)=gggp(1)+ees0pijp*xj &
3479                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3480                 gggp(2)=gggp(2)+ees0pijp*yj &
3481                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3482                 gggp(3)=gggp(3)+ees0pijp*zj &
3483                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3484
3485                 gggm(1)=gggm(1)+ees0mijp*xj &
3486                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3487
3488                 gggm(2)=gggm(2)+ees0mijp*yj &
3489                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3490
3491                 gggm(3)=gggm(3)+ees0mijp*zj &
3492                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3493
3494 ! Derivatives due to the contact function
3495                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3496                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3497                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3498                 do k=1,3
3499 !
3500 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3501 !          following the change of gradient-summation algorithm.
3502 !
3503 !grad                  ghalfp=0.5D0*gggp(k)
3504 !grad                  ghalfm=0.5D0*gggm(k)
3505                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3506                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3507                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3508                      *sss_ele_cut
3509
3510                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3511                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3512                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3513                      *sss_ele_cut
3514
3515                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3516                      *sss_ele_cut
3517
3518                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3519                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3520                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3521                      *sss_ele_cut
3522
3523                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3524                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3525                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3526                      *sss_ele_cut
3527
3528                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3529                      *sss_ele_cut
3530
3531                 enddo
3532 ! Diagnostics. Comment out or remove after debugging!
3533 !diag           do k=1,3
3534 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3535 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3536 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3537 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3538 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3539 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3540 !diag           enddo
3541               ENDIF ! wcorr
3542               endif  ! num_conti.le.maxconts
3543             endif  ! fcont.gt.0
3544           endif    ! j.gt.i+1
3545           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3546             do k=1,4
3547               do l=1,3
3548                 ghalf=0.5d0*agg(l,k)
3549                 aggi(l,k)=aggi(l,k)+ghalf
3550                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3551                 aggj(l,k)=aggj(l,k)+ghalf
3552               enddo
3553             enddo
3554             if (j.eq.nres-1 .and. i.lt.j-2) then
3555               do k=1,4
3556                 do l=1,3
3557                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3558                 enddo
3559               enddo
3560             endif
3561           endif
3562  128  continue
3563 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3564       return
3565       end subroutine eelecij
3566 !-----------------------------------------------------------------------------
3567       subroutine eturn3(i,eello_turn3)
3568 ! Third- and fourth-order contributions from turns
3569
3570       use comm_locel
3571 !      implicit real*8 (a-h,o-z)
3572 !      include 'DIMENSIONS'
3573 !      include 'COMMON.IOUNITS'
3574 !      include 'COMMON.GEO'
3575 !      include 'COMMON.VAR'
3576 !      include 'COMMON.LOCAL'
3577 !      include 'COMMON.CHAIN'
3578 !      include 'COMMON.DERIV'
3579 !      include 'COMMON.INTERACT'
3580 !      include 'COMMON.CONTACTS'
3581 !      include 'COMMON.TORSION'
3582 !      include 'COMMON.VECTORS'
3583 !      include 'COMMON.FFIELD'
3584 !      include 'COMMON.CONTROL'
3585       real(kind=8),dimension(3) :: ggg
3586       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3587         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3588       real(kind=8),dimension(2) :: auxvec,auxvec1
3589 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3590       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3591 !el      integer :: num_conti,j1,j2
3592 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3593 !el        dz_normi,xmedi,ymedi,zmedi
3594
3595 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3596 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3597 !el         num_conti,j1,j2
3598 !el local variables
3599       integer :: i,j,l
3600       real(kind=8) :: eello_turn3
3601
3602       j=i+2
3603 !      write (iout,*) "eturn3",i,j,j1,j2
3604       a_temp(1,1)=a22
3605       a_temp(1,2)=a23
3606       a_temp(2,1)=a32
3607       a_temp(2,2)=a33
3608 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3609 !
3610 !               Third-order contributions
3611 !
3612 !                 (i+2)o----(i+3)
3613 !                      | |
3614 !                      | |
3615 !                 (i+1)o----i
3616 !
3617 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3618 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3619         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3620         call transpose2(auxmat(1,1),auxmat1(1,1))
3621         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3622         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3623         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3624                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3625 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3626 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3627 !d     &    ' eello_turn3_num',4*eello_turn3_num
3628 ! Derivatives in gamma(i)
3629         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3630         call transpose2(auxmat2(1,1),auxmat3(1,1))
3631         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3632         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3633 ! Derivatives in gamma(i+1)
3634         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3635         call transpose2(auxmat2(1,1),auxmat3(1,1))
3636         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3637         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3638           +0.5d0*(pizda(1,1)+pizda(2,2))
3639 ! Cartesian derivatives
3640         do l=1,3
3641 !            ghalf1=0.5d0*agg(l,1)
3642 !            ghalf2=0.5d0*agg(l,2)
3643 !            ghalf3=0.5d0*agg(l,3)
3644 !            ghalf4=0.5d0*agg(l,4)
3645           a_temp(1,1)=aggi(l,1)!+ghalf1
3646           a_temp(1,2)=aggi(l,2)!+ghalf2
3647           a_temp(2,1)=aggi(l,3)!+ghalf3
3648           a_temp(2,2)=aggi(l,4)!+ghalf4
3649           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3650           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3651             +0.5d0*(pizda(1,1)+pizda(2,2))
3652           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3653           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3654           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3655           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3656           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3657           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3658             +0.5d0*(pizda(1,1)+pizda(2,2))
3659           a_temp(1,1)=aggj(l,1)!+ghalf1
3660           a_temp(1,2)=aggj(l,2)!+ghalf2
3661           a_temp(2,1)=aggj(l,3)!+ghalf3
3662           a_temp(2,2)=aggj(l,4)!+ghalf4
3663           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3664           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3665             +0.5d0*(pizda(1,1)+pizda(2,2))
3666           a_temp(1,1)=aggj1(l,1)
3667           a_temp(1,2)=aggj1(l,2)
3668           a_temp(2,1)=aggj1(l,3)
3669           a_temp(2,2)=aggj1(l,4)
3670           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3671           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3672             +0.5d0*(pizda(1,1)+pizda(2,2))
3673         enddo
3674       return
3675       end subroutine eturn3
3676 !-----------------------------------------------------------------------------
3677       subroutine eturn4(i,eello_turn4)
3678 ! Third- and fourth-order contributions from turns
3679
3680       use comm_locel
3681 !      implicit real*8 (a-h,o-z)
3682 !      include 'DIMENSIONS'
3683 !      include 'COMMON.IOUNITS'
3684 !      include 'COMMON.GEO'
3685 !      include 'COMMON.VAR'
3686 !      include 'COMMON.LOCAL'
3687 !      include 'COMMON.CHAIN'
3688 !      include 'COMMON.DERIV'
3689 !      include 'COMMON.INTERACT'
3690 !      include 'COMMON.CONTACTS'
3691 !      include 'COMMON.TORSION'
3692 !      include 'COMMON.VECTORS'
3693 !      include 'COMMON.FFIELD'
3694 !      include 'COMMON.CONTROL'
3695       real(kind=8),dimension(3) :: ggg
3696       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3697         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3698       real(kind=8),dimension(2) :: auxvec,auxvec1
3699 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3700       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3701 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3702 !el        dz_normi,xmedi,ymedi,zmedi
3703 !el      integer :: num_conti,j1,j2
3704 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3705 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3706 !el          num_conti,j1,j2
3707 !el local variables
3708       integer :: i,j,iti1,iti2,iti3,l
3709       real(kind=8) :: eello_turn4,s1,s2,s3
3710
3711       j=i+3
3712 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3713 !
3714 !               Fourth-order contributions
3715 !
3716 !                 (i+3)o----(i+4)
3717 !                     /  |
3718 !               (i+2)o   |
3719 !                     \  |
3720 !                 (i+1)o----i
3721 !
3722 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3723 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3724 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3725         a_temp(1,1)=a22
3726         a_temp(1,2)=a23
3727         a_temp(2,1)=a32
3728         a_temp(2,2)=a33
3729         iti1=itortyp(itype(i+1))
3730         iti2=itortyp(itype(i+2))
3731         iti3=itortyp(itype(i+3))
3732 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3733         call transpose2(EUg(1,1,i+1),e1t(1,1))
3734         call transpose2(Eug(1,1,i+2),e2t(1,1))
3735         call transpose2(Eug(1,1,i+3),e3t(1,1))
3736         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3737         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3738         s1=scalar2(b1(1,iti2),auxvec(1))
3739         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3740         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3741         s2=scalar2(b1(1,iti1),auxvec(1))
3742         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3743         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3744         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3745         eello_turn4=eello_turn4-(s1+s2+s3)
3746         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3747            'eturn4',i,j,-(s1+s2+s3)
3748 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3749 !d     &    ' eello_turn4_num',8*eello_turn4_num
3750 ! Derivatives in gamma(i)
3751         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3752         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3753         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3754         s1=scalar2(b1(1,iti2),auxvec(1))
3755         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3756         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3757         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3758 ! Derivatives in gamma(i+1)
3759         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3760         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3761         s2=scalar2(b1(1,iti1),auxvec(1))
3762         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3763         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3764         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3766 ! Derivatives in gamma(i+2)
3767         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3768         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3769         s1=scalar2(b1(1,iti2),auxvec(1))
3770         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3771         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3772         s2=scalar2(b1(1,iti1),auxvec(1))
3773         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3774         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3775         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3776         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3777 ! Cartesian derivatives
3778 ! Derivatives of this turn contributions in DC(i+2)
3779         if (j.lt.nres-1) then
3780           do l=1,3
3781             a_temp(1,1)=agg(l,1)
3782             a_temp(1,2)=agg(l,2)
3783             a_temp(2,1)=agg(l,3)
3784             a_temp(2,2)=agg(l,4)
3785             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787             s1=scalar2(b1(1,iti2),auxvec(1))
3788             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790             s2=scalar2(b1(1,iti1),auxvec(1))
3791             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794             ggg(l)=-(s1+s2+s3)
3795             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3796           enddo
3797         endif
3798 ! Remaining derivatives of this turn contribution
3799         do l=1,3
3800           a_temp(1,1)=aggi(l,1)
3801           a_temp(1,2)=aggi(l,2)
3802           a_temp(2,1)=aggi(l,3)
3803           a_temp(2,2)=aggi(l,4)
3804           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3805           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3806           s1=scalar2(b1(1,iti2),auxvec(1))
3807           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3808           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3809           s2=scalar2(b1(1,iti1),auxvec(1))
3810           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3811           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3812           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3813           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3814           a_temp(1,1)=aggi1(l,1)
3815           a_temp(1,2)=aggi1(l,2)
3816           a_temp(2,1)=aggi1(l,3)
3817           a_temp(2,2)=aggi1(l,4)
3818           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3819           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3820           s1=scalar2(b1(1,iti2),auxvec(1))
3821           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3822           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3823           s2=scalar2(b1(1,iti1),auxvec(1))
3824           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3825           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3826           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3827           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3828           a_temp(1,1)=aggj(l,1)
3829           a_temp(1,2)=aggj(l,2)
3830           a_temp(2,1)=aggj(l,3)
3831           a_temp(2,2)=aggj(l,4)
3832           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3833           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3834           s1=scalar2(b1(1,iti2),auxvec(1))
3835           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3836           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3837           s2=scalar2(b1(1,iti1),auxvec(1))
3838           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3839           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3840           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3841           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3842           a_temp(1,1)=aggj1(l,1)
3843           a_temp(1,2)=aggj1(l,2)
3844           a_temp(2,1)=aggj1(l,3)
3845           a_temp(2,2)=aggj1(l,4)
3846           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3847           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3848           s1=scalar2(b1(1,iti2),auxvec(1))
3849           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3850           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3851           s2=scalar2(b1(1,iti1),auxvec(1))
3852           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3853           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3854           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3855 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3856           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3857         enddo
3858       return
3859       end subroutine eturn4
3860 !-----------------------------------------------------------------------------
3861       subroutine unormderiv(u,ugrad,unorm,ungrad)
3862 ! This subroutine computes the derivatives of a normalized vector u, given
3863 ! the derivatives computed without normalization conditions, ugrad. Returns
3864 ! ungrad.
3865 !      implicit none
3866       real(kind=8),dimension(3) :: u,vec
3867       real(kind=8),dimension(3,3) ::ugrad,ungrad
3868       real(kind=8) :: unorm     !,scalar
3869       integer :: i,j
3870 !      write (2,*) 'ugrad',ugrad
3871 !      write (2,*) 'u',u
3872       do i=1,3
3873         vec(i)=scalar(ugrad(1,i),u(1))
3874       enddo
3875 !      write (2,*) 'vec',vec
3876       do i=1,3
3877         do j=1,3
3878           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3879         enddo
3880       enddo
3881 !      write (2,*) 'ungrad',ungrad
3882       return
3883       end subroutine unormderiv
3884 !-----------------------------------------------------------------------------
3885       subroutine escp_soft_sphere(evdw2,evdw2_14)
3886 !
3887 ! This subroutine calculates the excluded-volume interaction energy between
3888 ! peptide-group centers and side chains and its gradient in virtual-bond and
3889 ! side-chain vectors.
3890 !
3891 !      implicit real*8 (a-h,o-z)
3892 !      include 'DIMENSIONS'
3893 !      include 'COMMON.GEO'
3894 !      include 'COMMON.VAR'
3895 !      include 'COMMON.LOCAL'
3896 !      include 'COMMON.CHAIN'
3897 !      include 'COMMON.DERIV'
3898 !      include 'COMMON.INTERACT'
3899 !      include 'COMMON.FFIELD'
3900 !      include 'COMMON.IOUNITS'
3901 !      include 'COMMON.CONTROL'
3902       real(kind=8),dimension(3) :: ggg
3903 !el local variables
3904       integer :: i,iint,j,k,iteli,itypj
3905       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3906                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3907
3908       evdw2=0.0D0
3909       evdw2_14=0.0d0
3910       r0_scp=4.5d0
3911 !d    print '(a)','Enter ESCP'
3912 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3913       do i=iatscp_s,iatscp_e
3914         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3915         iteli=itel(i)
3916         xi=0.5D0*(c(1,i)+c(1,i+1))
3917         yi=0.5D0*(c(2,i)+c(2,i+1))
3918         zi=0.5D0*(c(3,i)+c(3,i+1))
3919
3920         do iint=1,nscp_gr(i)
3921
3922         do j=iscpstart(i,iint),iscpend(i,iint)
3923           if (itype(j).eq.ntyp1) cycle
3924           itypj=iabs(itype(j))
3925 ! Uncomment following three lines for SC-p interactions
3926 !         xj=c(1,nres+j)-xi
3927 !         yj=c(2,nres+j)-yi
3928 !         zj=c(3,nres+j)-zi
3929 ! Uncomment following three lines for Ca-p interactions
3930           xj=c(1,j)-xi
3931           yj=c(2,j)-yi
3932           zj=c(3,j)-zi
3933           rij=xj*xj+yj*yj+zj*zj
3934           r0ij=r0_scp
3935           r0ijsq=r0ij*r0ij
3936           if (rij.lt.r0ijsq) then
3937             evdwij=0.25d0*(rij-r0ijsq)**2
3938             fac=rij-r0ijsq
3939           else
3940             evdwij=0.0d0
3941             fac=0.0d0
3942           endif
3943           evdw2=evdw2+evdwij
3944 !
3945 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3946 !
3947           ggg(1)=xj*fac
3948           ggg(2)=yj*fac
3949           ggg(3)=zj*fac
3950 !grad          if (j.lt.i) then
3951 !d          write (iout,*) 'j<i'
3952 ! Uncomment following three lines for SC-p interactions
3953 !           do k=1,3
3954 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3955 !           enddo
3956 !grad          else
3957 !d          write (iout,*) 'j>i'
3958 !grad            do k=1,3
3959 !grad              ggg(k)=-ggg(k)
3960 ! Uncomment following line for SC-p interactions
3961 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3962 !grad            enddo
3963 !grad          endif
3964 !grad          do k=1,3
3965 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3966 !grad          enddo
3967 !grad          kstart=min0(i+1,j)
3968 !grad          kend=max0(i-1,j-1)
3969 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3970 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3971 !grad          do k=kstart,kend
3972 !grad            do l=1,3
3973 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3974 !grad            enddo
3975 !grad          enddo
3976           do k=1,3
3977             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3978             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3979           enddo
3980         enddo
3981
3982         enddo ! iint
3983       enddo ! i
3984       return
3985       end subroutine escp_soft_sphere
3986 !-----------------------------------------------------------------------------
3987       subroutine escp(evdw2,evdw2_14)
3988 !
3989 ! This subroutine calculates the excluded-volume interaction energy between
3990 ! peptide-group centers and side chains and its gradient in virtual-bond and
3991 ! side-chain vectors.
3992 !
3993 !      implicit real*8 (a-h,o-z)
3994 !      include 'DIMENSIONS'
3995 !      include 'COMMON.GEO'
3996 !      include 'COMMON.VAR'
3997 !      include 'COMMON.LOCAL'
3998 !      include 'COMMON.CHAIN'
3999 !      include 'COMMON.DERIV'
4000 !      include 'COMMON.INTERACT'
4001 !      include 'COMMON.FFIELD'
4002 !      include 'COMMON.IOUNITS'
4003 !      include 'COMMON.CONTROL'
4004       real(kind=8),dimension(3) :: ggg
4005 !el local variables
4006       integer :: i,iint,j,k,iteli,itypj,subchap
4007       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4008                    e1,e2,evdwij,rij
4009       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4010                     dist_temp, dist_init
4011       integer xshift,yshift,zshift
4012
4013       evdw2=0.0D0
4014       evdw2_14=0.0d0
4015 !d    print '(a)','Enter ESCP'
4016 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4017       do i=iatscp_s,iatscp_e
4018         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4019         iteli=itel(i)
4020         xi=0.5D0*(c(1,i)+c(1,i+1))
4021         yi=0.5D0*(c(2,i)+c(2,i+1))
4022         zi=0.5D0*(c(3,i)+c(3,i+1))
4023           xi=mod(xi,boxxsize)
4024           if (xi.lt.0) xi=xi+boxxsize
4025           yi=mod(yi,boxysize)
4026           if (yi.lt.0) yi=yi+boxysize
4027           zi=mod(zi,boxzsize)
4028           if (zi.lt.0) zi=zi+boxzsize
4029
4030         do iint=1,nscp_gr(i)
4031
4032         do j=iscpstart(i,iint),iscpend(i,iint)
4033           itypj=iabs(itype(j))
4034           if (itypj.eq.ntyp1) cycle
4035 ! Uncomment following three lines for SC-p interactions
4036 !         xj=c(1,nres+j)-xi
4037 !         yj=c(2,nres+j)-yi
4038 !         zj=c(3,nres+j)-zi
4039 ! Uncomment following three lines for Ca-p interactions
4040 !          xj=c(1,j)-xi
4041 !          yj=c(2,j)-yi
4042 !          zj=c(3,j)-zi
4043           xj=c(1,j)
4044           yj=c(2,j)
4045           zj=c(3,j)
4046           xj=mod(xj,boxxsize)
4047           if (xj.lt.0) xj=xj+boxxsize
4048           yj=mod(yj,boxysize)
4049           if (yj.lt.0) yj=yj+boxysize
4050           zj=mod(zj,boxzsize)
4051           if (zj.lt.0) zj=zj+boxzsize
4052       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4053       xj_safe=xj
4054       yj_safe=yj
4055       zj_safe=zj
4056       subchap=0
4057       do xshift=-1,1
4058       do yshift=-1,1
4059       do zshift=-1,1
4060           xj=xj_safe+xshift*boxxsize
4061           yj=yj_safe+yshift*boxysize
4062           zj=zj_safe+zshift*boxzsize
4063           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4064           if(dist_temp.lt.dist_init) then
4065             dist_init=dist_temp
4066             xj_temp=xj
4067             yj_temp=yj
4068             zj_temp=zj
4069             subchap=1
4070           endif
4071        enddo
4072        enddo
4073        enddo
4074        if (subchap.eq.1) then
4075           xj=xj_temp-xi
4076           yj=yj_temp-yi
4077           zj=zj_temp-zi
4078        else
4079           xj=xj_safe-xi
4080           yj=yj_safe-yi
4081           zj=zj_safe-zi
4082        endif
4083
4084           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4085           rij=dsqrt(1.0d0/rrij)
4086             sss_ele_cut=sscale_ele(rij)
4087             sss_ele_grad=sscagrad_ele(rij)
4088 !            print *,sss_ele_cut,sss_ele_grad,&
4089 !            (rij),r_cut_ele,rlamb_ele
4090             if (sss_ele_cut.le.0.0) cycle
4091           fac=rrij**expon2
4092           e1=fac*fac*aad(itypj,iteli)
4093           e2=fac*bad(itypj,iteli)
4094           if (iabs(j-i) .le. 2) then
4095             e1=scal14*e1
4096             e2=scal14*e2
4097             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4098           endif
4099           evdwij=e1+e2
4100           evdw2=evdw2+evdwij*sss_ele_cut
4101 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4102 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4103           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4104              'evdw2',i,j,evdwij
4105 !
4106 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4107 !
4108           fac=-(evdwij+e1)*rrij*sss_ele_cut
4109           fac=fac+evdwij*sss_ele_grad/rij/expon
4110           ggg(1)=xj*fac
4111           ggg(2)=yj*fac
4112           ggg(3)=zj*fac
4113 !grad          if (j.lt.i) then
4114 !d          write (iout,*) 'j<i'
4115 ! Uncomment following three lines for SC-p interactions
4116 !           do k=1,3
4117 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4118 !           enddo
4119 !grad          else
4120 !d          write (iout,*) 'j>i'
4121 !grad            do k=1,3
4122 !grad              ggg(k)=-ggg(k)
4123 ! Uncomment following line for SC-p interactions
4124 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4125 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4126 !grad            enddo
4127 !grad          endif
4128 !grad          do k=1,3
4129 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4130 !grad          enddo
4131 !grad          kstart=min0(i+1,j)
4132 !grad          kend=max0(i-1,j-1)
4133 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4134 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4135 !grad          do k=kstart,kend
4136 !grad            do l=1,3
4137 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4138 !grad            enddo
4139 !grad          enddo
4140           do k=1,3
4141             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4142             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4143           enddo
4144         enddo
4145
4146         enddo ! iint
4147       enddo ! i
4148       do i=1,nct
4149         do j=1,3
4150           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4151           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4152           gradx_scp(j,i)=expon*gradx_scp(j,i)
4153         enddo
4154       enddo
4155 !******************************************************************************
4156 !
4157 !                              N O T E !!!
4158 !
4159 ! To save time the factor EXPON has been extracted from ALL components
4160 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4161 ! use!
4162 !
4163 !******************************************************************************
4164       return
4165       end subroutine escp
4166 !-----------------------------------------------------------------------------
4167       subroutine edis(ehpb)
4168 !
4169 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4170 !
4171 !      implicit real*8 (a-h,o-z)
4172 !      include 'DIMENSIONS'
4173 !      include 'COMMON.SBRIDGE'
4174 !      include 'COMMON.CHAIN'
4175 !      include 'COMMON.DERIV'
4176 !      include 'COMMON.VAR'
4177 !      include 'COMMON.INTERACT'
4178 !      include 'COMMON.IOUNITS'
4179       real(kind=8),dimension(3) :: ggg
4180 !el local variables
4181       integer :: i,j,ii,jj,iii,jjj,k
4182       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4183
4184       ehpb=0.0D0
4185 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4186 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4187       if (link_end.eq.0) return
4188       do i=link_start,link_end
4189 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4190 ! CA-CA distance used in regularization of structure.
4191         ii=ihpb(i)
4192         jj=jhpb(i)
4193 ! iii and jjj point to the residues for which the distance is assigned.
4194         if (ii.gt.nres) then
4195           iii=ii-nres
4196           jjj=jj-nres
4197         else
4198           iii=ii
4199           jjj=jj
4200         endif
4201 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4202 !     &    dhpb(i),dhpb1(i),forcon(i)
4203 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4204 !    distance and angle dependent SS bond potential.
4205 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4206 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4207         if (.not.dyn_ss .and. i.le.nss) then
4208 ! 15/02/13 CC dynamic SSbond - additional check
4209          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4210         iabs(itype(jjj)).eq.1) then
4211           call ssbond_ene(iii,jjj,eij)
4212           ehpb=ehpb+2*eij
4213 !d          write (iout,*) "eij",eij
4214          endif
4215         else
4216 ! Calculate the distance between the two points and its difference from the
4217 ! target distance.
4218         dd=dist(ii,jj)
4219         rdis=dd-dhpb(i)
4220 ! Get the force constant corresponding to this distance.
4221         waga=forcon(i)
4222 ! Calculate the contribution to energy.
4223         ehpb=ehpb+waga*rdis*rdis
4224 !
4225 ! Evaluate gradient.
4226 !
4227         fac=waga*rdis/dd
4228 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4229 !d   &   ' waga=',waga,' fac=',fac
4230         do j=1,3
4231           ggg(j)=fac*(c(j,jj)-c(j,ii))
4232         enddo
4233 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4234 ! If this is a SC-SC distance, we need to calculate the contributions to the
4235 ! Cartesian gradient in the SC vectors (ghpbx).
4236         if (iii.lt.ii) then
4237           do j=1,3
4238             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4239             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4240           enddo
4241         endif
4242 !grad        do j=iii,jjj-1
4243 !grad          do k=1,3
4244 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4245 !grad          enddo
4246 !grad        enddo
4247         do k=1,3
4248           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4249           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4250         enddo
4251         endif
4252       enddo
4253       ehpb=0.5D0*ehpb
4254       return
4255       end subroutine edis
4256 !-----------------------------------------------------------------------------
4257       subroutine ssbond_ene(i,j,eij)
4258 !
4259 ! Calculate the distance and angle dependent SS-bond potential energy
4260 ! using a free-energy function derived based on RHF/6-31G** ab initio
4261 ! calculations of diethyl disulfide.
4262 !
4263 ! A. Liwo and U. Kozlowska, 11/24/03
4264 !
4265 !      implicit real*8 (a-h,o-z)
4266 !      include 'DIMENSIONS'
4267 !      include 'COMMON.SBRIDGE'
4268 !      include 'COMMON.CHAIN'
4269 !      include 'COMMON.DERIV'
4270 !      include 'COMMON.LOCAL'
4271 !      include 'COMMON.INTERACT'
4272 !      include 'COMMON.VAR'
4273 !      include 'COMMON.IOUNITS'
4274       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4275 !el local variables
4276       integer :: i,j,itypi,itypj,k
4277       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4278                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4279                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4280                    cosphi,ggk
4281
4282       itypi=iabs(itype(i))
4283       xi=c(1,nres+i)
4284       yi=c(2,nres+i)
4285       zi=c(3,nres+i)
4286       dxi=dc_norm(1,nres+i)
4287       dyi=dc_norm(2,nres+i)
4288       dzi=dc_norm(3,nres+i)
4289 !      dsci_inv=dsc_inv(itypi)
4290       dsci_inv=vbld_inv(nres+i)
4291       itypj=iabs(itype(j))
4292 !      dscj_inv=dsc_inv(itypj)
4293       dscj_inv=vbld_inv(nres+j)
4294       xj=c(1,nres+j)-xi
4295       yj=c(2,nres+j)-yi
4296       zj=c(3,nres+j)-zi
4297       dxj=dc_norm(1,nres+j)
4298       dyj=dc_norm(2,nres+j)
4299       dzj=dc_norm(3,nres+j)
4300       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4301       rij=dsqrt(rrij)
4302       erij(1)=xj*rij
4303       erij(2)=yj*rij
4304       erij(3)=zj*rij
4305       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4306       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4307       om12=dxi*dxj+dyi*dyj+dzi*dzj
4308       do k=1,3
4309         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4310         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4311       enddo
4312       rij=1.0d0/rij
4313       deltad=rij-d0cm
4314       deltat1=1.0d0-om1
4315       deltat2=1.0d0+om2
4316       deltat12=om2-om1+2.0d0
4317       cosphi=om12-om1*om2
4318       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4319         +akct*deltad*deltat12 &
4320         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4321 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4322 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4323 !     &  " deltat12",deltat12," eij",eij
4324       ed=2*akcm*deltad+akct*deltat12
4325       pom1=akct*deltad
4326       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4327       eom1=-2*akth*deltat1-pom1-om2*pom2
4328       eom2= 2*akth*deltat2+pom1-om1*pom2
4329       eom12=pom2
4330       do k=1,3
4331         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4332         ghpbx(k,i)=ghpbx(k,i)-ggk &
4333                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4334                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4335         ghpbx(k,j)=ghpbx(k,j)+ggk &
4336                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4337                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4338         ghpbc(k,i)=ghpbc(k,i)-ggk
4339         ghpbc(k,j)=ghpbc(k,j)+ggk
4340       enddo
4341 !
4342 ! Calculate the components of the gradient in DC and X
4343 !
4344 !grad      do k=i,j-1
4345 !grad        do l=1,3
4346 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4347 !grad        enddo
4348 !grad      enddo
4349       return
4350       end subroutine ssbond_ene
4351 !-----------------------------------------------------------------------------
4352       subroutine ebond(estr)
4353 !
4354 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4355 !
4356 !      implicit real*8 (a-h,o-z)
4357 !      include 'DIMENSIONS'
4358 !      include 'COMMON.LOCAL'
4359 !      include 'COMMON.GEO'
4360 !      include 'COMMON.INTERACT'
4361 !      include 'COMMON.DERIV'
4362 !      include 'COMMON.VAR'
4363 !      include 'COMMON.CHAIN'
4364 !      include 'COMMON.IOUNITS'
4365 !      include 'COMMON.NAMES'
4366 !      include 'COMMON.FFIELD'
4367 !      include 'COMMON.CONTROL'
4368 !      include 'COMMON.SETUP'
4369       real(kind=8),dimension(3) :: u,ud
4370 !el local variables
4371       integer :: i,j,iti,nbi,k
4372       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4373                    uprod1,uprod2
4374
4375       estr=0.0d0
4376       estr1=0.0d0
4377 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4378 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4379
4380       do i=ibondp_start,ibondp_end
4381         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4382         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4383 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4384 !C          do j=1,3
4385 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4386 !C            *dc(j,i-1)/vbld(i)
4387 !C          enddo
4388 !C          if (energy_dec) write(iout,*) &
4389 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4390         diff = vbld(i)-vbldpDUM
4391         else
4392         diff = vbld(i)-vbldp0
4393         endif
4394         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4395            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4396         estr=estr+diff*diff
4397         do j=1,3
4398           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4399         enddo
4400 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4401 !        endif
4402       enddo
4403       estr=0.5d0*AKP*estr+estr1
4404 !
4405 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4406 !
4407       do i=ibond_start,ibond_end
4408         iti=iabs(itype(i))
4409         if (iti.ne.10 .and. iti.ne.ntyp1) then
4410           nbi=nbondterm(iti)
4411           if (nbi.eq.1) then
4412             diff=vbld(i+nres)-vbldsc0(1,iti)
4413             if (energy_dec) write (iout,*) &
4414             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4415             AKSC(1,iti),AKSC(1,iti)*diff*diff
4416             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4417             do j=1,3
4418               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4419             enddo
4420           else
4421             do j=1,nbi
4422               diff=vbld(i+nres)-vbldsc0(j,iti)
4423               ud(j)=aksc(j,iti)*diff
4424               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4425             enddo
4426             uprod=u(1)
4427             do j=2,nbi
4428               uprod=uprod*u(j)
4429             enddo
4430             usum=0.0d0
4431             usumsqder=0.0d0
4432             do j=1,nbi
4433               uprod1=1.0d0
4434               uprod2=1.0d0
4435               do k=1,nbi
4436                 if (k.ne.j) then
4437                   uprod1=uprod1*u(k)
4438                   uprod2=uprod2*u(k)*u(k)
4439                 endif
4440               enddo
4441               usum=usum+uprod1
4442               usumsqder=usumsqder+ud(j)*uprod2
4443             enddo
4444             estr=estr+uprod/usum
4445             do j=1,3
4446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4447             enddo
4448           endif
4449         endif
4450       enddo
4451       return
4452       end subroutine ebond
4453 #ifdef CRYST_THETA
4454 !-----------------------------------------------------------------------------
4455       subroutine ebend(etheta)
4456 !
4457 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4458 ! angles gamma and its derivatives in consecutive thetas and gammas.
4459 !
4460       use comm_calcthet
4461 !      implicit real*8 (a-h,o-z)
4462 !      include 'DIMENSIONS'
4463 !      include 'COMMON.LOCAL'
4464 !      include 'COMMON.GEO'
4465 !      include 'COMMON.INTERACT'
4466 !      include 'COMMON.DERIV'
4467 !      include 'COMMON.VAR'
4468 !      include 'COMMON.CHAIN'
4469 !      include 'COMMON.IOUNITS'
4470 !      include 'COMMON.NAMES'
4471 !      include 'COMMON.FFIELD'
4472 !      include 'COMMON.CONTROL'
4473 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4474 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4475 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4476 !el      integer :: it
4477 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4478 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4479 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4480 !el local variables
4481       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4482        ichir21,ichir22
4483       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4484        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4485        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4486       real(kind=8),dimension(2) :: y,z
4487
4488       delta=0.02d0*pi
4489 !      time11=dexp(-2*time)
4490 !      time12=1.0d0
4491       etheta=0.0D0
4492 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4493       do i=ithet_start,ithet_end
4494         if (itype(i-1).eq.ntyp1) cycle
4495 ! Zero the energy function and its derivative at 0 or pi.
4496         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4497         it=itype(i-1)
4498         ichir1=isign(1,itype(i-2))
4499         ichir2=isign(1,itype(i))
4500          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4501          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4502          if (itype(i-1).eq.10) then
4503           itype1=isign(10,itype(i-2))
4504           ichir11=isign(1,itype(i-2))
4505           ichir12=isign(1,itype(i-2))
4506           itype2=isign(10,itype(i))
4507           ichir21=isign(1,itype(i))
4508           ichir22=isign(1,itype(i))
4509          endif
4510
4511         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4512 #ifdef OSF
4513           phii=phi(i)
4514           if (phii.ne.phii) phii=150.0
4515 #else
4516           phii=phi(i)
4517 #endif
4518           y(1)=dcos(phii)
4519           y(2)=dsin(phii)
4520         else
4521           y(1)=0.0D0
4522           y(2)=0.0D0
4523         endif
4524         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4525 #ifdef OSF
4526           phii1=phi(i+1)
4527           if (phii1.ne.phii1) phii1=150.0
4528           phii1=pinorm(phii1)
4529           z(1)=cos(phii1)
4530 #else
4531           phii1=phi(i+1)
4532           z(1)=dcos(phii1)
4533 #endif
4534           z(2)=dsin(phii1)
4535         else
4536           z(1)=0.0D0
4537           z(2)=0.0D0
4538         endif
4539 ! Calculate the "mean" value of theta from the part of the distribution
4540 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4541 ! In following comments this theta will be referred to as t_c.
4542         thet_pred_mean=0.0d0
4543         do k=1,2
4544             athetk=athet(k,it,ichir1,ichir2)
4545             bthetk=bthet(k,it,ichir1,ichir2)
4546           if (it.eq.10) then
4547              athetk=athet(k,itype1,ichir11,ichir12)
4548              bthetk=bthet(k,itype2,ichir21,ichir22)
4549           endif
4550          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4551         enddo
4552         dthett=thet_pred_mean*ssd
4553         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4554 ! Derivatives of the "mean" values in gamma1 and gamma2.
4555         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4556                +athet(2,it,ichir1,ichir2)*y(1))*ss
4557         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4558                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4559          if (it.eq.10) then
4560         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4561              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4562         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4563                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4564          endif
4565         if (theta(i).gt.pi-delta) then
4566           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4567                E_tc0)
4568           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4569           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4570           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4571               E_theta)
4572           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4573               E_tc)
4574         else if (theta(i).lt.delta) then
4575           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4576           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4577           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4578               E_theta)
4579           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4580           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4581               E_tc)
4582         else
4583           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4584               E_theta,E_tc)
4585         endif
4586         etheta=etheta+ethetai
4587         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4588             'ebend',i,ethetai
4589         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4590         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4591         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4592       enddo
4593 ! Ufff.... We've done all this!!!
4594       return
4595       end subroutine ebend
4596 !-----------------------------------------------------------------------------
4597       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4598
4599       use comm_calcthet
4600 !      implicit real*8 (a-h,o-z)
4601 !      include 'DIMENSIONS'
4602 !      include 'COMMON.LOCAL'
4603 !      include 'COMMON.IOUNITS'
4604 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4605 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4606 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4607       integer :: i,j,k
4608       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4609 !el      integer :: it
4610 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4611 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4612 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4613 !el local variables
4614       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4615        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4616
4617 ! Calculate the contributions to both Gaussian lobes.
4618 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4619 ! The "polynomial part" of the "standard deviation" of this part of
4620 ! the distribution.
4621         sig=polthet(3,it)
4622         do j=2,0,-1
4623           sig=sig*thet_pred_mean+polthet(j,it)
4624         enddo
4625 ! Derivative of the "interior part" of the "standard deviation of the"
4626 ! gamma-dependent Gaussian lobe in t_c.
4627         sigtc=3*polthet(3,it)
4628         do j=2,1,-1
4629           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4630         enddo
4631         sigtc=sig*sigtc
4632 ! Set the parameters of both Gaussian lobes of the distribution.
4633 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4634         fac=sig*sig+sigc0(it)
4635         sigcsq=fac+fac
4636         sigc=1.0D0/sigcsq
4637 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4638         sigsqtc=-4.0D0*sigcsq*sigtc
4639 !       print *,i,sig,sigtc,sigsqtc
4640 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4641         sigtc=-sigtc/(fac*fac)
4642 ! Following variable is sigma(t_c)**(-2)
4643         sigcsq=sigcsq*sigcsq
4644         sig0i=sig0(it)
4645         sig0inv=1.0D0/sig0i**2
4646         delthec=thetai-thet_pred_mean
4647         delthe0=thetai-theta0i
4648         term1=-0.5D0*sigcsq*delthec*delthec
4649         term2=-0.5D0*sig0inv*delthe0*delthe0
4650 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4651 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4652 ! to the energy (this being the log of the distribution) at the end of energy
4653 ! term evaluation for this virtual-bond angle.
4654         if (term1.gt.term2) then
4655           termm=term1
4656           term2=dexp(term2-termm)
4657           term1=1.0d0
4658         else
4659           termm=term2
4660           term1=dexp(term1-termm)
4661           term2=1.0d0
4662         endif
4663 ! The ratio between the gamma-independent and gamma-dependent lobes of
4664 ! the distribution is a Gaussian function of thet_pred_mean too.
4665         diffak=gthet(2,it)-thet_pred_mean
4666         ratak=diffak/gthet(3,it)**2
4667         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4668 ! Let's differentiate it in thet_pred_mean NOW.
4669         aktc=ak*ratak
4670 ! Now put together the distribution terms to make complete distribution.
4671         termexp=term1+ak*term2
4672         termpre=sigc+ak*sig0i
4673 ! Contribution of the bending energy from this theta is just the -log of
4674 ! the sum of the contributions from the two lobes and the pre-exponential
4675 ! factor. Simple enough, isn't it?
4676         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4677 ! NOW the derivatives!!!
4678 ! 6/6/97 Take into account the deformation.
4679         E_theta=(delthec*sigcsq*term1 &
4680              +ak*delthe0*sig0inv*term2)/termexp
4681         E_tc=((sigtc+aktc*sig0i)/termpre &
4682             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4683              aktc*term2)/termexp)
4684       return
4685       end subroutine theteng
4686 #else
4687 !-----------------------------------------------------------------------------
4688       subroutine ebend(etheta)
4689 !
4690 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4691 ! angles gamma and its derivatives in consecutive thetas and gammas.
4692 ! ab initio-derived potentials from
4693 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4694 !
4695 !      implicit real*8 (a-h,o-z)
4696 !      include 'DIMENSIONS'
4697 !      include 'COMMON.LOCAL'
4698 !      include 'COMMON.GEO'
4699 !      include 'COMMON.INTERACT'
4700 !      include 'COMMON.DERIV'
4701 !      include 'COMMON.VAR'
4702 !      include 'COMMON.CHAIN'
4703 !      include 'COMMON.IOUNITS'
4704 !      include 'COMMON.NAMES'
4705 !      include 'COMMON.FFIELD'
4706 !      include 'COMMON.CONTROL'
4707       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4708       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4709       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4710       logical :: lprn=.false., lprn1=.false.
4711 !el local variables
4712       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4713       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4714       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4715
4716       etheta=0.0D0
4717       do i=ithet_start,ithet_end
4718         if (itype(i-1).eq.ntyp1) cycle
4719         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4720         if (iabs(itype(i+1)).eq.20) iblock=2
4721         if (iabs(itype(i+1)).ne.20) iblock=1
4722         dethetai=0.0d0
4723         dephii=0.0d0
4724         dephii1=0.0d0
4725         theti2=0.5d0*theta(i)
4726         ityp2=ithetyp((itype(i-1)))
4727         do k=1,nntheterm
4728           coskt(k)=dcos(k*theti2)
4729           sinkt(k)=dsin(k*theti2)
4730         enddo
4731         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4732 #ifdef OSF
4733           phii=phi(i)
4734           if (phii.ne.phii) phii=150.0
4735 #else
4736           phii=phi(i)
4737 #endif
4738           ityp1=ithetyp((itype(i-2)))
4739 ! propagation of chirality for glycine type
4740           do k=1,nsingle
4741             cosph1(k)=dcos(k*phii)
4742             sinph1(k)=dsin(k*phii)
4743           enddo
4744         else
4745           phii=0.0d0
4746           ityp1=ithetyp(itype(i-2))
4747           do k=1,nsingle
4748             cosph1(k)=0.0d0
4749             sinph1(k)=0.0d0
4750           enddo
4751         endif
4752         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4753 #ifdef OSF
4754           phii1=phi(i+1)
4755           if (phii1.ne.phii1) phii1=150.0
4756           phii1=pinorm(phii1)
4757 #else
4758           phii1=phi(i+1)
4759 #endif
4760           ityp3=ithetyp((itype(i)))
4761           do k=1,nsingle
4762             cosph2(k)=dcos(k*phii1)
4763             sinph2(k)=dsin(k*phii1)
4764           enddo
4765         else
4766           phii1=0.0d0
4767           ityp3=ithetyp(itype(i))
4768           do k=1,nsingle
4769             cosph2(k)=0.0d0
4770             sinph2(k)=0.0d0
4771           enddo
4772         endif
4773         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4774         do k=1,ndouble
4775           do l=1,k-1
4776             ccl=cosph1(l)*cosph2(k-l)
4777             ssl=sinph1(l)*sinph2(k-l)
4778             scl=sinph1(l)*cosph2(k-l)
4779             csl=cosph1(l)*sinph2(k-l)
4780             cosph1ph2(l,k)=ccl-ssl
4781             cosph1ph2(k,l)=ccl+ssl
4782             sinph1ph2(l,k)=scl+csl
4783             sinph1ph2(k,l)=scl-csl
4784           enddo
4785         enddo
4786         if (lprn) then
4787         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4788           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4789         write (iout,*) "coskt and sinkt"
4790         do k=1,nntheterm
4791           write (iout,*) k,coskt(k),sinkt(k)
4792         enddo
4793         endif
4794         do k=1,ntheterm
4795           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4796           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4797             *coskt(k)
4798           if (lprn) &
4799           write (iout,*) "k",k,&
4800            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4801            " ethetai",ethetai
4802         enddo
4803         if (lprn) then
4804         write (iout,*) "cosph and sinph"
4805         do k=1,nsingle
4806           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4807         enddo
4808         write (iout,*) "cosph1ph2 and sinph2ph2"
4809         do k=2,ndouble
4810           do l=1,k-1
4811             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4812                sinph1ph2(l,k),sinph1ph2(k,l)
4813           enddo
4814         enddo
4815         write(iout,*) "ethetai",ethetai
4816         endif
4817         do m=1,ntheterm2
4818           do k=1,nsingle
4819             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4820                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4821                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4822                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4823             ethetai=ethetai+sinkt(m)*aux
4824             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4825             dephii=dephii+k*sinkt(m)* &
4826                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4827                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4828             dephii1=dephii1+k*sinkt(m)* &
4829                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4830                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4831             if (lprn) &
4832             write (iout,*) "m",m," k",k," bbthet", &
4833                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4834                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4835                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4836                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4837           enddo
4838         enddo
4839         if (lprn) &
4840         write(iout,*) "ethetai",ethetai
4841         do m=1,ntheterm3
4842           do k=2,ndouble
4843             do l=1,k-1
4844               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4845                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4846                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4847                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4848               ethetai=ethetai+sinkt(m)*aux
4849               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4850               dephii=dephii+l*sinkt(m)* &
4851                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4852                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4853                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4854                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4855               dephii1=dephii1+(k-l)*sinkt(m)* &
4856                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4857                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4858                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4859                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4860               if (lprn) then
4861               write (iout,*) "m",m," k",k," l",l," ffthet",&
4862                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4863                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4864                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4865                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4866                   " ethetai",ethetai
4867               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4868                   cosph1ph2(k,l)*sinkt(m),&
4869                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4870               endif
4871             enddo
4872           enddo
4873         enddo
4874 10      continue
4875 !        lprn1=.true.
4876         if (lprn1) &
4877           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4878          i,theta(i)*rad2deg,phii*rad2deg,&
4879          phii1*rad2deg,ethetai
4880 !        lprn1=.false.
4881         etheta=etheta+ethetai
4882         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4883                                     'ebend',i,ethetai
4884         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4885         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4886         gloc(nphi+i-2,icg)=wang*dethetai
4887       enddo
4888       return
4889       end subroutine ebend
4890 #endif
4891 #ifdef CRYST_SC
4892 !-----------------------------------------------------------------------------
4893       subroutine esc(escloc)
4894 ! Calculate the local energy of a side chain and its derivatives in the
4895 ! corresponding virtual-bond valence angles THETA and the spherical angles
4896 ! ALPHA and OMEGA.
4897 !
4898       use comm_sccalc
4899 !      implicit real*8 (a-h,o-z)
4900 !      include 'DIMENSIONS'
4901 !      include 'COMMON.GEO'
4902 !      include 'COMMON.LOCAL'
4903 !      include 'COMMON.VAR'
4904 !      include 'COMMON.INTERACT'
4905 !      include 'COMMON.DERIV'
4906 !      include 'COMMON.CHAIN'
4907 !      include 'COMMON.IOUNITS'
4908 !      include 'COMMON.NAMES'
4909 !      include 'COMMON.FFIELD'
4910 !      include 'COMMON.CONTROL'
4911       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4912          ddersc0,ddummy,xtemp,temp
4913 !el      real(kind=8) :: time11,time12,time112,theti
4914       real(kind=8) :: escloc,delta
4915 !el      integer :: it,nlobit
4916 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4917 !el local variables
4918       integer :: i,k
4919       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4920        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4921       delta=0.02d0*pi
4922       escloc=0.0D0
4923 !     write (iout,'(a)') 'ESC'
4924       do i=loc_start,loc_end
4925         it=itype(i)
4926         if (it.eq.ntyp1) cycle
4927         if (it.eq.10) goto 1
4928         nlobit=nlob(iabs(it))
4929 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4930 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4931         theti=theta(i+1)-pipol
4932         x(1)=dtan(theti)
4933         x(2)=alph(i)
4934         x(3)=omeg(i)
4935
4936         if (x(2).gt.pi-delta) then
4937           xtemp(1)=x(1)
4938           xtemp(2)=pi-delta
4939           xtemp(3)=x(3)
4940           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4941           xtemp(2)=pi
4942           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4943           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4944               escloci,dersc(2))
4945           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4946               ddersc0(1),dersc(1))
4947           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4948               ddersc0(3),dersc(3))
4949           xtemp(2)=pi-delta
4950           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4951           xtemp(2)=pi
4952           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4953           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4954                   dersc0(2),esclocbi,dersc02)
4955           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4956                   dersc12,dersc01)
4957           call splinthet(x(2),0.5d0*delta,ss,ssd)
4958           dersc0(1)=dersc01
4959           dersc0(2)=dersc02
4960           dersc0(3)=0.0d0
4961           do k=1,3
4962             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4963           enddo
4964           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4965 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4966 !    &             esclocbi,ss,ssd
4967           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4968 !         escloci=esclocbi
4969 !         write (iout,*) escloci
4970         else if (x(2).lt.delta) then
4971           xtemp(1)=x(1)
4972           xtemp(2)=delta
4973           xtemp(3)=x(3)
4974           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4975           xtemp(2)=0.0d0
4976           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4977           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4978               escloci,dersc(2))
4979           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4980               ddersc0(1),dersc(1))
4981           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4982               ddersc0(3),dersc(3))
4983           xtemp(2)=delta
4984           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4985           xtemp(2)=0.0d0
4986           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4987           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4988                   dersc0(2),esclocbi,dersc02)
4989           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4990                   dersc12,dersc01)
4991           dersc0(1)=dersc01
4992           dersc0(2)=dersc02
4993           dersc0(3)=0.0d0
4994           call splinthet(x(2),0.5d0*delta,ss,ssd)
4995           do k=1,3
4996             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4997           enddo
4998           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4999 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5000 !    &             esclocbi,ss,ssd
5001           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5002 !         write (iout,*) escloci
5003         else
5004           call enesc(x,escloci,dersc,ddummy,.false.)
5005         endif
5006
5007         escloc=escloc+escloci
5008         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5009            'escloc',i,escloci
5010 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5011
5012         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5013          wscloc*dersc(1)
5014         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5015         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5016     1   continue
5017       enddo
5018       return
5019       end subroutine esc
5020 !-----------------------------------------------------------------------------
5021       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5022
5023       use comm_sccalc
5024 !      implicit real*8 (a-h,o-z)
5025 !      include 'DIMENSIONS'
5026 !      include 'COMMON.GEO'
5027 !      include 'COMMON.LOCAL'
5028 !      include 'COMMON.IOUNITS'
5029 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5030       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5031       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5032       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5033       real(kind=8) :: escloci
5034       logical :: mixed
5035 !el local variables
5036       integer :: j,iii,l,k !el,it,nlobit
5037       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5038 !el       time11,time12,time112
5039 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5040         escloc_i=0.0D0
5041         do j=1,3
5042           dersc(j)=0.0D0
5043           if (mixed) ddersc(j)=0.0d0
5044         enddo
5045         x3=x(3)
5046
5047 ! Because of periodicity of the dependence of the SC energy in omega we have
5048 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5049 ! To avoid underflows, first compute & store the exponents.
5050
5051         do iii=-1,1
5052
5053           x(3)=x3+iii*dwapi
5054
5055           do j=1,nlobit
5056             do k=1,3
5057               z(k)=x(k)-censc(k,j,it)
5058             enddo
5059             do k=1,3
5060               Axk=0.0D0
5061               do l=1,3
5062                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5063               enddo
5064               Ax(k,j,iii)=Axk
5065             enddo
5066             expfac=0.0D0
5067             do k=1,3
5068               expfac=expfac+Ax(k,j,iii)*z(k)
5069             enddo
5070             contr(j,iii)=expfac
5071           enddo ! j
5072
5073         enddo ! iii
5074
5075         x(3)=x3
5076 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5077 ! subsequent NaNs and INFs in energy calculation.
5078 ! Find the largest exponent
5079         emin=contr(1,-1)
5080         do iii=-1,1
5081           do j=1,nlobit
5082             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5083           enddo
5084         enddo
5085         emin=0.5D0*emin
5086 !d      print *,'it=',it,' emin=',emin
5087
5088 ! Compute the contribution to SC energy and derivatives
5089         do iii=-1,1
5090
5091           do j=1,nlobit
5092 #ifdef OSF
5093             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5094             if(adexp.ne.adexp) adexp=1.0
5095             expfac=dexp(adexp)
5096 #else
5097             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5098 #endif
5099 !d          print *,'j=',j,' expfac=',expfac
5100             escloc_i=escloc_i+expfac
5101             do k=1,3
5102               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5103             enddo
5104             if (mixed) then
5105               do k=1,3,2
5106                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5107                   +gaussc(k,2,j,it))*expfac
5108               enddo
5109             endif
5110           enddo
5111
5112         enddo ! iii
5113
5114         dersc(1)=dersc(1)/cos(theti)**2
5115         ddersc(1)=ddersc(1)/cos(theti)**2
5116         ddersc(3)=ddersc(3)
5117
5118         escloci=-(dlog(escloc_i)-emin)
5119         do j=1,3
5120           dersc(j)=dersc(j)/escloc_i
5121         enddo
5122         if (mixed) then
5123           do j=1,3,2
5124             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5125           enddo
5126         endif
5127       return
5128       end subroutine enesc
5129 !-----------------------------------------------------------------------------
5130       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5131
5132       use comm_sccalc
5133 !      implicit real*8 (a-h,o-z)
5134 !      include 'DIMENSIONS'
5135 !      include 'COMMON.GEO'
5136 !      include 'COMMON.LOCAL'
5137 !      include 'COMMON.IOUNITS'
5138 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5139       real(kind=8),dimension(3) :: x,z,dersc
5140       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5141       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5142       real(kind=8) :: escloci,dersc12,emin
5143       logical :: mixed
5144 !el local varables
5145       integer :: j,k,l !el,it,nlobit
5146       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5147
5148       escloc_i=0.0D0
5149
5150       do j=1,3
5151         dersc(j)=0.0D0
5152       enddo
5153
5154       do j=1,nlobit
5155         do k=1,2
5156           z(k)=x(k)-censc(k,j,it)
5157         enddo
5158         z(3)=dwapi
5159         do k=1,3
5160           Axk=0.0D0
5161           do l=1,3
5162             Axk=Axk+gaussc(l,k,j,it)*z(l)
5163           enddo
5164           Ax(k,j)=Axk
5165         enddo
5166         expfac=0.0D0
5167         do k=1,3
5168           expfac=expfac+Ax(k,j)*z(k)
5169         enddo
5170         contr(j)=expfac
5171       enddo ! j
5172
5173 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5174 ! subsequent NaNs and INFs in energy calculation.
5175 ! Find the largest exponent
5176       emin=contr(1)
5177       do j=1,nlobit
5178         if (emin.gt.contr(j)) emin=contr(j)
5179       enddo
5180       emin=0.5D0*emin
5181
5182 ! Compute the contribution to SC energy and derivatives
5183
5184       dersc12=0.0d0
5185       do j=1,nlobit
5186         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5187         escloc_i=escloc_i+expfac
5188         do k=1,2
5189           dersc(k)=dersc(k)+Ax(k,j)*expfac
5190         enddo
5191         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5192                   +gaussc(1,2,j,it))*expfac
5193         dersc(3)=0.0d0
5194       enddo
5195
5196       dersc(1)=dersc(1)/cos(theti)**2
5197       dersc12=dersc12/cos(theti)**2
5198       escloci=-(dlog(escloc_i)-emin)
5199       do j=1,2
5200         dersc(j)=dersc(j)/escloc_i
5201       enddo
5202       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5203       return
5204       end subroutine enesc_bound
5205 #else
5206 !-----------------------------------------------------------------------------
5207       subroutine esc(escloc)
5208 ! Calculate the local energy of a side chain and its derivatives in the
5209 ! corresponding virtual-bond valence angles THETA and the spherical angles
5210 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5211 ! added by Urszula Kozlowska. 07/11/2007
5212 !
5213       use comm_sccalc
5214 !      implicit real*8 (a-h,o-z)
5215 !      include 'DIMENSIONS'
5216 !      include 'COMMON.GEO'
5217 !      include 'COMMON.LOCAL'
5218 !      include 'COMMON.VAR'
5219 !      include 'COMMON.SCROT'
5220 !      include 'COMMON.INTERACT'
5221 !      include 'COMMON.DERIV'
5222 !      include 'COMMON.CHAIN'
5223 !      include 'COMMON.IOUNITS'
5224 !      include 'COMMON.NAMES'
5225 !      include 'COMMON.FFIELD'
5226 !      include 'COMMON.CONTROL'
5227 !      include 'COMMON.VECTORS'
5228       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5229       real(kind=8),dimension(65) :: x
5230       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5231          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5232       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5233       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5234          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5235 !el local variables
5236       integer :: i,j,k !el,it,nlobit
5237       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5238 !el      real(kind=8) :: time11,time12,time112,theti
5239 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5240       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5241                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5242                    sumene1x,sumene2x,sumene3x,sumene4x,&
5243                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5244                    cosfac2xx,sinfac2yy
5245 #ifdef DEBUG
5246       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5247                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5248                    de_dt_num
5249 #endif
5250 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5251
5252       delta=0.02d0*pi
5253       escloc=0.0D0
5254       do i=loc_start,loc_end
5255         if (itype(i).eq.ntyp1) cycle
5256         costtab(i+1) =dcos(theta(i+1))
5257         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5258         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5259         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5260         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5261         cosfac=dsqrt(cosfac2)
5262         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5263         sinfac=dsqrt(sinfac2)
5264         it=iabs(itype(i))
5265         if (it.eq.10) goto 1
5266 !
5267 !  Compute the axes of tghe local cartesian coordinates system; store in
5268 !   x_prime, y_prime and z_prime
5269 !
5270         do j=1,3
5271           x_prime(j) = 0.00
5272           y_prime(j) = 0.00
5273           z_prime(j) = 0.00
5274         enddo
5275 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5276 !     &   dc_norm(3,i+nres)
5277         do j = 1,3
5278           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5279           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5280         enddo
5281         do j = 1,3
5282           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5283         enddo
5284 !       write (2,*) "i",i
5285 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5286 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5287 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5288 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5289 !      & " xy",scalar(x_prime(1),y_prime(1)),
5290 !      & " xz",scalar(x_prime(1),z_prime(1)),
5291 !      & " yy",scalar(y_prime(1),y_prime(1)),
5292 !      & " yz",scalar(y_prime(1),z_prime(1)),
5293 !      & " zz",scalar(z_prime(1),z_prime(1))
5294 !
5295 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5296 ! to local coordinate system. Store in xx, yy, zz.
5297 !
5298         xx=0.0d0
5299         yy=0.0d0
5300         zz=0.0d0
5301         do j = 1,3
5302           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5303           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5304           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5305         enddo
5306
5307         xxtab(i)=xx
5308         yytab(i)=yy
5309         zztab(i)=zz
5310 !
5311 ! Compute the energy of the ith side cbain
5312 !
5313 !        write (2,*) "xx",xx," yy",yy," zz",zz
5314         it=iabs(itype(i))
5315         do j = 1,65
5316           x(j) = sc_parmin(j,it)
5317         enddo
5318 #ifdef CHECK_COORD
5319 !c diagnostics - remove later
5320         xx1 = dcos(alph(2))
5321         yy1 = dsin(alph(2))*dcos(omeg(2))
5322         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5323         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5324           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5325           xx1,yy1,zz1
5326 !,"  --- ", xx_w,yy_w,zz_w
5327 ! end diagnostics
5328 #endif
5329         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5330          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5331          + x(10)*yy*zz
5332         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5333          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5334          + x(20)*yy*zz
5335         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5336          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5337          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5338          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5339          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5340          +x(40)*xx*yy*zz
5341         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5342          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5343          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5344          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5345          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5346          +x(60)*xx*yy*zz
5347         dsc_i   = 0.743d0+x(61)
5348         dp2_i   = 1.9d0+x(62)
5349         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5350                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5351         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5352                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5353         s1=(1+x(63))/(0.1d0 + dscp1)
5354         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5355         s2=(1+x(65))/(0.1d0 + dscp2)
5356         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5357         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5358       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5359 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5360 !     &   sumene4,
5361 !     &   dscp1,dscp2,sumene
5362 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5363         escloc = escloc + sumene
5364 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5365 !     & ,zz,xx,yy
5366 !#define DEBUG
5367 #ifdef DEBUG
5368 !
5369 ! This section to check the numerical derivatives of the energy of ith side
5370 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5371 ! #define DEBUG in the code to turn it on.
5372 !
5373         write (2,*) "sumene               =",sumene
5374         aincr=1.0d-7
5375         xxsave=xx
5376         xx=xx+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dxx_num=(sumenep-sumene)/aincr
5380         xx=xxsave
5381         write (2,*) "xx+ sumene from enesc=",sumenep
5382         yysave=yy
5383         yy=yy+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dyy_num=(sumenep-sumene)/aincr
5387         yy=yysave
5388         write (2,*) "yy+ sumene from enesc=",sumenep
5389         zzsave=zz
5390         zz=zz+aincr
5391         write (2,*) xx,yy,zz
5392         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5393         de_dzz_num=(sumenep-sumene)/aincr
5394         zz=zzsave
5395         write (2,*) "zz+ sumene from enesc=",sumenep
5396         costsave=cost2tab(i+1)
5397         sintsave=sint2tab(i+1)
5398         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5399         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5400         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         de_dt_num=(sumenep-sumene)/aincr
5402         write (2,*) " t+ sumene from enesc=",sumenep
5403         cost2tab(i+1)=costsave
5404         sint2tab(i+1)=sintsave
5405 ! End of diagnostics section.
5406 #endif
5407 !
5408 ! Compute the gradient of esc
5409 !
5410 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5411         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5412         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5413         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5414         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5415         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5416         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5417         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5418         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5419         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5420            *(pom_s1/dscp1+pom_s16*dscp1**4)
5421         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5422            *(pom_s2/dscp2+pom_s26*dscp2**4)
5423         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5424         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5425         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5426         +x(40)*yy*zz
5427         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5428         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5429         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5430         +x(60)*yy*zz
5431         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5432               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5433               +(pom1+pom2)*pom_dx
5434 #ifdef DEBUG
5435         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5436 #endif
5437 !
5438         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5439         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5440         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5441         +x(40)*xx*zz
5442         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5443         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5444         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5445         +x(59)*zz**2 +x(60)*xx*zz
5446         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5447               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5448               +(pom1-pom2)*pom_dy
5449 #ifdef DEBUG
5450         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5451 #endif
5452 !
5453         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5454         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5455         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5456         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5457         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5458         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5459         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5460         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5461 #ifdef DEBUG
5462         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5463 #endif
5464 !
5465         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5466         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5467         +pom1*pom_dt1+pom2*pom_dt2
5468 #ifdef DEBUG
5469         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5470 #endif
5471 !
5472 !
5473        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5474        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5475        cosfac2xx=cosfac2*xx
5476        sinfac2yy=sinfac2*yy
5477        do k = 1,3
5478          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5479             vbld_inv(i+1)
5480          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5481             vbld_inv(i)
5482          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5483          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5484 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5485 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5486 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5487 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5488          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5489          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5490          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5491          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5492          dZZ_Ci1(k)=0.0d0
5493          dZZ_Ci(k)=0.0d0
5494          do j=1,3
5495            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5496            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5497            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5498            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5499          enddo
5500
5501          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5502          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5503          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5504          (z_prime(k)-zz*dC_norm(k,i+nres))
5505 !
5506          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5507          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5508        enddo
5509
5510        do k=1,3
5511          dXX_Ctab(k,i)=dXX_Ci(k)
5512          dXX_C1tab(k,i)=dXX_Ci1(k)
5513          dYY_Ctab(k,i)=dYY_Ci(k)
5514          dYY_C1tab(k,i)=dYY_Ci1(k)
5515          dZZ_Ctab(k,i)=dZZ_Ci(k)
5516          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5517          dXX_XYZtab(k,i)=dXX_XYZ(k)
5518          dYY_XYZtab(k,i)=dYY_XYZ(k)
5519          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5520        enddo
5521
5522        do k = 1,3
5523 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5524 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5525 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5526 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5527 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5528 !     &    dt_dci(k)
5529 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5530 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5531          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5532           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5533          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5534           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5535          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5536           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5537        enddo
5538 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5539 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5540
5541 ! to check gradient call subroutine check_grad
5542
5543     1 continue
5544       enddo
5545       return
5546       end subroutine esc
5547 !-----------------------------------------------------------------------------
5548       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5549 !      implicit none
5550       real(kind=8),dimension(65) :: x
5551       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5552         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5553
5554       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5555         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5556         + x(10)*yy*zz
5557       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5558         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5559         + x(20)*yy*zz
5560       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5561         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5562         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5563         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5564         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5565         +x(40)*xx*yy*zz
5566       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5567         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5568         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5569         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5570         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5571         +x(60)*xx*yy*zz
5572       dsc_i   = 0.743d0+x(61)
5573       dp2_i   = 1.9d0+x(62)
5574       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5575                 *(xx*cost2+yy*sint2))
5576       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5577                 *(xx*cost2-yy*sint2))
5578       s1=(1+x(63))/(0.1d0 + dscp1)
5579       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5580       s2=(1+x(65))/(0.1d0 + dscp2)
5581       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5582       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5583        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5584       enesc=sumene
5585       return
5586       end function enesc
5587 #endif
5588 !-----------------------------------------------------------------------------
5589       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5590 !
5591 ! This procedure calculates two-body contact function g(rij) and its derivative:
5592 !
5593 !           eps0ij                                     !       x < -1
5594 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5595 !            0                                         !       x > 1
5596 !
5597 ! where x=(rij-r0ij)/delta
5598 !
5599 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5600 !
5601 !      implicit none
5602       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5603       real(kind=8) :: x,x2,x4,delta
5604 !     delta=0.02D0*r0ij
5605 !      delta=0.2D0*r0ij
5606       x=(rij-r0ij)/delta
5607       if (x.lt.-1.0D0) then
5608         fcont=eps0ij
5609         fprimcont=0.0D0
5610       else if (x.le.1.0D0) then
5611         x2=x*x
5612         x4=x2*x2
5613         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5614         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5615       else
5616         fcont=0.0D0
5617         fprimcont=0.0D0
5618       endif
5619       return
5620       end subroutine gcont
5621 !-----------------------------------------------------------------------------
5622       subroutine splinthet(theti,delta,ss,ssder)
5623 !      implicit real*8 (a-h,o-z)
5624 !      include 'DIMENSIONS'
5625 !      include 'COMMON.VAR'
5626 !      include 'COMMON.GEO'
5627       real(kind=8) :: theti,delta,ss,ssder
5628       real(kind=8) :: thetup,thetlow
5629       thetup=pi-delta
5630       thetlow=delta
5631       if (theti.gt.pipol) then
5632         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5633       else
5634         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5635         ssder=-ssder
5636       endif
5637       return
5638       end subroutine splinthet
5639 !-----------------------------------------------------------------------------
5640       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5641 !      implicit none
5642       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5643       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5644       a1=fprim0*delta/(f1-f0)
5645       a2=3.0d0-2.0d0*a1
5646       a3=a1-2.0d0
5647       ksi=(x-x0)/delta
5648       ksi2=ksi*ksi
5649       ksi3=ksi2*ksi
5650       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5651       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5652       return
5653       end subroutine spline1
5654 !-----------------------------------------------------------------------------
5655       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5656 !      implicit none
5657       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5658       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5659       ksi=(x-x0)/delta
5660       ksi2=ksi*ksi
5661       ksi3=ksi2*ksi
5662       a1=fprim0x*delta
5663       a2=3*(f1x-f0x)-2*fprim0x*delta
5664       a3=fprim0x*delta-2*(f1x-f0x)
5665       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5666       return
5667       end subroutine spline2
5668 !-----------------------------------------------------------------------------
5669 #ifdef CRYST_TOR
5670 !-----------------------------------------------------------------------------
5671       subroutine etor(etors,edihcnstr)
5672 !      implicit real*8 (a-h,o-z)
5673 !      include 'DIMENSIONS'
5674 !      include 'COMMON.VAR'
5675 !      include 'COMMON.GEO'
5676 !      include 'COMMON.LOCAL'
5677 !      include 'COMMON.TORSION'
5678 !      include 'COMMON.INTERACT'
5679 !      include 'COMMON.DERIV'
5680 !      include 'COMMON.CHAIN'
5681 !      include 'COMMON.NAMES'
5682 !      include 'COMMON.IOUNITS'
5683 !      include 'COMMON.FFIELD'
5684 !      include 'COMMON.TORCNSTR'
5685 !      include 'COMMON.CONTROL'
5686       real(kind=8) :: etors,edihcnstr
5687       logical :: lprn
5688 !el local variables
5689       integer :: i,j,
5690       real(kind=8) :: phii,fac,etors_ii
5691
5692 ! Set lprn=.true. for debugging
5693       lprn=.false.
5694 !      lprn=.true.
5695       etors=0.0D0
5696       do i=iphi_start,iphi_end
5697       etors_ii=0.0D0
5698         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5699             .or. itype(i).eq.ntyp1) cycle
5700         itori=itortyp(itype(i-2))
5701         itori1=itortyp(itype(i-1))
5702         phii=phi(i)
5703         gloci=0.0D0
5704 ! Proline-Proline pair is a special case...
5705         if (itori.eq.3 .and. itori1.eq.3) then
5706           if (phii.gt.-dwapi3) then
5707             cosphi=dcos(3*phii)
5708             fac=1.0D0/(1.0D0-cosphi)
5709             etorsi=v1(1,3,3)*fac
5710             etorsi=etorsi+etorsi
5711             etors=etors+etorsi-v1(1,3,3)
5712             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5713             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5714           endif
5715           do j=1,3
5716             v1ij=v1(j+1,itori,itori1)
5717             v2ij=v2(j+1,itori,itori1)
5718             cosphi=dcos(j*phii)
5719             sinphi=dsin(j*phii)
5720             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5721             if (energy_dec) etors_ii=etors_ii+ &
5722                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5723             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5724           enddo
5725         else
5726           do j=1,nterm_old
5727             v1ij=v1(j,itori,itori1)
5728             v2ij=v2(j,itori,itori1)
5729             cosphi=dcos(j*phii)
5730             sinphi=dsin(j*phii)
5731             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5732             if (energy_dec) etors_ii=etors_ii+ &
5733                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5734             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5735           enddo
5736         endif
5737         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5738              'etor',i,etors_ii
5739         if (lprn) &
5740         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5741         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5742         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5743         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5744 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5745       enddo
5746 ! 6/20/98 - dihedral angle constraints
5747       edihcnstr=0.0d0
5748       do i=1,ndih_constr
5749         itori=idih_constr(i)
5750         phii=phi(itori)
5751         difi=phii-phi0(i)
5752         if (difi.gt.drange(i)) then
5753           difi=difi-drange(i)
5754           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5755           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5756         else if (difi.lt.-drange(i)) then
5757           difi=difi+drange(i)
5758           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5759           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5760         endif
5761 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5762 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5763       enddo
5764 !      write (iout,*) 'edihcnstr',edihcnstr
5765       return
5766       end subroutine etor
5767 !-----------------------------------------------------------------------------
5768       subroutine etor_d(etors_d)
5769       real(kind=8) :: etors_d
5770       etors_d=0.0d0
5771       return
5772       end subroutine etor_d
5773 #else
5774 !-----------------------------------------------------------------------------
5775       subroutine etor(etors,edihcnstr)
5776 !      implicit real*8 (a-h,o-z)
5777 !      include 'DIMENSIONS'
5778 !      include 'COMMON.VAR'
5779 !      include 'COMMON.GEO'
5780 !      include 'COMMON.LOCAL'
5781 !      include 'COMMON.TORSION'
5782 !      include 'COMMON.INTERACT'
5783 !      include 'COMMON.DERIV'
5784 !      include 'COMMON.CHAIN'
5785 !      include 'COMMON.NAMES'
5786 !      include 'COMMON.IOUNITS'
5787 !      include 'COMMON.FFIELD'
5788 !      include 'COMMON.TORCNSTR'
5789 !      include 'COMMON.CONTROL'
5790       real(kind=8) :: etors,edihcnstr
5791       logical :: lprn
5792 !el local variables
5793       integer :: i,j,iblock,itori,itori1
5794       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5795                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5796 ! Set lprn=.true. for debugging
5797       lprn=.false.
5798 !     lprn=.true.
5799       etors=0.0D0
5800       do i=iphi_start,iphi_end
5801         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5802              .or. itype(i-3).eq.ntyp1 &
5803              .or. itype(i).eq.ntyp1) cycle
5804         etors_ii=0.0D0
5805          if (iabs(itype(i)).eq.20) then
5806          iblock=2
5807          else
5808          iblock=1
5809          endif
5810         itori=itortyp(itype(i-2))
5811         itori1=itortyp(itype(i-1))
5812         phii=phi(i)
5813         gloci=0.0D0
5814 ! Regular cosine and sine terms
5815         do j=1,nterm(itori,itori1,iblock)
5816           v1ij=v1(j,itori,itori1,iblock)
5817           v2ij=v2(j,itori,itori1,iblock)
5818           cosphi=dcos(j*phii)
5819           sinphi=dsin(j*phii)
5820           etors=etors+v1ij*cosphi+v2ij*sinphi
5821           if (energy_dec) etors_ii=etors_ii+ &
5822                      v1ij*cosphi+v2ij*sinphi
5823           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5824         enddo
5825 ! Lorentz terms
5826 !                         v1
5827 !  E = SUM ----------------------------------- - v1
5828 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5829 !
5830         cosphi=dcos(0.5d0*phii)
5831         sinphi=dsin(0.5d0*phii)
5832         do j=1,nlor(itori,itori1,iblock)
5833           vl1ij=vlor1(j,itori,itori1)
5834           vl2ij=vlor2(j,itori,itori1)
5835           vl3ij=vlor3(j,itori,itori1)
5836           pom=vl2ij*cosphi+vl3ij*sinphi
5837           pom1=1.0d0/(pom*pom+1.0d0)
5838           etors=etors+vl1ij*pom1
5839           if (energy_dec) etors_ii=etors_ii+ &
5840                      vl1ij*pom1
5841           pom=-pom*pom1*pom1
5842           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5843         enddo
5844 ! Subtract the constant term
5845         etors=etors-v0(itori,itori1,iblock)
5846           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5847                'etor',i,etors_ii-v0(itori,itori1,iblock)
5848         if (lprn) &
5849         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5850         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5851         (v1(j,itori,itori1,iblock),j=1,6),&
5852         (v2(j,itori,itori1,iblock),j=1,6)
5853         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5854 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5855       enddo
5856 ! 6/20/98 - dihedral angle constraints
5857       edihcnstr=0.0d0
5858 !      do i=1,ndih_constr
5859       do i=idihconstr_start,idihconstr_end
5860         itori=idih_constr(i)
5861         phii=phi(itori)
5862         difi=pinorm(phii-phi0(i))
5863         if (difi.gt.drange(i)) then
5864           difi=difi-drange(i)
5865           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5866           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5867         else if (difi.lt.-drange(i)) then
5868           difi=difi+drange(i)
5869           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5870           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5871         else
5872           difi=0.0
5873         endif
5874 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5875 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5876 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5877       enddo
5878 !d       write (iout,*) 'edihcnstr',edihcnstr
5879       return
5880       end subroutine etor
5881 !-----------------------------------------------------------------------------
5882       subroutine etor_d(etors_d)
5883 ! 6/23/01 Compute double torsional energy
5884 !      implicit real*8 (a-h,o-z)
5885 !      include 'DIMENSIONS'
5886 !      include 'COMMON.VAR'
5887 !      include 'COMMON.GEO'
5888 !      include 'COMMON.LOCAL'
5889 !      include 'COMMON.TORSION'
5890 !      include 'COMMON.INTERACT'
5891 !      include 'COMMON.DERIV'
5892 !      include 'COMMON.CHAIN'
5893 !      include 'COMMON.NAMES'
5894 !      include 'COMMON.IOUNITS'
5895 !      include 'COMMON.FFIELD'
5896 !      include 'COMMON.TORCNSTR'
5897       real(kind=8) :: etors_d,etors_d_ii
5898       logical :: lprn
5899 !el local variables
5900       integer :: i,j,k,l,itori,itori1,itori2,iblock
5901       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5902                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5903                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5904                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5905 ! Set lprn=.true. for debugging
5906       lprn=.false.
5907 !     lprn=.true.
5908       etors_d=0.0D0
5909 !      write(iout,*) "a tu??"
5910       do i=iphid_start,iphid_end
5911         etors_d_ii=0.0D0
5912         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5913             .or. itype(i-3).eq.ntyp1 &
5914             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5915         itori=itortyp(itype(i-2))
5916         itori1=itortyp(itype(i-1))
5917         itori2=itortyp(itype(i))
5918         phii=phi(i)
5919         phii1=phi(i+1)
5920         gloci1=0.0D0
5921         gloci2=0.0D0
5922         iblock=1
5923         if (iabs(itype(i+1)).eq.20) iblock=2
5924
5925 ! Regular cosine and sine terms
5926         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5927           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5928           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5929           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5930           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5931           cosphi1=dcos(j*phii)
5932           sinphi1=dsin(j*phii)
5933           cosphi2=dcos(j*phii1)
5934           sinphi2=dsin(j*phii1)
5935           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5936            v2cij*cosphi2+v2sij*sinphi2
5937           if (energy_dec) etors_d_ii=etors_d_ii+ &
5938            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5939           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5940           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5941         enddo
5942         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5943           do l=1,k-1
5944             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5945             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5946             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5947             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5948             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5949             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5950             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5951             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5952             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5953               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5954             if (energy_dec) etors_d_ii=etors_d_ii+ &
5955               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5956               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5957             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5958               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5959             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5960               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5961           enddo
5962         enddo
5963         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5964                             'etor_d',i,etors_d_ii
5965         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5966         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5967       enddo
5968       return
5969       end subroutine etor_d
5970 #endif
5971 !-----------------------------------------------------------------------------
5972       subroutine eback_sc_corr(esccor)
5973 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5974 !        conformational states; temporarily implemented as differences
5975 !        between UNRES torsional potentials (dependent on three types of
5976 !        residues) and the torsional potentials dependent on all 20 types
5977 !        of residues computed from AM1  energy surfaces of terminally-blocked
5978 !        amino-acid residues.
5979 !      implicit real*8 (a-h,o-z)
5980 !      include 'DIMENSIONS'
5981 !      include 'COMMON.VAR'
5982 !      include 'COMMON.GEO'
5983 !      include 'COMMON.LOCAL'
5984 !      include 'COMMON.TORSION'
5985 !      include 'COMMON.SCCOR'
5986 !      include 'COMMON.INTERACT'
5987 !      include 'COMMON.DERIV'
5988 !      include 'COMMON.CHAIN'
5989 !      include 'COMMON.NAMES'
5990 !      include 'COMMON.IOUNITS'
5991 !      include 'COMMON.FFIELD'
5992 !      include 'COMMON.CONTROL'
5993       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5994                    cosphi,sinphi
5995       logical :: lprn
5996       integer :: i,interty,j,isccori,isccori1,intertyp
5997 ! Set lprn=.true. for debugging
5998       lprn=.false.
5999 !      lprn=.true.
6000 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6001       esccor=0.0D0
6002       do i=itau_start,itau_end
6003         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6004         esccor_ii=0.0D0
6005         isccori=isccortyp(itype(i-2))
6006         isccori1=isccortyp(itype(i-1))
6007
6008 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6009         phii=phi(i)
6010         do intertyp=1,3 !intertyp
6011          esccor_ii=0.0D0
6012 !c Added 09 May 2012 (Adasko)
6013 !c  Intertyp means interaction type of backbone mainchain correlation:
6014 !   1 = SC...Ca...Ca...Ca
6015 !   2 = Ca...Ca...Ca...SC
6016 !   3 = SC...Ca...Ca...SCi
6017         gloci=0.0D0
6018         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6019             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6020             (itype(i-1).eq.ntyp1))) &
6021           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6022            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6023            .or.(itype(i).eq.ntyp1))) &
6024           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6025             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6026             (itype(i-3).eq.ntyp1)))) cycle
6027         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6028         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6029        cycle
6030        do j=1,nterm_sccor(isccori,isccori1)
6031           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6032           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6033           cosphi=dcos(j*tauangle(intertyp,i))
6034           sinphi=dsin(j*tauangle(intertyp,i))
6035           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6036           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6037           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6038         enddo
6039         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6040                                 'esccor',i,intertyp,esccor_ii
6041 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6042         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6043         if (lprn) &
6044         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6045         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6046         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6047         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6048         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6049        enddo !intertyp
6050       enddo
6051
6052       return
6053       end subroutine eback_sc_corr
6054 !-----------------------------------------------------------------------------
6055       subroutine multibody(ecorr)
6056 ! This subroutine calculates multi-body contributions to energy following
6057 ! the idea of Skolnick et al. If side chains I and J make a contact and
6058 ! at the same time side chains I+1 and J+1 make a contact, an extra
6059 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6060 !      implicit real*8 (a-h,o-z)
6061 !      include 'DIMENSIONS'
6062 !      include 'COMMON.IOUNITS'
6063 !      include 'COMMON.DERIV'
6064 !      include 'COMMON.INTERACT'
6065 !      include 'COMMON.CONTACTS'
6066       real(kind=8),dimension(3) :: gx,gx1
6067       logical :: lprn
6068       real(kind=8) :: ecorr
6069       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6070 ! Set lprn=.true. for debugging
6071       lprn=.false.
6072
6073       if (lprn) then
6074         write (iout,'(a)') 'Contact function values:'
6075         do i=nnt,nct-2
6076           write (iout,'(i2,20(1x,i2,f10.5))') &
6077               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6078         enddo
6079       endif
6080       ecorr=0.0D0
6081
6082 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6083 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6084       do i=nnt,nct
6085         do j=1,3
6086           gradcorr(j,i)=0.0D0
6087           gradxorr(j,i)=0.0D0
6088         enddo
6089       enddo
6090       do i=nnt,nct-2
6091
6092         DO ISHIFT = 3,4
6093
6094         i1=i+ishift
6095         num_conti=num_cont(i)
6096         num_conti1=num_cont(i1)
6097         do jj=1,num_conti
6098           j=jcont(jj,i)
6099           do kk=1,num_conti1
6100             j1=jcont(kk,i1)
6101             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6102 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6103 !d   &                   ' ishift=',ishift
6104 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6105 ! The system gains extra energy.
6106               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6107             endif   ! j1==j+-ishift
6108           enddo     ! kk
6109         enddo       ! jj
6110
6111         ENDDO ! ISHIFT
6112
6113       enddo         ! i
6114       return
6115       end subroutine multibody
6116 !-----------------------------------------------------------------------------
6117       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6118 !      implicit real*8 (a-h,o-z)
6119 !      include 'DIMENSIONS'
6120 !      include 'COMMON.IOUNITS'
6121 !      include 'COMMON.DERIV'
6122 !      include 'COMMON.INTERACT'
6123 !      include 'COMMON.CONTACTS'
6124       real(kind=8),dimension(3) :: gx,gx1
6125       logical :: lprn
6126       integer :: i,j,k,l,jj,kk,m,ll
6127       real(kind=8) :: eij,ekl
6128       lprn=.false.
6129       eij=facont(jj,i)
6130       ekl=facont(kk,k)
6131 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6132 ! Calculate the multi-body contribution to energy.
6133 ! Calculate multi-body contributions to the gradient.
6134 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6135 !d   & k,l,(gacont(m,kk,k),m=1,3)
6136       do m=1,3
6137         gx(m) =ekl*gacont(m,jj,i)
6138         gx1(m)=eij*gacont(m,kk,k)
6139         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6140         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6141         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6142         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6143       enddo
6144       do m=i,j-1
6145         do ll=1,3
6146           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6147         enddo
6148       enddo
6149       do m=k,l-1
6150         do ll=1,3
6151           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6152         enddo
6153       enddo
6154       esccorr=-eij*ekl
6155       return
6156       end function esccorr
6157 !-----------------------------------------------------------------------------
6158       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6159 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6160 !      implicit real*8 (a-h,o-z)
6161 !      include 'DIMENSIONS'
6162 !      include 'COMMON.IOUNITS'
6163 #ifdef MPI
6164       include "mpif.h"
6165 !      integer :: maxconts !max_cont=maxconts  =nres/4
6166       integer,parameter :: max_dim=26
6167       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6168       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6169 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6170 !el      common /przechowalnia/ zapas
6171       integer :: status(MPI_STATUS_SIZE)
6172       integer,dimension((nres/4)*2) :: req !maxconts*2
6173       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6174 #endif
6175 !      include 'COMMON.SETUP'
6176 !      include 'COMMON.FFIELD'
6177 !      include 'COMMON.DERIV'
6178 !      include 'COMMON.INTERACT'
6179 !      include 'COMMON.CONTACTS'
6180 !      include 'COMMON.CONTROL'
6181 !      include 'COMMON.LOCAL'
6182       real(kind=8),dimension(3) :: gx,gx1
6183       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6184       logical :: lprn,ldone
6185 !el local variables
6186       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6187               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6188
6189 ! Set lprn=.true. for debugging
6190       lprn=.false.
6191 #ifdef MPI
6192 !      maxconts=nres/4
6193       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6194       n_corr=0
6195       n_corr1=0
6196       if (nfgtasks.le.1) goto 30
6197       if (lprn) then
6198         write (iout,'(a)') 'Contact function values before RECEIVE:'
6199         do i=nnt,nct-2
6200           write (iout,'(2i3,50(1x,i2,f5.2))') &
6201           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6202           j=1,num_cont_hb(i))
6203         enddo
6204       endif
6205       call flush(iout)
6206       do i=1,ntask_cont_from
6207         ncont_recv(i)=0
6208       enddo
6209       do i=1,ntask_cont_to
6210         ncont_sent(i)=0
6211       enddo
6212 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6213 !     & ntask_cont_to
6214 ! Make the list of contacts to send to send to other procesors
6215 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6216 !      call flush(iout)
6217       do i=iturn3_start,iturn3_end
6218 !        write (iout,*) "make contact list turn3",i," num_cont",
6219 !     &    num_cont_hb(i)
6220         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6221       enddo
6222       do i=iturn4_start,iturn4_end
6223 !        write (iout,*) "make contact list turn4",i," num_cont",
6224 !     &   num_cont_hb(i)
6225         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6226       enddo
6227       do ii=1,nat_sent
6228         i=iat_sent(ii)
6229 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6230 !     &    num_cont_hb(i)
6231         do j=1,num_cont_hb(i)
6232         do k=1,4
6233           jjc=jcont_hb(j,i)
6234           iproc=iint_sent_local(k,jjc,ii)
6235 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6236           if (iproc.gt.0) then
6237             ncont_sent(iproc)=ncont_sent(iproc)+1
6238             nn=ncont_sent(iproc)
6239             zapas(1,nn,iproc)=i
6240             zapas(2,nn,iproc)=jjc
6241             zapas(3,nn,iproc)=facont_hb(j,i)
6242             zapas(4,nn,iproc)=ees0p(j,i)
6243             zapas(5,nn,iproc)=ees0m(j,i)
6244             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6245             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6246             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6247             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6248             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6249             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6250             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6251             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6252             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6253             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6254             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6255             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6256             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6257             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6258             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6259             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6260             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6261             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6262             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6263             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6264             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6265           endif
6266         enddo
6267         enddo
6268       enddo
6269       if (lprn) then
6270       write (iout,*) &
6271         "Numbers of contacts to be sent to other processors",&
6272         (ncont_sent(i),i=1,ntask_cont_to)
6273       write (iout,*) "Contacts sent"
6274       do ii=1,ntask_cont_to
6275         nn=ncont_sent(ii)
6276         iproc=itask_cont_to(ii)
6277         write (iout,*) nn," contacts to processor",iproc,&
6278          " of CONT_TO_COMM group"
6279         do i=1,nn
6280           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6281         enddo
6282       enddo
6283       call flush(iout)
6284       endif
6285       CorrelType=477
6286       CorrelID=fg_rank+1
6287       CorrelType1=478
6288       CorrelID1=nfgtasks+fg_rank+1
6289       ireq=0
6290 ! Receive the numbers of needed contacts from other processors
6291       do ii=1,ntask_cont_from
6292         iproc=itask_cont_from(ii)
6293         ireq=ireq+1
6294         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6295           FG_COMM,req(ireq),IERR)
6296       enddo
6297 !      write (iout,*) "IRECV ended"
6298 !      call flush(iout)
6299 ! Send the number of contacts needed by other processors
6300       do ii=1,ntask_cont_to
6301         iproc=itask_cont_to(ii)
6302         ireq=ireq+1
6303         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6304           FG_COMM,req(ireq),IERR)
6305       enddo
6306 !      write (iout,*) "ISEND ended"
6307 !      write (iout,*) "number of requests (nn)",ireq
6308       call flush(iout)
6309       if (ireq.gt.0) &
6310         call MPI_Waitall(ireq,req,status_array,ierr)
6311 !      write (iout,*)
6312 !     &  "Numbers of contacts to be received from other processors",
6313 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6314 !      call flush(iout)
6315 ! Receive contacts
6316       ireq=0
6317       do ii=1,ntask_cont_from
6318         iproc=itask_cont_from(ii)
6319         nn=ncont_recv(ii)
6320 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6321 !     &   " of CONT_TO_COMM group"
6322         call flush(iout)
6323         if (nn.gt.0) then
6324           ireq=ireq+1
6325           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6326           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6327 !          write (iout,*) "ireq,req",ireq,req(ireq)
6328         endif
6329       enddo
6330 ! Send the contacts to processors that need them
6331       do ii=1,ntask_cont_to
6332         iproc=itask_cont_to(ii)
6333         nn=ncont_sent(ii)
6334 !        write (iout,*) nn," contacts to processor",iproc,
6335 !     &   " of CONT_TO_COMM group"
6336         if (nn.gt.0) then
6337           ireq=ireq+1
6338           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6339             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6340 !          write (iout,*) "ireq,req",ireq,req(ireq)
6341 !          do i=1,nn
6342 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6343 !          enddo
6344         endif
6345       enddo
6346 !      write (iout,*) "number of requests (contacts)",ireq
6347 !      write (iout,*) "req",(req(i),i=1,4)
6348 !      call flush(iout)
6349       if (ireq.gt.0) &
6350        call MPI_Waitall(ireq,req,status_array,ierr)
6351       do iii=1,ntask_cont_from
6352         iproc=itask_cont_from(iii)
6353         nn=ncont_recv(iii)
6354         if (lprn) then
6355         write (iout,*) "Received",nn," contacts from processor",iproc,&
6356          " of CONT_FROM_COMM group"
6357         call flush(iout)
6358         do i=1,nn
6359           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6360         enddo
6361         call flush(iout)
6362         endif
6363         do i=1,nn
6364           ii=zapas_recv(1,i,iii)
6365 ! Flag the received contacts to prevent double-counting
6366           jj=-zapas_recv(2,i,iii)
6367 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6368 !          call flush(iout)
6369           nnn=num_cont_hb(ii)+1
6370           num_cont_hb(ii)=nnn
6371           jcont_hb(nnn,ii)=jj
6372           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6373           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6374           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6375           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6376           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6377           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6378           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6379           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6380           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6381           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6382           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6383           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6384           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6385           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6386           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6387           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6388           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6389           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6390           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6391           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6392           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6393           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6394           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6395           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6396         enddo
6397       enddo
6398       call flush(iout)
6399       if (lprn) then
6400         write (iout,'(a)') 'Contact function values after receive:'
6401         do i=nnt,nct-2
6402           write (iout,'(2i3,50(1x,i3,f5.2))') &
6403           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6404           j=1,num_cont_hb(i))
6405         enddo
6406         call flush(iout)
6407       endif
6408    30 continue
6409 #endif
6410       if (lprn) then
6411         write (iout,'(a)') 'Contact function values:'
6412         do i=nnt,nct-2
6413           write (iout,'(2i3,50(1x,i3,f5.2))') &
6414           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6415           j=1,num_cont_hb(i))
6416         enddo
6417       endif
6418       ecorr=0.0D0
6419
6420 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6421 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6422 ! Remove the loop below after debugging !!!
6423       do i=nnt,nct
6424         do j=1,3
6425           gradcorr(j,i)=0.0D0
6426           gradxorr(j,i)=0.0D0
6427         enddo
6428       enddo
6429 ! Calculate the local-electrostatic correlation terms
6430       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6431         i1=i+1
6432         num_conti=num_cont_hb(i)
6433         num_conti1=num_cont_hb(i+1)
6434         do jj=1,num_conti
6435           j=jcont_hb(jj,i)
6436           jp=iabs(j)
6437           do kk=1,num_conti1
6438             j1=jcont_hb(kk,i1)
6439             jp1=iabs(j1)
6440 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6441 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6442             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6443                 .or. j.lt.0 .and. j1.gt.0) .and. &
6444                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6445 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6446 ! The system gains extra energy.
6447               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6448               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6449                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6450               n_corr=n_corr+1
6451             else if (j1.eq.j) then
6452 ! Contacts I-J and I-(J+1) occur simultaneously.
6453 ! The system loses extra energy.
6454 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6455             endif
6456           enddo ! kk
6457           do kk=1,num_conti
6458             j1=jcont_hb(kk,i)
6459 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6460 !    &         ' jj=',jj,' kk=',kk
6461             if (j1.eq.j+1) then
6462 ! Contacts I-J and (I+1)-J occur simultaneously.
6463 ! The system loses extra energy.
6464 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6465             endif ! j1==j+1
6466           enddo ! kk
6467         enddo ! jj
6468       enddo ! i
6469       return
6470       end subroutine multibody_hb
6471 !-----------------------------------------------------------------------------
6472       subroutine add_hb_contact(ii,jj,itask)
6473 !      implicit real*8 (a-h,o-z)
6474 !      include "DIMENSIONS"
6475 !      include "COMMON.IOUNITS"
6476 !      include "COMMON.CONTACTS"
6477 !      integer,parameter :: maxconts=nres/4
6478       integer,parameter :: max_dim=26
6479       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6480 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6481 !      common /przechowalnia/ zapas
6482       integer :: i,j,ii,jj,iproc,nn,jjc
6483       integer,dimension(4) :: itask
6484 !      write (iout,*) "itask",itask
6485       do i=1,2
6486         iproc=itask(i)
6487         if (iproc.gt.0) then
6488           do j=1,num_cont_hb(ii)
6489             jjc=jcont_hb(j,ii)
6490 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6491             if (jjc.eq.jj) then
6492               ncont_sent(iproc)=ncont_sent(iproc)+1
6493               nn=ncont_sent(iproc)
6494               zapas(1,nn,iproc)=ii
6495               zapas(2,nn,iproc)=jjc
6496               zapas(3,nn,iproc)=facont_hb(j,ii)
6497               zapas(4,nn,iproc)=ees0p(j,ii)
6498               zapas(5,nn,iproc)=ees0m(j,ii)
6499               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6500               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6501               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6502               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6503               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6504               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6505               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6506               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6507               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6508               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6509               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6510               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6511               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6512               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6513               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6514               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6515               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6516               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6517               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6518               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6519               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6520               exit
6521             endif
6522           enddo
6523         endif
6524       enddo
6525       return
6526       end subroutine add_hb_contact
6527 !-----------------------------------------------------------------------------
6528       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6529 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6530 !      implicit real*8 (a-h,o-z)
6531 !      include 'DIMENSIONS'
6532 !      include 'COMMON.IOUNITS'
6533       integer,parameter :: max_dim=70
6534 #ifdef MPI
6535       include "mpif.h"
6536 !      integer :: maxconts !max_cont=maxconts=nres/4
6537       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6538       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6539 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6540 !      common /przechowalnia/ zapas
6541       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6542         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6543         ierr,iii,nnn
6544 #endif
6545 !      include 'COMMON.SETUP'
6546 !      include 'COMMON.FFIELD'
6547 !      include 'COMMON.DERIV'
6548 !      include 'COMMON.LOCAL'
6549 !      include 'COMMON.INTERACT'
6550 !      include 'COMMON.CONTACTS'
6551 !      include 'COMMON.CHAIN'
6552 !      include 'COMMON.CONTROL'
6553       real(kind=8),dimension(3) :: gx,gx1
6554       integer,dimension(nres) :: num_cont_hb_old
6555       logical :: lprn,ldone
6556 !EL      double precision eello4,eello5,eelo6,eello_turn6
6557 !EL      external eello4,eello5,eello6,eello_turn6
6558 !el local variables
6559       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6560               j1,jp1,i1,num_conti1
6561       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6562       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6563
6564 ! Set lprn=.true. for debugging
6565       lprn=.false.
6566       eturn6=0.0d0
6567 #ifdef MPI
6568 !      maxconts=nres/4
6569       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6570       do i=1,nres
6571         num_cont_hb_old(i)=num_cont_hb(i)
6572       enddo
6573       n_corr=0
6574       n_corr1=0
6575       if (nfgtasks.le.1) goto 30
6576       if (lprn) then
6577         write (iout,'(a)') 'Contact function values before RECEIVE:'
6578         do i=nnt,nct-2
6579           write (iout,'(2i3,50(1x,i2,f5.2))') &
6580           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6581           j=1,num_cont_hb(i))
6582         enddo
6583       endif
6584       call flush(iout)
6585       do i=1,ntask_cont_from
6586         ncont_recv(i)=0
6587       enddo
6588       do i=1,ntask_cont_to
6589         ncont_sent(i)=0
6590       enddo
6591 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6592 !     & ntask_cont_to
6593 ! Make the list of contacts to send to send to other procesors
6594       do i=iturn3_start,iturn3_end
6595 !        write (iout,*) "make contact list turn3",i," num_cont",
6596 !     &    num_cont_hb(i)
6597         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6598       enddo
6599       do i=iturn4_start,iturn4_end
6600 !        write (iout,*) "make contact list turn4",i," num_cont",
6601 !     &   num_cont_hb(i)
6602         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6603       enddo
6604       do ii=1,nat_sent
6605         i=iat_sent(ii)
6606 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6607 !     &    num_cont_hb(i)
6608         do j=1,num_cont_hb(i)
6609         do k=1,4
6610           jjc=jcont_hb(j,i)
6611           iproc=iint_sent_local(k,jjc,ii)
6612 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6613           if (iproc.ne.0) then
6614             ncont_sent(iproc)=ncont_sent(iproc)+1
6615             nn=ncont_sent(iproc)
6616             zapas(1,nn,iproc)=i
6617             zapas(2,nn,iproc)=jjc
6618             zapas(3,nn,iproc)=d_cont(j,i)
6619             ind=3
6620             do kk=1,3
6621               ind=ind+1
6622               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6623             enddo
6624             do kk=1,2
6625               do ll=1,2
6626                 ind=ind+1
6627                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6628               enddo
6629             enddo
6630             do jj=1,5
6631               do kk=1,3
6632                 do ll=1,2
6633                   do mm=1,2
6634                     ind=ind+1
6635                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6636                   enddo
6637                 enddo
6638               enddo
6639             enddo
6640           endif
6641         enddo
6642         enddo
6643       enddo
6644       if (lprn) then
6645       write (iout,*) &
6646         "Numbers of contacts to be sent to other processors",&
6647         (ncont_sent(i),i=1,ntask_cont_to)
6648       write (iout,*) "Contacts sent"
6649       do ii=1,ntask_cont_to
6650         nn=ncont_sent(ii)
6651         iproc=itask_cont_to(ii)
6652         write (iout,*) nn," contacts to processor",iproc,&
6653          " of CONT_TO_COMM group"
6654         do i=1,nn
6655           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6656         enddo
6657       enddo
6658       call flush(iout)
6659       endif
6660       CorrelType=477
6661       CorrelID=fg_rank+1
6662       CorrelType1=478
6663       CorrelID1=nfgtasks+fg_rank+1
6664       ireq=0
6665 ! Receive the numbers of needed contacts from other processors
6666       do ii=1,ntask_cont_from
6667         iproc=itask_cont_from(ii)
6668         ireq=ireq+1
6669         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6670           FG_COMM,req(ireq),IERR)
6671       enddo
6672 !      write (iout,*) "IRECV ended"
6673 !      call flush(iout)
6674 ! Send the number of contacts needed by other processors
6675       do ii=1,ntask_cont_to
6676         iproc=itask_cont_to(ii)
6677         ireq=ireq+1
6678         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6679           FG_COMM,req(ireq),IERR)
6680       enddo
6681 !      write (iout,*) "ISEND ended"
6682 !      write (iout,*) "number of requests (nn)",ireq
6683       call flush(iout)
6684       if (ireq.gt.0) &
6685         call MPI_Waitall(ireq,req,status_array,ierr)
6686 !      write (iout,*)
6687 !     &  "Numbers of contacts to be received from other processors",
6688 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6689 !      call flush(iout)
6690 ! Receive contacts
6691       ireq=0
6692       do ii=1,ntask_cont_from
6693         iproc=itask_cont_from(ii)
6694         nn=ncont_recv(ii)
6695 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6696 !     &   " of CONT_TO_COMM group"
6697         call flush(iout)
6698         if (nn.gt.0) then
6699           ireq=ireq+1
6700           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6701           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6702 !          write (iout,*) "ireq,req",ireq,req(ireq)
6703         endif
6704       enddo
6705 ! Send the contacts to processors that need them
6706       do ii=1,ntask_cont_to
6707         iproc=itask_cont_to(ii)
6708         nn=ncont_sent(ii)
6709 !        write (iout,*) nn," contacts to processor",iproc,
6710 !     &   " of CONT_TO_COMM group"
6711         if (nn.gt.0) then
6712           ireq=ireq+1
6713           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6714             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6715 !          write (iout,*) "ireq,req",ireq,req(ireq)
6716 !          do i=1,nn
6717 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6718 !          enddo
6719         endif
6720       enddo
6721 !      write (iout,*) "number of requests (contacts)",ireq
6722 !      write (iout,*) "req",(req(i),i=1,4)
6723 !      call flush(iout)
6724       if (ireq.gt.0) &
6725        call MPI_Waitall(ireq,req,status_array,ierr)
6726       do iii=1,ntask_cont_from
6727         iproc=itask_cont_from(iii)
6728         nn=ncont_recv(iii)
6729         if (lprn) then
6730         write (iout,*) "Received",nn," contacts from processor",iproc,&
6731          " of CONT_FROM_COMM group"
6732         call flush(iout)
6733         do i=1,nn
6734           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6735         enddo
6736         call flush(iout)
6737         endif
6738         do i=1,nn
6739           ii=zapas_recv(1,i,iii)
6740 ! Flag the received contacts to prevent double-counting
6741           jj=-zapas_recv(2,i,iii)
6742 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6743 !          call flush(iout)
6744           nnn=num_cont_hb(ii)+1
6745           num_cont_hb(ii)=nnn
6746           jcont_hb(nnn,ii)=jj
6747           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6748           ind=3
6749           do kk=1,3
6750             ind=ind+1
6751             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6752           enddo
6753           do kk=1,2
6754             do ll=1,2
6755               ind=ind+1
6756               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6757             enddo
6758           enddo
6759           do jj=1,5
6760             do kk=1,3
6761               do ll=1,2
6762                 do mm=1,2
6763                   ind=ind+1
6764                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6765                 enddo
6766               enddo
6767             enddo
6768           enddo
6769         enddo
6770       enddo
6771       call flush(iout)
6772       if (lprn) then
6773         write (iout,'(a)') 'Contact function values after receive:'
6774         do i=nnt,nct-2
6775           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6776           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6777           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6778         enddo
6779         call flush(iout)
6780       endif
6781    30 continue
6782 #endif
6783       if (lprn) then
6784         write (iout,'(a)') 'Contact function values:'
6785         do i=nnt,nct-2
6786           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6787           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6788           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6789         enddo
6790       endif
6791       ecorr=0.0D0
6792       ecorr5=0.0d0
6793       ecorr6=0.0d0
6794
6795 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6796 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6797 ! Remove the loop below after debugging !!!
6798       do i=nnt,nct
6799         do j=1,3
6800           gradcorr(j,i)=0.0D0
6801           gradxorr(j,i)=0.0D0
6802         enddo
6803       enddo
6804 ! Calculate the dipole-dipole interaction energies
6805       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6806       do i=iatel_s,iatel_e+1
6807         num_conti=num_cont_hb(i)
6808         do jj=1,num_conti
6809           j=jcont_hb(jj,i)
6810 #ifdef MOMENT
6811           call dipole(i,j,jj)
6812 #endif
6813         enddo
6814       enddo
6815       endif
6816 ! Calculate the local-electrostatic correlation terms
6817 !                write (iout,*) "gradcorr5 in eello5 before loop"
6818 !                do iii=1,nres
6819 !                  write (iout,'(i5,3f10.5)')
6820 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6821 !                enddo
6822       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6823 !        write (iout,*) "corr loop i",i
6824         i1=i+1
6825         num_conti=num_cont_hb(i)
6826         num_conti1=num_cont_hb(i+1)
6827         do jj=1,num_conti
6828           j=jcont_hb(jj,i)
6829           jp=iabs(j)
6830           do kk=1,num_conti1
6831             j1=jcont_hb(kk,i1)
6832             jp1=iabs(j1)
6833 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6834 !     &         ' jj=',jj,' kk=',kk
6835 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6836             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6837                 .or. j.lt.0 .and. j1.gt.0) .and. &
6838                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6839 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6840 ! The system gains extra energy.
6841               n_corr=n_corr+1
6842               sqd1=dsqrt(d_cont(jj,i))
6843               sqd2=dsqrt(d_cont(kk,i1))
6844               sred_geom = sqd1*sqd2
6845               IF (sred_geom.lt.cutoff_corr) THEN
6846                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6847                   ekont,fprimcont)
6848 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6849 !d     &         ' jj=',jj,' kk=',kk
6850                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6851                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6852                 do l=1,3
6853                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6854                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6855                 enddo
6856                 n_corr1=n_corr1+1
6857 !d               write (iout,*) 'sred_geom=',sred_geom,
6858 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6859 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6860 !d               write (iout,*) "g_contij",g_contij
6861 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6862 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6863                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6864                 if (wcorr4.gt.0.0d0) &
6865                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6866                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6867                        write (iout,'(a6,4i5,0pf7.3)') &
6868                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6869 !                write (iout,*) "gradcorr5 before eello5"
6870 !                do iii=1,nres
6871 !                  write (iout,'(i5,3f10.5)')
6872 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6873 !                enddo
6874                 if (wcorr5.gt.0.0d0) &
6875                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6876 !                write (iout,*) "gradcorr5 after eello5"
6877 !                do iii=1,nres
6878 !                  write (iout,'(i5,3f10.5)')
6879 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6880 !                enddo
6881                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6882                        write (iout,'(a6,4i5,0pf7.3)') &
6883                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6884 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6885 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6886                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6887                      .or. wturn6.eq.0.0d0))then
6888 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6889                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6890                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6891                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6892 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6893 !d     &            'ecorr6=',ecorr6
6894 !d                write (iout,'(4e15.5)') sred_geom,
6895 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6896 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6897 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6898                 else if (wturn6.gt.0.0d0 &
6899                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6900 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6901                   eturn6=eturn6+eello_turn6(i,jj,kk)
6902                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6903                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6904 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6905                 endif
6906               ENDIF
6907 1111          continue
6908             endif
6909           enddo ! kk
6910         enddo ! jj
6911       enddo ! i
6912       do i=1,nres
6913         num_cont_hb(i)=num_cont_hb_old(i)
6914       enddo
6915 !                write (iout,*) "gradcorr5 in eello5"
6916 !                do iii=1,nres
6917 !                  write (iout,'(i5,3f10.5)')
6918 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6919 !                enddo
6920       return
6921       end subroutine multibody_eello
6922 !-----------------------------------------------------------------------------
6923       subroutine add_hb_contact_eello(ii,jj,itask)
6924 !      implicit real*8 (a-h,o-z)
6925 !      include "DIMENSIONS"
6926 !      include "COMMON.IOUNITS"
6927 !      include "COMMON.CONTACTS"
6928 !      integer,parameter :: maxconts=nres/4
6929       integer,parameter :: max_dim=70
6930       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6931 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6932 !      common /przechowalnia/ zapas
6933
6934       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6935       integer,dimension(4) ::itask
6936 !      write (iout,*) "itask",itask
6937       do i=1,2
6938         iproc=itask(i)
6939         if (iproc.gt.0) then
6940           do j=1,num_cont_hb(ii)
6941             jjc=jcont_hb(j,ii)
6942 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6943             if (jjc.eq.jj) then
6944               ncont_sent(iproc)=ncont_sent(iproc)+1
6945               nn=ncont_sent(iproc)
6946               zapas(1,nn,iproc)=ii
6947               zapas(2,nn,iproc)=jjc
6948               zapas(3,nn,iproc)=d_cont(j,ii)
6949               ind=3
6950               do kk=1,3
6951                 ind=ind+1
6952                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6953               enddo
6954               do kk=1,2
6955                 do ll=1,2
6956                   ind=ind+1
6957                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6958                 enddo
6959               enddo
6960               do jj=1,5
6961                 do kk=1,3
6962                   do ll=1,2
6963                     do mm=1,2
6964                       ind=ind+1
6965                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6966                     enddo
6967                   enddo
6968                 enddo
6969               enddo
6970               exit
6971             endif
6972           enddo
6973         endif
6974       enddo
6975       return
6976       end subroutine add_hb_contact_eello
6977 !-----------------------------------------------------------------------------
6978       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6979 !      implicit real*8 (a-h,o-z)
6980 !      include 'DIMENSIONS'
6981 !      include 'COMMON.IOUNITS'
6982 !      include 'COMMON.DERIV'
6983 !      include 'COMMON.INTERACT'
6984 !      include 'COMMON.CONTACTS'
6985       real(kind=8),dimension(3) :: gx,gx1
6986       logical :: lprn
6987 !el local variables
6988       integer :: i,j,k,l,jj,kk,ll
6989       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6990                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6991                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6992
6993       lprn=.false.
6994       eij=facont_hb(jj,i)
6995       ekl=facont_hb(kk,k)
6996       ees0pij=ees0p(jj,i)
6997       ees0pkl=ees0p(kk,k)
6998       ees0mij=ees0m(jj,i)
6999       ees0mkl=ees0m(kk,k)
7000       ekont=eij*ekl
7001       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7002 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7003 ! Following 4 lines for diagnostics.
7004 !d    ees0pkl=0.0D0
7005 !d    ees0pij=1.0D0
7006 !d    ees0mkl=0.0D0
7007 !d    ees0mij=1.0D0
7008 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7009 !     & 'Contacts ',i,j,
7010 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7011 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7012 !     & 'gradcorr_long'
7013 ! Calculate the multi-body contribution to energy.
7014 !      ecorr=ecorr+ekont*ees
7015 ! Calculate multi-body contributions to the gradient.
7016       coeffpees0pij=coeffp*ees0pij
7017       coeffmees0mij=coeffm*ees0mij
7018       coeffpees0pkl=coeffp*ees0pkl
7019       coeffmees0mkl=coeffm*ees0mkl
7020       do ll=1,3
7021 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7022         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7023         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7024         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7025         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7026         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7027         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7028 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7029         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7030         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7031         coeffmees0mij*gacontm_hb1(ll,kk,k))
7032         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7033         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7034         coeffmees0mij*gacontm_hb2(ll,kk,k))
7035         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7036            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7037            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7038         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7039         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7040         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7041            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7042            coeffmees0mij*gacontm_hb3(ll,kk,k))
7043         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7044         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7045 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7046       enddo
7047 !      write (iout,*)
7048 !grad      do m=i+1,j-1
7049 !grad        do ll=1,3
7050 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7051 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7052 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7053 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7054 !grad        enddo
7055 !grad      enddo
7056 !grad      do m=k+1,l-1
7057 !grad        do ll=1,3
7058 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7059 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7060 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7061 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7062 !grad        enddo
7063 !grad      enddo
7064 !      write (iout,*) "ehbcorr",ekont*ees
7065       ehbcorr=ekont*ees
7066       return
7067       end function ehbcorr
7068 #ifdef MOMENT
7069 !-----------------------------------------------------------------------------
7070       subroutine dipole(i,j,jj)
7071 !      implicit real*8 (a-h,o-z)
7072 !      include 'DIMENSIONS'
7073 !      include 'COMMON.IOUNITS'
7074 !      include 'COMMON.CHAIN'
7075 !      include 'COMMON.FFIELD'
7076 !      include 'COMMON.DERIV'
7077 !      include 'COMMON.INTERACT'
7078 !      include 'COMMON.CONTACTS'
7079 !      include 'COMMON.TORSION'
7080 !      include 'COMMON.VAR'
7081 !      include 'COMMON.GEO'
7082       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7083       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7084       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7085
7086       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7087       allocate(dipderx(3,5,4,maxconts,nres))
7088 !
7089
7090       iti1 = itortyp(itype(i+1))
7091       if (j.lt.nres-1) then
7092         itj1 = itortyp(itype(j+1))
7093       else
7094         itj1=ntortyp+1
7095       endif
7096       do iii=1,2
7097         dipi(iii,1)=Ub2(iii,i)
7098         dipderi(iii)=Ub2der(iii,i)
7099         dipi(iii,2)=b1(iii,iti1)
7100         dipj(iii,1)=Ub2(iii,j)
7101         dipderj(iii)=Ub2der(iii,j)
7102         dipj(iii,2)=b1(iii,itj1)
7103       enddo
7104       kkk=0
7105       do iii=1,2
7106         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7107         do jjj=1,2
7108           kkk=kkk+1
7109           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7110         enddo
7111       enddo
7112       do kkk=1,5
7113         do lll=1,3
7114           mmm=0
7115           do iii=1,2
7116             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7117               auxvec(1))
7118             do jjj=1,2
7119               mmm=mmm+1
7120               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7121             enddo
7122           enddo
7123         enddo
7124       enddo
7125       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7126       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7127       do iii=1,2
7128         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7129       enddo
7130       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7131       do iii=1,2
7132         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7133       enddo
7134       return
7135       end subroutine dipole
7136 #endif
7137 !-----------------------------------------------------------------------------
7138       subroutine calc_eello(i,j,k,l,jj,kk)
7139 !
7140 ! This subroutine computes matrices and vectors needed to calculate
7141 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7142 !
7143       use comm_kut
7144 !      implicit real*8 (a-h,o-z)
7145 !      include 'DIMENSIONS'
7146 !      include 'COMMON.IOUNITS'
7147 !      include 'COMMON.CHAIN'
7148 !      include 'COMMON.DERIV'
7149 !      include 'COMMON.INTERACT'
7150 !      include 'COMMON.CONTACTS'
7151 !      include 'COMMON.TORSION'
7152 !      include 'COMMON.VAR'
7153 !      include 'COMMON.GEO'
7154 !      include 'COMMON.FFIELD'
7155       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7156       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7157       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7158               itj1
7159 !el      logical :: lprn
7160 !el      common /kutas/ lprn
7161 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7162 !d     & ' jj=',jj,' kk=',kk
7163 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7164 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7165 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7166       do iii=1,2
7167         do jjj=1,2
7168           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7169           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7170         enddo
7171       enddo
7172       call transpose2(aa1(1,1),aa1t(1,1))
7173       call transpose2(aa2(1,1),aa2t(1,1))
7174       do kkk=1,5
7175         do lll=1,3
7176           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7177             aa1tder(1,1,lll,kkk))
7178           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7179             aa2tder(1,1,lll,kkk))
7180         enddo
7181       enddo
7182       if (l.eq.j+1) then
7183 ! parallel orientation of the two CA-CA-CA frames.
7184         if (i.gt.1) then
7185           iti=itortyp(itype(i))
7186         else
7187           iti=ntortyp+1
7188         endif
7189         itk1=itortyp(itype(k+1))
7190         itj=itortyp(itype(j))
7191         if (l.lt.nres-1) then
7192           itl1=itortyp(itype(l+1))
7193         else
7194           itl1=ntortyp+1
7195         endif
7196 ! A1 kernel(j+1) A2T
7197 !d        do iii=1,2
7198 !d          write (iout,'(3f10.5,5x,3f10.5)')
7199 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7200 !d        enddo
7201         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7202          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7203          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7204 ! Following matrices are needed only for 6-th order cumulants
7205         IF (wcorr6.gt.0.0d0) THEN
7206         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7207          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7208          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7209         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7210          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7211          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7212          ADtEAderx(1,1,1,1,1,1))
7213         lprn=.false.
7214         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7215          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7216          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7217          ADtEA1derx(1,1,1,1,1,1))
7218         ENDIF
7219 ! End 6-th order cumulants
7220 !d        lprn=.false.
7221 !d        if (lprn) then
7222 !d        write (2,*) 'In calc_eello6'
7223 !d        do iii=1,2
7224 !d          write (2,*) 'iii=',iii
7225 !d          do kkk=1,5
7226 !d            write (2,*) 'kkk=',kkk
7227 !d            do jjj=1,2
7228 !d              write (2,'(3(2f10.5),5x)')
7229 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7230 !d            enddo
7231 !d          enddo
7232 !d        enddo
7233 !d        endif
7234         call transpose2(EUgder(1,1,k),auxmat(1,1))
7235         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7236         call transpose2(EUg(1,1,k),auxmat(1,1))
7237         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7238         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7239         do iii=1,2
7240           do kkk=1,5
7241             do lll=1,3
7242               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7243                 EAEAderx(1,1,lll,kkk,iii,1))
7244             enddo
7245           enddo
7246         enddo
7247 ! A1T kernel(i+1) A2
7248         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7249          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7250          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7251 ! Following matrices are needed only for 6-th order cumulants
7252         IF (wcorr6.gt.0.0d0) THEN
7253         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7254          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7255          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7256         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7257          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7258          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7259          ADtEAderx(1,1,1,1,1,2))
7260         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7261          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7262          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7263          ADtEA1derx(1,1,1,1,1,2))
7264         ENDIF
7265 ! End 6-th order cumulants
7266         call transpose2(EUgder(1,1,l),auxmat(1,1))
7267         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7268         call transpose2(EUg(1,1,l),auxmat(1,1))
7269         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7270         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7271         do iii=1,2
7272           do kkk=1,5
7273             do lll=1,3
7274               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7275                 EAEAderx(1,1,lll,kkk,iii,2))
7276             enddo
7277           enddo
7278         enddo
7279 ! AEAb1 and AEAb2
7280 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7281 ! They are needed only when the fifth- or the sixth-order cumulants are
7282 ! indluded.
7283         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7284         call transpose2(AEA(1,1,1),auxmat(1,1))
7285         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7286         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7287         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7288         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7289         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7290         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7291         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7292         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7293         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7294         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7295         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7296         call transpose2(AEA(1,1,2),auxmat(1,1))
7297         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7298         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7299         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7300         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7301         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7302         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7303         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7304         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7305         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7306         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7307         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7308 ! Calculate the Cartesian derivatives of the vectors.
7309         do iii=1,2
7310           do kkk=1,5
7311             do lll=1,3
7312               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7313               call matvec2(auxmat(1,1),b1(1,iti),&
7314                 AEAb1derx(1,lll,kkk,iii,1,1))
7315               call matvec2(auxmat(1,1),Ub2(1,i),&
7316                 AEAb2derx(1,lll,kkk,iii,1,1))
7317               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7318                 AEAb1derx(1,lll,kkk,iii,2,1))
7319               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7320                 AEAb2derx(1,lll,kkk,iii,2,1))
7321               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7322               call matvec2(auxmat(1,1),b1(1,itj),&
7323                 AEAb1derx(1,lll,kkk,iii,1,2))
7324               call matvec2(auxmat(1,1),Ub2(1,j),&
7325                 AEAb2derx(1,lll,kkk,iii,1,2))
7326               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7327                 AEAb1derx(1,lll,kkk,iii,2,2))
7328               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7329                 AEAb2derx(1,lll,kkk,iii,2,2))
7330             enddo
7331           enddo
7332         enddo
7333         ENDIF
7334 ! End vectors
7335       else
7336 ! Antiparallel orientation of the two CA-CA-CA frames.
7337         if (i.gt.1) then
7338           iti=itortyp(itype(i))
7339         else
7340           iti=ntortyp+1
7341         endif
7342         itk1=itortyp(itype(k+1))
7343         itl=itortyp(itype(l))
7344         itj=itortyp(itype(j))
7345         if (j.lt.nres-1) then
7346           itj1=itortyp(itype(j+1))
7347         else
7348           itj1=ntortyp+1
7349         endif
7350 ! A2 kernel(j-1)T A1T
7351         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7352          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7353          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7354 ! Following matrices are needed only for 6-th order cumulants
7355         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7356            j.eq.i+4 .and. l.eq.i+3)) THEN
7357         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7358          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7359          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7360         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7361          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7362          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7363          ADtEAderx(1,1,1,1,1,1))
7364         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7365          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7366          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7367          ADtEA1derx(1,1,1,1,1,1))
7368         ENDIF
7369 ! End 6-th order cumulants
7370         call transpose2(EUgder(1,1,k),auxmat(1,1))
7371         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7372         call transpose2(EUg(1,1,k),auxmat(1,1))
7373         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7374         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7375         do iii=1,2
7376           do kkk=1,5
7377             do lll=1,3
7378               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7379                 EAEAderx(1,1,lll,kkk,iii,1))
7380             enddo
7381           enddo
7382         enddo
7383 ! A2T kernel(i+1)T A1
7384         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7385          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7386          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7387 ! Following matrices are needed only for 6-th order cumulants
7388         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7389            j.eq.i+4 .and. l.eq.i+3)) THEN
7390         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7391          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7392          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7393         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7394          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7395          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7396          ADtEAderx(1,1,1,1,1,2))
7397         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7398          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7399          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7400          ADtEA1derx(1,1,1,1,1,2))
7401         ENDIF
7402 ! End 6-th order cumulants
7403         call transpose2(EUgder(1,1,j),auxmat(1,1))
7404         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7405         call transpose2(EUg(1,1,j),auxmat(1,1))
7406         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7407         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7408         do iii=1,2
7409           do kkk=1,5
7410             do lll=1,3
7411               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7412                 EAEAderx(1,1,lll,kkk,iii,2))
7413             enddo
7414           enddo
7415         enddo
7416 ! AEAb1 and AEAb2
7417 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7418 ! They are needed only when the fifth- or the sixth-order cumulants are
7419 ! indluded.
7420         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7421           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7422         call transpose2(AEA(1,1,1),auxmat(1,1))
7423         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7424         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7425         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7426         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7427         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7428         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7429         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7430         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7431         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7432         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7433         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7434         call transpose2(AEA(1,1,2),auxmat(1,1))
7435         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7436         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7437         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7438         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7439         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7440         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7441         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7442         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7443         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7444         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7445         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7446 ! Calculate the Cartesian derivatives of the vectors.
7447         do iii=1,2
7448           do kkk=1,5
7449             do lll=1,3
7450               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7451               call matvec2(auxmat(1,1),b1(1,iti),&
7452                 AEAb1derx(1,lll,kkk,iii,1,1))
7453               call matvec2(auxmat(1,1),Ub2(1,i),&
7454                 AEAb2derx(1,lll,kkk,iii,1,1))
7455               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7456                 AEAb1derx(1,lll,kkk,iii,2,1))
7457               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7458                 AEAb2derx(1,lll,kkk,iii,2,1))
7459               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7460               call matvec2(auxmat(1,1),b1(1,itl),&
7461                 AEAb1derx(1,lll,kkk,iii,1,2))
7462               call matvec2(auxmat(1,1),Ub2(1,l),&
7463                 AEAb2derx(1,lll,kkk,iii,1,2))
7464               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7465                 AEAb1derx(1,lll,kkk,iii,2,2))
7466               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7467                 AEAb2derx(1,lll,kkk,iii,2,2))
7468             enddo
7469           enddo
7470         enddo
7471         ENDIF
7472 ! End vectors
7473       endif
7474       return
7475       end subroutine calc_eello
7476 !-----------------------------------------------------------------------------
7477       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7478       use comm_kut
7479       implicit none
7480       integer :: nderg
7481       logical :: transp
7482       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7483       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7484       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7485       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7486       integer :: iii,kkk,lll
7487       integer :: jjj,mmm
7488 !el      logical :: lprn
7489 !el      common /kutas/ lprn
7490       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7491       do iii=1,nderg
7492         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7493           AKAderg(1,1,iii))
7494       enddo
7495 !d      if (lprn) write (2,*) 'In kernel'
7496       do kkk=1,5
7497 !d        if (lprn) write (2,*) 'kkk=',kkk
7498         do lll=1,3
7499           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7500             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7501 !d          if (lprn) then
7502 !d            write (2,*) 'lll=',lll
7503 !d            write (2,*) 'iii=1'
7504 !d            do jjj=1,2
7505 !d              write (2,'(3(2f10.5),5x)')
7506 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7507 !d            enddo
7508 !d          endif
7509           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7510             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7511 !d          if (lprn) then
7512 !d            write (2,*) 'lll=',lll
7513 !d            write (2,*) 'iii=2'
7514 !d            do jjj=1,2
7515 !d              write (2,'(3(2f10.5),5x)')
7516 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7517 !d            enddo
7518 !d          endif
7519         enddo
7520       enddo
7521       return
7522       end subroutine kernel
7523 !-----------------------------------------------------------------------------
7524       real(kind=8) function eello4(i,j,k,l,jj,kk)
7525 !      implicit real*8 (a-h,o-z)
7526 !      include 'DIMENSIONS'
7527 !      include 'COMMON.IOUNITS'
7528 !      include 'COMMON.CHAIN'
7529 !      include 'COMMON.DERIV'
7530 !      include 'COMMON.INTERACT'
7531 !      include 'COMMON.CONTACTS'
7532 !      include 'COMMON.TORSION'
7533 !      include 'COMMON.VAR'
7534 !      include 'COMMON.GEO'
7535       real(kind=8),dimension(2,2) :: pizda
7536       real(kind=8),dimension(3) :: ggg1,ggg2
7537       real(kind=8) ::  eel4,glongij,glongkl
7538       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7539 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7540 !d        eello4=0.0d0
7541 !d        return
7542 !d      endif
7543 !d      print *,'eello4:',i,j,k,l,jj,kk
7544 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7545 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7546 !old      eij=facont_hb(jj,i)
7547 !old      ekl=facont_hb(kk,k)
7548 !old      ekont=eij*ekl
7549       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7550 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7551       gcorr_loc(k-1)=gcorr_loc(k-1) &
7552          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7553       if (l.eq.j+1) then
7554         gcorr_loc(l-1)=gcorr_loc(l-1) &
7555            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7556       else
7557         gcorr_loc(j-1)=gcorr_loc(j-1) &
7558            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7559       endif
7560       do iii=1,2
7561         do kkk=1,5
7562           do lll=1,3
7563             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7564                               -EAEAderx(2,2,lll,kkk,iii,1)
7565 !d            derx(lll,kkk,iii)=0.0d0
7566           enddo
7567         enddo
7568       enddo
7569 !d      gcorr_loc(l-1)=0.0d0
7570 !d      gcorr_loc(j-1)=0.0d0
7571 !d      gcorr_loc(k-1)=0.0d0
7572 !d      eel4=1.0d0
7573 !d      write (iout,*)'Contacts have occurred for peptide groups',
7574 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7575 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7576       if (j.lt.nres-1) then
7577         j1=j+1
7578         j2=j-1
7579       else
7580         j1=j-1
7581         j2=j-2
7582       endif
7583       if (l.lt.nres-1) then
7584         l1=l+1
7585         l2=l-1
7586       else
7587         l1=l-1
7588         l2=l-2
7589       endif
7590       do ll=1,3
7591 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7592 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7593         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7594         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7595 !grad        ghalf=0.5d0*ggg1(ll)
7596         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7597         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7598         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7599         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7600         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7601         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7602 !grad        ghalf=0.5d0*ggg2(ll)
7603         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7604         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7605         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7606         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7607         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7608         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7609       enddo
7610 !grad      do m=i+1,j-1
7611 !grad        do ll=1,3
7612 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7613 !grad        enddo
7614 !grad      enddo
7615 !grad      do m=k+1,l-1
7616 !grad        do ll=1,3
7617 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7618 !grad        enddo
7619 !grad      enddo
7620 !grad      do m=i+2,j2
7621 !grad        do ll=1,3
7622 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7623 !grad        enddo
7624 !grad      enddo
7625 !grad      do m=k+2,l2
7626 !grad        do ll=1,3
7627 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7628 !grad        enddo
7629 !grad      enddo
7630 !d      do iii=1,nres-3
7631 !d        write (2,*) iii,gcorr_loc(iii)
7632 !d      enddo
7633       eello4=ekont*eel4
7634 !d      write (2,*) 'ekont',ekont
7635 !d      write (iout,*) 'eello4',ekont*eel4
7636       return
7637       end function eello4
7638 !-----------------------------------------------------------------------------
7639       real(kind=8) function eello5(i,j,k,l,jj,kk)
7640 !      implicit real*8 (a-h,o-z)
7641 !      include 'DIMENSIONS'
7642 !      include 'COMMON.IOUNITS'
7643 !      include 'COMMON.CHAIN'
7644 !      include 'COMMON.DERIV'
7645 !      include 'COMMON.INTERACT'
7646 !      include 'COMMON.CONTACTS'
7647 !      include 'COMMON.TORSION'
7648 !      include 'COMMON.VAR'
7649 !      include 'COMMON.GEO'
7650       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7651       real(kind=8),dimension(2) :: vv
7652       real(kind=8),dimension(3) :: ggg1,ggg2
7653       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7654       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7655       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7656 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7657 !                                                                              C
7658 !                            Parallel chains                                   C
7659 !                                                                              C
7660 !          o             o                   o             o                   C
7661 !         /l\           / \             \   / \           / \   /              C
7662 !        /   \         /   \             \ /   \         /   \ /               C
7663 !       j| o |l1       | o |              o| o |         | o |o                C
7664 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7665 !      \i/   \         /   \ /             /   \         /   \                 C
7666 !       o    k1             o                                                  C
7667 !         (I)          (II)                (III)          (IV)                 C
7668 !                                                                              C
7669 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7670 !                                                                              C
7671 !                            Antiparallel chains                               C
7672 !                                                                              C
7673 !          o             o                   o             o                   C
7674 !         /j\           / \             \   / \           / \   /              C
7675 !        /   \         /   \             \ /   \         /   \ /               C
7676 !      j1| o |l        | o |              o| o |         | o |o                C
7677 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7678 !      \i/   \         /   \ /             /   \         /   \                 C
7679 !       o     k1            o                                                  C
7680 !         (I)          (II)                (III)          (IV)                 C
7681 !                                                                              C
7682 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7683 !                                                                              C
7684 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7685 !                                                                              C
7686 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7687 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7688 !d        eello5=0.0d0
7689 !d        return
7690 !d      endif
7691 !d      write (iout,*)
7692 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7693 !d     &   ' and',k,l
7694       itk=itortyp(itype(k))
7695       itl=itortyp(itype(l))
7696       itj=itortyp(itype(j))
7697       eello5_1=0.0d0
7698       eello5_2=0.0d0
7699       eello5_3=0.0d0
7700       eello5_4=0.0d0
7701 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7702 !d     &   eel5_3_num,eel5_4_num)
7703       do iii=1,2
7704         do kkk=1,5
7705           do lll=1,3
7706             derx(lll,kkk,iii)=0.0d0
7707           enddo
7708         enddo
7709       enddo
7710 !d      eij=facont_hb(jj,i)
7711 !d      ekl=facont_hb(kk,k)
7712 !d      ekont=eij*ekl
7713 !d      write (iout,*)'Contacts have occurred for peptide groups',
7714 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7715 !d      goto 1111
7716 ! Contribution from the graph I.
7717 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7718 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7719       call transpose2(EUg(1,1,k),auxmat(1,1))
7720       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7721       vv(1)=pizda(1,1)-pizda(2,2)
7722       vv(2)=pizda(1,2)+pizda(2,1)
7723       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7724        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7725 ! Explicit gradient in virtual-dihedral angles.
7726       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7727        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7728        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7729       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7730       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7731       vv(1)=pizda(1,1)-pizda(2,2)
7732       vv(2)=pizda(1,2)+pizda(2,1)
7733       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7734        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7735        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7736       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7737       vv(1)=pizda(1,1)-pizda(2,2)
7738       vv(2)=pizda(1,2)+pizda(2,1)
7739       if (l.eq.j+1) then
7740         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7741          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7742          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7743       else
7744         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7745          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7746          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7747       endif
7748 ! Cartesian gradient
7749       do iii=1,2
7750         do kkk=1,5
7751           do lll=1,3
7752             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7753               pizda(1,1))
7754             vv(1)=pizda(1,1)-pizda(2,2)
7755             vv(2)=pizda(1,2)+pizda(2,1)
7756             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7757              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7758              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7759           enddo
7760         enddo
7761       enddo
7762 !      goto 1112
7763 !1111  continue
7764 ! Contribution from graph II
7765       call transpose2(EE(1,1,itk),auxmat(1,1))
7766       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7767       vv(1)=pizda(1,1)+pizda(2,2)
7768       vv(2)=pizda(2,1)-pizda(1,2)
7769       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7770        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7771 ! Explicit gradient in virtual-dihedral angles.
7772       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7773        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7774       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7775       vv(1)=pizda(1,1)+pizda(2,2)
7776       vv(2)=pizda(2,1)-pizda(1,2)
7777       if (l.eq.j+1) then
7778         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7779          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7780          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7781       else
7782         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7783          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7784          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7785       endif
7786 ! Cartesian gradient
7787       do iii=1,2
7788         do kkk=1,5
7789           do lll=1,3
7790             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7791               pizda(1,1))
7792             vv(1)=pizda(1,1)+pizda(2,2)
7793             vv(2)=pizda(2,1)-pizda(1,2)
7794             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7795              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7796              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7797           enddo
7798         enddo
7799       enddo
7800 !d      goto 1112
7801 !d1111  continue
7802       if (l.eq.j+1) then
7803 !d        goto 1110
7804 ! Parallel orientation
7805 ! Contribution from graph III
7806         call transpose2(EUg(1,1,l),auxmat(1,1))
7807         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7808         vv(1)=pizda(1,1)-pizda(2,2)
7809         vv(2)=pizda(1,2)+pizda(2,1)
7810         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7811          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7812 ! Explicit gradient in virtual-dihedral angles.
7813         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7814          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7815          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7816         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7817         vv(1)=pizda(1,1)-pizda(2,2)
7818         vv(2)=pizda(1,2)+pizda(2,1)
7819         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7820          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7821          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7822         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7823         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7824         vv(1)=pizda(1,1)-pizda(2,2)
7825         vv(2)=pizda(1,2)+pizda(2,1)
7826         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7827          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7828          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7829 ! Cartesian gradient
7830         do iii=1,2
7831           do kkk=1,5
7832             do lll=1,3
7833               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7834                 pizda(1,1))
7835               vv(1)=pizda(1,1)-pizda(2,2)
7836               vv(2)=pizda(1,2)+pizda(2,1)
7837               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7838                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7839                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7840             enddo
7841           enddo
7842         enddo
7843 !d        goto 1112
7844 ! Contribution from graph IV
7845 !d1110    continue
7846         call transpose2(EE(1,1,itl),auxmat(1,1))
7847         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7848         vv(1)=pizda(1,1)+pizda(2,2)
7849         vv(2)=pizda(2,1)-pizda(1,2)
7850         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7851          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7852 ! Explicit gradient in virtual-dihedral angles.
7853         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7854          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7855         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7856         vv(1)=pizda(1,1)+pizda(2,2)
7857         vv(2)=pizda(2,1)-pizda(1,2)
7858         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7859          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7860          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7861 ! Cartesian gradient
7862         do iii=1,2
7863           do kkk=1,5
7864             do lll=1,3
7865               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7866                 pizda(1,1))
7867               vv(1)=pizda(1,1)+pizda(2,2)
7868               vv(2)=pizda(2,1)-pizda(1,2)
7869               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7870                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7871                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7872             enddo
7873           enddo
7874         enddo
7875       else
7876 ! Antiparallel orientation
7877 ! Contribution from graph III
7878 !        goto 1110
7879         call transpose2(EUg(1,1,j),auxmat(1,1))
7880         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7881         vv(1)=pizda(1,1)-pizda(2,2)
7882         vv(2)=pizda(1,2)+pizda(2,1)
7883         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7884          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7885 ! Explicit gradient in virtual-dihedral angles.
7886         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7887          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7888          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7889         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7890         vv(1)=pizda(1,1)-pizda(2,2)
7891         vv(2)=pizda(1,2)+pizda(2,1)
7892         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7893          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7894          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7895         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7896         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7897         vv(1)=pizda(1,1)-pizda(2,2)
7898         vv(2)=pizda(1,2)+pizda(2,1)
7899         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7900          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7901          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7902 ! Cartesian gradient
7903         do iii=1,2
7904           do kkk=1,5
7905             do lll=1,3
7906               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7907                 pizda(1,1))
7908               vv(1)=pizda(1,1)-pizda(2,2)
7909               vv(2)=pizda(1,2)+pizda(2,1)
7910               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7911                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7912                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7913             enddo
7914           enddo
7915         enddo
7916 !d        goto 1112
7917 ! Contribution from graph IV
7918 1110    continue
7919         call transpose2(EE(1,1,itj),auxmat(1,1))
7920         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7921         vv(1)=pizda(1,1)+pizda(2,2)
7922         vv(2)=pizda(2,1)-pizda(1,2)
7923         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7924          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7925 ! Explicit gradient in virtual-dihedral angles.
7926         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7927          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7928         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7929         vv(1)=pizda(1,1)+pizda(2,2)
7930         vv(2)=pizda(2,1)-pizda(1,2)
7931         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7932          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7933          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7934 ! Cartesian gradient
7935         do iii=1,2
7936           do kkk=1,5
7937             do lll=1,3
7938               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7939                 pizda(1,1))
7940               vv(1)=pizda(1,1)+pizda(2,2)
7941               vv(2)=pizda(2,1)-pizda(1,2)
7942               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7943                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7944                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7945             enddo
7946           enddo
7947         enddo
7948       endif
7949 1112  continue
7950       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7951 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7952 !d        write (2,*) 'ijkl',i,j,k,l
7953 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7954 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7955 !d      endif
7956 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7957 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7958 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7959 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7960       if (j.lt.nres-1) then
7961         j1=j+1
7962         j2=j-1
7963       else
7964         j1=j-1
7965         j2=j-2
7966       endif
7967       if (l.lt.nres-1) then
7968         l1=l+1
7969         l2=l-1
7970       else
7971         l1=l-1
7972         l2=l-2
7973       endif
7974 !d      eij=1.0d0
7975 !d      ekl=1.0d0
7976 !d      ekont=1.0d0
7977 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7978 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7979 !        summed up outside the subrouine as for the other subroutines
7980 !        handling long-range interactions. The old code is commented out
7981 !        with "cgrad" to keep track of changes.
7982       do ll=1,3
7983 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7984 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7985         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7986         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7987 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7988 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7989 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7990 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7991 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7992 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7993 !     &   gradcorr5ij,
7994 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7995 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7996 !grad        ghalf=0.5d0*ggg1(ll)
7997 !d        ghalf=0.0d0
7998         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7999         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8000         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8001         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8002         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8003         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8004 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8005 !grad        ghalf=0.5d0*ggg2(ll)
8006         ghalf=0.0d0
8007         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8008         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8009         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8010         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8011         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8012         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8013       enddo
8014 !d      goto 1112
8015 !grad      do m=i+1,j-1
8016 !grad        do ll=1,3
8017 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8018 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8019 !grad        enddo
8020 !grad      enddo
8021 !grad      do m=k+1,l-1
8022 !grad        do ll=1,3
8023 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8024 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8025 !grad        enddo
8026 !grad      enddo
8027 !1112  continue
8028 !grad      do m=i+2,j2
8029 !grad        do ll=1,3
8030 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8031 !grad        enddo
8032 !grad      enddo
8033 !grad      do m=k+2,l2
8034 !grad        do ll=1,3
8035 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8036 !grad        enddo
8037 !grad      enddo
8038 !d      do iii=1,nres-3
8039 !d        write (2,*) iii,g_corr5_loc(iii)
8040 !d      enddo
8041       eello5=ekont*eel5
8042 !d      write (2,*) 'ekont',ekont
8043 !d      write (iout,*) 'eello5',ekont*eel5
8044       return
8045       end function eello5
8046 !-----------------------------------------------------------------------------
8047       real(kind=8) function eello6(i,j,k,l,jj,kk)
8048 !      implicit real*8 (a-h,o-z)
8049 !      include 'DIMENSIONS'
8050 !      include 'COMMON.IOUNITS'
8051 !      include 'COMMON.CHAIN'
8052 !      include 'COMMON.DERIV'
8053 !      include 'COMMON.INTERACT'
8054 !      include 'COMMON.CONTACTS'
8055 !      include 'COMMON.TORSION'
8056 !      include 'COMMON.VAR'
8057 !      include 'COMMON.GEO'
8058 !      include 'COMMON.FFIELD'
8059       real(kind=8),dimension(3) :: ggg1,ggg2
8060       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8061                    eello6_6,eel6
8062       real(kind=8) :: gradcorr6ij,gradcorr6kl
8063       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8064 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8065 !d        eello6=0.0d0
8066 !d        return
8067 !d      endif
8068 !d      write (iout,*)
8069 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8070 !d     &   ' and',k,l
8071       eello6_1=0.0d0
8072       eello6_2=0.0d0
8073       eello6_3=0.0d0
8074       eello6_4=0.0d0
8075       eello6_5=0.0d0
8076       eello6_6=0.0d0
8077 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8078 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8079       do iii=1,2
8080         do kkk=1,5
8081           do lll=1,3
8082             derx(lll,kkk,iii)=0.0d0
8083           enddo
8084         enddo
8085       enddo
8086 !d      eij=facont_hb(jj,i)
8087 !d      ekl=facont_hb(kk,k)
8088 !d      ekont=eij*ekl
8089 !d      eij=1.0d0
8090 !d      ekl=1.0d0
8091 !d      ekont=1.0d0
8092       if (l.eq.j+1) then
8093         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8094         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8095         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8096         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8097         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8098         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8099       else
8100         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8101         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8102         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8103         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8104         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8105           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8106         else
8107           eello6_5=0.0d0
8108         endif
8109         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8110       endif
8111 ! If turn contributions are considered, they will be handled separately.
8112       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8113 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8114 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8115 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8116 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8117 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8118 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8119 !d      goto 1112
8120       if (j.lt.nres-1) then
8121         j1=j+1
8122         j2=j-1
8123       else
8124         j1=j-1
8125         j2=j-2
8126       endif
8127       if (l.lt.nres-1) then
8128         l1=l+1
8129         l2=l-1
8130       else
8131         l1=l-1
8132         l2=l-2
8133       endif
8134       do ll=1,3
8135 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8136 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8137 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8138 !grad        ghalf=0.5d0*ggg1(ll)
8139 !d        ghalf=0.0d0
8140         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8141         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8142         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8143         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8144         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8145         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8146         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8147         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8148 !grad        ghalf=0.5d0*ggg2(ll)
8149 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8150 !d        ghalf=0.0d0
8151         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8152         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8153         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8154         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8155         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8156         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8157       enddo
8158 !d      goto 1112
8159 !grad      do m=i+1,j-1
8160 !grad        do ll=1,3
8161 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8162 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8163 !grad        enddo
8164 !grad      enddo
8165 !grad      do m=k+1,l-1
8166 !grad        do ll=1,3
8167 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8168 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8169 !grad        enddo
8170 !grad      enddo
8171 !grad1112  continue
8172 !grad      do m=i+2,j2
8173 !grad        do ll=1,3
8174 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8175 !grad        enddo
8176 !grad      enddo
8177 !grad      do m=k+2,l2
8178 !grad        do ll=1,3
8179 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8180 !grad        enddo
8181 !grad      enddo
8182 !d      do iii=1,nres-3
8183 !d        write (2,*) iii,g_corr6_loc(iii)
8184 !d      enddo
8185       eello6=ekont*eel6
8186 !d      write (2,*) 'ekont',ekont
8187 !d      write (iout,*) 'eello6',ekont*eel6
8188       return
8189       end function eello6
8190 !-----------------------------------------------------------------------------
8191       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8192       use comm_kut
8193 !      implicit real*8 (a-h,o-z)
8194 !      include 'DIMENSIONS'
8195 !      include 'COMMON.IOUNITS'
8196 !      include 'COMMON.CHAIN'
8197 !      include 'COMMON.DERIV'
8198 !      include 'COMMON.INTERACT'
8199 !      include 'COMMON.CONTACTS'
8200 !      include 'COMMON.TORSION'
8201 !      include 'COMMON.VAR'
8202 !      include 'COMMON.GEO'
8203       real(kind=8),dimension(2) :: vv,vv1
8204       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8205       logical :: swap
8206 !el      logical :: lprn
8207 !el      common /kutas/ lprn
8208       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8209       real(kind=8) :: s1,s2,s3,s4,s5
8210 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8211 !                                                                              C
8212 !      Parallel       Antiparallel                                             C
8213 !                                                                              C
8214 !          o             o                                                     C
8215 !         /l\           /j\                                                    C
8216 !        /   \         /   \                                                   C
8217 !       /| o |         | o |\                                                  C
8218 !     \ j|/k\|  /   \  |/k\|l /                                                C
8219 !      \ /   \ /     \ /   \ /                                                 C
8220 !       o     o       o     o                                                  C
8221 !       i             i                                                        C
8222 !                                                                              C
8223 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8224       itk=itortyp(itype(k))
8225       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8226       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8227       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8228       call transpose2(EUgC(1,1,k),auxmat(1,1))
8229       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8230       vv1(1)=pizda1(1,1)-pizda1(2,2)
8231       vv1(2)=pizda1(1,2)+pizda1(2,1)
8232       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8233       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8234       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8235       s5=scalar2(vv(1),Dtobr2(1,i))
8236 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8237       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8238       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8239        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8240        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8241        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8242        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8243        +scalar2(vv(1),Dtobr2der(1,i)))
8244       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8245       vv1(1)=pizda1(1,1)-pizda1(2,2)
8246       vv1(2)=pizda1(1,2)+pizda1(2,1)
8247       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8248       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8249       if (l.eq.j+1) then
8250         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8251        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8252        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8253        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8254        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8255       else
8256         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8257        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8258        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8259        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8260        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8261       endif
8262       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8263       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8264       vv1(1)=pizda1(1,1)-pizda1(2,2)
8265       vv1(2)=pizda1(1,2)+pizda1(2,1)
8266       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8267        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8268        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8269        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8270       do iii=1,2
8271         if (swap) then
8272           ind=3-iii
8273         else
8274           ind=iii
8275         endif
8276         do kkk=1,5
8277           do lll=1,3
8278             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8279             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8280             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8281             call transpose2(EUgC(1,1,k),auxmat(1,1))
8282             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8283               pizda1(1,1))
8284             vv1(1)=pizda1(1,1)-pizda1(2,2)
8285             vv1(2)=pizda1(1,2)+pizda1(2,1)
8286             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8287             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8288              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8289             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8290              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8291             s5=scalar2(vv(1),Dtobr2(1,i))
8292             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8293           enddo
8294         enddo
8295       enddo
8296       return
8297       end function eello6_graph1
8298 !-----------------------------------------------------------------------------
8299       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8300       use comm_kut
8301 !      implicit real*8 (a-h,o-z)
8302 !      include 'DIMENSIONS'
8303 !      include 'COMMON.IOUNITS'
8304 !      include 'COMMON.CHAIN'
8305 !      include 'COMMON.DERIV'
8306 !      include 'COMMON.INTERACT'
8307 !      include 'COMMON.CONTACTS'
8308 !      include 'COMMON.TORSION'
8309 !      include 'COMMON.VAR'
8310 !      include 'COMMON.GEO'
8311       logical :: swap
8312       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8313       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8314 !el      logical :: lprn
8315 !el      common /kutas/ lprn
8316       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8317       real(kind=8) :: s2,s3,s4
8318 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8319 !                                                                              C
8320 !      Parallel       Antiparallel                                             C
8321 !                                                                              C
8322 !          o             o                                                     C
8323 !     \   /l\           /j\   /                                                C
8324 !      \ /   \         /   \ /                                                 C
8325 !       o| o |         | o |o                                                  C
8326 !     \ j|/k\|      \  |/k\|l                                                  C
8327 !      \ /   \       \ /   \                                                   C
8328 !       o             o                                                        C
8329 !       i             i                                                        C
8330 !                                                                              C
8331 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8332 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8333 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8334 !           but not in a cluster cumulant
8335 #ifdef MOMENT
8336       s1=dip(1,jj,i)*dip(1,kk,k)
8337 #endif
8338       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8339       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8340       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8341       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8342       call transpose2(EUg(1,1,k),auxmat(1,1))
8343       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8344       vv(1)=pizda(1,1)-pizda(2,2)
8345       vv(2)=pizda(1,2)+pizda(2,1)
8346       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8347 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8348 #ifdef MOMENT
8349       eello6_graph2=-(s1+s2+s3+s4)
8350 #else
8351       eello6_graph2=-(s2+s3+s4)
8352 #endif
8353 !      eello6_graph2=-s3
8354 ! Derivatives in gamma(i-1)
8355       if (i.gt.1) then
8356 #ifdef MOMENT
8357         s1=dipderg(1,jj,i)*dip(1,kk,k)
8358 #endif
8359         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8360         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8361         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8362         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8363 #ifdef MOMENT
8364         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8365 #else
8366         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8367 #endif
8368 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8369       endif
8370 ! Derivatives in gamma(k-1)
8371 #ifdef MOMENT
8372       s1=dip(1,jj,i)*dipderg(1,kk,k)
8373 #endif
8374       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8375       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8376       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8377       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8378       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8379       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8380       vv(1)=pizda(1,1)-pizda(2,2)
8381       vv(2)=pizda(1,2)+pizda(2,1)
8382       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8383 #ifdef MOMENT
8384       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8385 #else
8386       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8387 #endif
8388 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8389 ! Derivatives in gamma(j-1) or gamma(l-1)
8390       if (j.gt.1) then
8391 #ifdef MOMENT
8392         s1=dipderg(3,jj,i)*dip(1,kk,k)
8393 #endif
8394         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8395         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8396         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8397         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8398         vv(1)=pizda(1,1)-pizda(2,2)
8399         vv(2)=pizda(1,2)+pizda(2,1)
8400         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8401 #ifdef MOMENT
8402         if (swap) then
8403           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8404         else
8405           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8406         endif
8407 #endif
8408         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8409 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8410       endif
8411 ! Derivatives in gamma(l-1) or gamma(j-1)
8412       if (l.gt.1) then
8413 #ifdef MOMENT
8414         s1=dip(1,jj,i)*dipderg(3,kk,k)
8415 #endif
8416         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8417         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8418         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8419         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8420         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8421         vv(1)=pizda(1,1)-pizda(2,2)
8422         vv(2)=pizda(1,2)+pizda(2,1)
8423         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8424 #ifdef MOMENT
8425         if (swap) then
8426           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8427         else
8428           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8429         endif
8430 #endif
8431         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8432 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8433       endif
8434 ! Cartesian derivatives.
8435       if (lprn) then
8436         write (2,*) 'In eello6_graph2'
8437         do iii=1,2
8438           write (2,*) 'iii=',iii
8439           do kkk=1,5
8440             write (2,*) 'kkk=',kkk
8441             do jjj=1,2
8442               write (2,'(3(2f10.5),5x)') &
8443               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8444             enddo
8445           enddo
8446         enddo
8447       endif
8448       do iii=1,2
8449         do kkk=1,5
8450           do lll=1,3
8451 #ifdef MOMENT
8452             if (iii.eq.1) then
8453               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8454             else
8455               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8456             endif
8457 #endif
8458             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8459               auxvec(1))
8460             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8461             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8462               auxvec(1))
8463             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8464             call transpose2(EUg(1,1,k),auxmat(1,1))
8465             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8466               pizda(1,1))
8467             vv(1)=pizda(1,1)-pizda(2,2)
8468             vv(2)=pizda(1,2)+pizda(2,1)
8469             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8470 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8471 #ifdef MOMENT
8472             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8473 #else
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8475 #endif
8476             if (swap) then
8477               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8478             else
8479               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8480             endif
8481           enddo
8482         enddo
8483       enddo
8484       return
8485       end function eello6_graph2
8486 !-----------------------------------------------------------------------------
8487       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8488 !      implicit real*8 (a-h,o-z)
8489 !      include 'DIMENSIONS'
8490 !      include 'COMMON.IOUNITS'
8491 !      include 'COMMON.CHAIN'
8492 !      include 'COMMON.DERIV'
8493 !      include 'COMMON.INTERACT'
8494 !      include 'COMMON.CONTACTS'
8495 !      include 'COMMON.TORSION'
8496 !      include 'COMMON.VAR'
8497 !      include 'COMMON.GEO'
8498       real(kind=8),dimension(2) :: vv,auxvec
8499       real(kind=8),dimension(2,2) :: pizda,auxmat
8500       logical :: swap
8501       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8502       real(kind=8) :: s1,s2,s3,s4
8503 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8504 !                                                                              C
8505 !      Parallel       Antiparallel                                             C
8506 !                                                                              C
8507 !          o             o                                                     C
8508 !         /l\   /   \   /j\                                                    C
8509 !        /   \ /     \ /   \                                                   C
8510 !       /| o |o       o| o |\                                                  C
8511 !       j|/k\|  /      |/k\|l /                                                C
8512 !        /   \ /       /   \ /                                                 C
8513 !       /     o       /     o                                                  C
8514 !       i             i                                                        C
8515 !                                                                              C
8516 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8517 !
8518 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8519 !           energy moment and not to the cluster cumulant.
8520       iti=itortyp(itype(i))
8521       if (j.lt.nres-1) then
8522         itj1=itortyp(itype(j+1))
8523       else
8524         itj1=ntortyp+1
8525       endif
8526       itk=itortyp(itype(k))
8527       itk1=itortyp(itype(k+1))
8528       if (l.lt.nres-1) then
8529         itl1=itortyp(itype(l+1))
8530       else
8531         itl1=ntortyp+1
8532       endif
8533 #ifdef MOMENT
8534       s1=dip(4,jj,i)*dip(4,kk,k)
8535 #endif
8536       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8537       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8538       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8539       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8540       call transpose2(EE(1,1,itk),auxmat(1,1))
8541       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8542       vv(1)=pizda(1,1)+pizda(2,2)
8543       vv(2)=pizda(2,1)-pizda(1,2)
8544       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8545 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8546 !d     & "sum",-(s2+s3+s4)
8547 #ifdef MOMENT
8548       eello6_graph3=-(s1+s2+s3+s4)
8549 #else
8550       eello6_graph3=-(s2+s3+s4)
8551 #endif
8552 !      eello6_graph3=-s4
8553 ! Derivatives in gamma(k-1)
8554       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8555       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8556       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8557       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8558 ! Derivatives in gamma(l-1)
8559       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8560       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8561       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8562       vv(1)=pizda(1,1)+pizda(2,2)
8563       vv(2)=pizda(2,1)-pizda(1,2)
8564       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8565       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8566 ! Cartesian derivatives.
8567       do iii=1,2
8568         do kkk=1,5
8569           do lll=1,3
8570 #ifdef MOMENT
8571             if (iii.eq.1) then
8572               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8573             else
8574               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8575             endif
8576 #endif
8577             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8578               auxvec(1))
8579             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8580             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8581               auxvec(1))
8582             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8583             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8584               pizda(1,1))
8585             vv(1)=pizda(1,1)+pizda(2,2)
8586             vv(2)=pizda(2,1)-pizda(1,2)
8587             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8588 #ifdef MOMENT
8589             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8590 #else
8591             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8592 #endif
8593             if (swap) then
8594               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8595             else
8596               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8597             endif
8598 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8599           enddo
8600         enddo
8601       enddo
8602       return
8603       end function eello6_graph3
8604 !-----------------------------------------------------------------------------
8605       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8606 !      implicit real*8 (a-h,o-z)
8607 !      include 'DIMENSIONS'
8608 !      include 'COMMON.IOUNITS'
8609 !      include 'COMMON.CHAIN'
8610 !      include 'COMMON.DERIV'
8611 !      include 'COMMON.INTERACT'
8612 !      include 'COMMON.CONTACTS'
8613 !      include 'COMMON.TORSION'
8614 !      include 'COMMON.VAR'
8615 !      include 'COMMON.GEO'
8616 !      include 'COMMON.FFIELD'
8617       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8618       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8619       logical :: swap
8620       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8621               iii,kkk,lll
8622       real(kind=8) :: s1,s2,s3,s4
8623 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8624 !                                                                              C
8625 !      Parallel       Antiparallel                                             C
8626 !                                                                              C
8627 !          o             o                                                     C
8628 !         /l\   /   \   /j\                                                    C
8629 !        /   \ /     \ /   \                                                   C
8630 !       /| o |o       o| o |\                                                  C
8631 !     \ j|/k\|      \  |/k\|l                                                  C
8632 !      \ /   \       \ /   \                                                   C
8633 !       o     \       o     \                                                  C
8634 !       i             i                                                        C
8635 !                                                                              C
8636 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8637 !
8638 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8639 !           energy moment and not to the cluster cumulant.
8640 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8641       iti=itortyp(itype(i))
8642       itj=itortyp(itype(j))
8643       if (j.lt.nres-1) then
8644         itj1=itortyp(itype(j+1))
8645       else
8646         itj1=ntortyp+1
8647       endif
8648       itk=itortyp(itype(k))
8649       if (k.lt.nres-1) then
8650         itk1=itortyp(itype(k+1))
8651       else
8652         itk1=ntortyp+1
8653       endif
8654       itl=itortyp(itype(l))
8655       if (l.lt.nres-1) then
8656         itl1=itortyp(itype(l+1))
8657       else
8658         itl1=ntortyp+1
8659       endif
8660 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8661 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8662 !d     & ' itl',itl,' itl1',itl1
8663 #ifdef MOMENT
8664       if (imat.eq.1) then
8665         s1=dip(3,jj,i)*dip(3,kk,k)
8666       else
8667         s1=dip(2,jj,j)*dip(2,kk,l)
8668       endif
8669 #endif
8670       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8671       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8672       if (j.eq.l+1) then
8673         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8674         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8675       else
8676         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8677         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8678       endif
8679       call transpose2(EUg(1,1,k),auxmat(1,1))
8680       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8681       vv(1)=pizda(1,1)-pizda(2,2)
8682       vv(2)=pizda(2,1)+pizda(1,2)
8683       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8684 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8685 #ifdef MOMENT
8686       eello6_graph4=-(s1+s2+s3+s4)
8687 #else
8688       eello6_graph4=-(s2+s3+s4)
8689 #endif
8690 ! Derivatives in gamma(i-1)
8691       if (i.gt.1) then
8692 #ifdef MOMENT
8693         if (imat.eq.1) then
8694           s1=dipderg(2,jj,i)*dip(3,kk,k)
8695         else
8696           s1=dipderg(4,jj,j)*dip(2,kk,l)
8697         endif
8698 #endif
8699         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8700         if (j.eq.l+1) then
8701           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8702           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8703         else
8704           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8705           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8706         endif
8707         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8708         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8709 !d          write (2,*) 'turn6 derivatives'
8710 #ifdef MOMENT
8711           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8712 #else
8713           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8714 #endif
8715         else
8716 #ifdef MOMENT
8717           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8718 #else
8719           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8720 #endif
8721         endif
8722       endif
8723 ! Derivatives in gamma(k-1)
8724 #ifdef MOMENT
8725       if (imat.eq.1) then
8726         s1=dip(3,jj,i)*dipderg(2,kk,k)
8727       else
8728         s1=dip(2,jj,j)*dipderg(4,kk,l)
8729       endif
8730 #endif
8731       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8732       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8733       if (j.eq.l+1) then
8734         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8735         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8736       else
8737         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8738         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8739       endif
8740       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8741       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8742       vv(1)=pizda(1,1)-pizda(2,2)
8743       vv(2)=pizda(2,1)+pizda(1,2)
8744       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8745       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8746 #ifdef MOMENT
8747         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8748 #else
8749         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8750 #endif
8751       else
8752 #ifdef MOMENT
8753         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8754 #else
8755         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8756 #endif
8757       endif
8758 ! Derivatives in gamma(j-1) or gamma(l-1)
8759       if (l.eq.j+1 .and. l.gt.1) then
8760         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8761         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8762         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8763         vv(1)=pizda(1,1)-pizda(2,2)
8764         vv(2)=pizda(2,1)+pizda(1,2)
8765         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8766         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8767       else if (j.gt.1) then
8768         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8769         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8770         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8771         vv(1)=pizda(1,1)-pizda(2,2)
8772         vv(2)=pizda(2,1)+pizda(1,2)
8773         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8774         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8775           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8776         else
8777           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8778         endif
8779       endif
8780 ! Cartesian derivatives.
8781       do iii=1,2
8782         do kkk=1,5
8783           do lll=1,3
8784 #ifdef MOMENT
8785             if (iii.eq.1) then
8786               if (imat.eq.1) then
8787                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8788               else
8789                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8790               endif
8791             else
8792               if (imat.eq.1) then
8793                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8794               else
8795                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8796               endif
8797             endif
8798 #endif
8799             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8800               auxvec(1))
8801             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8802             if (j.eq.l+1) then
8803               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8804                 b1(1,itj1),auxvec(1))
8805               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8806             else
8807               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8808                 b1(1,itl1),auxvec(1))
8809               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8810             endif
8811             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8812               pizda(1,1))
8813             vv(1)=pizda(1,1)-pizda(2,2)
8814             vv(2)=pizda(2,1)+pizda(1,2)
8815             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8816             if (swap) then
8817               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8818 #ifdef MOMENT
8819                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8820                    -(s1+s2+s4)
8821 #else
8822                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8823                    -(s2+s4)
8824 #endif
8825                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8826               else
8827 #ifdef MOMENT
8828                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8829 #else
8830                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8831 #endif
8832                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8833               endif
8834             else
8835 #ifdef MOMENT
8836               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8837 #else
8838               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8839 #endif
8840               if (l.eq.j+1) then
8841                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8842               else
8843                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8844               endif
8845             endif
8846           enddo
8847         enddo
8848       enddo
8849       return
8850       end function eello6_graph4
8851 !-----------------------------------------------------------------------------
8852       real(kind=8) function eello_turn6(i,jj,kk)
8853 !      implicit real*8 (a-h,o-z)
8854 !      include 'DIMENSIONS'
8855 !      include 'COMMON.IOUNITS'
8856 !      include 'COMMON.CHAIN'
8857 !      include 'COMMON.DERIV'
8858 !      include 'COMMON.INTERACT'
8859 !      include 'COMMON.CONTACTS'
8860 !      include 'COMMON.TORSION'
8861 !      include 'COMMON.VAR'
8862 !      include 'COMMON.GEO'
8863       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8864       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8865       real(kind=8),dimension(3) :: ggg1,ggg2
8866       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8867       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8868 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8869 !           the respective energy moment and not to the cluster cumulant.
8870 !el local variables
8871       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8872       integer :: j1,j2,l1,l2,ll
8873       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8874       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8875       s1=0.0d0
8876       s8=0.0d0
8877       s13=0.0d0
8878 !
8879       eello_turn6=0.0d0
8880       j=i+4
8881       k=i+1
8882       l=i+3
8883       iti=itortyp(itype(i))
8884       itk=itortyp(itype(k))
8885       itk1=itortyp(itype(k+1))
8886       itl=itortyp(itype(l))
8887       itj=itortyp(itype(j))
8888 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8889 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8890 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8891 !d        eello6=0.0d0
8892 !d        return
8893 !d      endif
8894 !d      write (iout,*)
8895 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8896 !d     &   ' and',k,l
8897 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8898       do iii=1,2
8899         do kkk=1,5
8900           do lll=1,3
8901             derx_turn(lll,kkk,iii)=0.0d0
8902           enddo
8903         enddo
8904       enddo
8905 !d      eij=1.0d0
8906 !d      ekl=1.0d0
8907 !d      ekont=1.0d0
8908       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8909 !d      eello6_5=0.0d0
8910 !d      write (2,*) 'eello6_5',eello6_5
8911 #ifdef MOMENT
8912       call transpose2(AEA(1,1,1),auxmat(1,1))
8913       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8914       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8915       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8916 #endif
8917       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8918       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8919       s2 = scalar2(b1(1,itk),vtemp1(1))
8920 #ifdef MOMENT
8921       call transpose2(AEA(1,1,2),atemp(1,1))
8922       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8923       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8924       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8925 #endif
8926       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8927       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8928       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8929 #ifdef MOMENT
8930       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8931       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8932       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8933       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8934       ss13 = scalar2(b1(1,itk),vtemp4(1))
8935       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8936 #endif
8937 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8938 !      s1=0.0d0
8939 !      s2=0.0d0
8940 !      s8=0.0d0
8941 !      s12=0.0d0
8942 !      s13=0.0d0
8943       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8944 ! Derivatives in gamma(i+2)
8945       s1d =0.0d0
8946       s8d =0.0d0
8947 #ifdef MOMENT
8948       call transpose2(AEA(1,1,1),auxmatd(1,1))
8949       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8950       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8951       call transpose2(AEAderg(1,1,2),atempd(1,1))
8952       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8953       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8954 #endif
8955       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8956       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8957       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8958 !      s1d=0.0d0
8959 !      s2d=0.0d0
8960 !      s8d=0.0d0
8961 !      s12d=0.0d0
8962 !      s13d=0.0d0
8963       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8964 ! Derivatives in gamma(i+3)
8965 #ifdef MOMENT
8966       call transpose2(AEA(1,1,1),auxmatd(1,1))
8967       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8968       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8969       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8970 #endif
8971       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8972       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8973       s2d = scalar2(b1(1,itk),vtemp1d(1))
8974 #ifdef MOMENT
8975       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8976       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8977 #endif
8978       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8979 #ifdef MOMENT
8980       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8981       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8982       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8983 #endif
8984 !      s1d=0.0d0
8985 !      s2d=0.0d0
8986 !      s8d=0.0d0
8987 !      s12d=0.0d0
8988 !      s13d=0.0d0
8989 #ifdef MOMENT
8990       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8991                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8992 #else
8993       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8994                     -0.5d0*ekont*(s2d+s12d)
8995 #endif
8996 ! Derivatives in gamma(i+4)
8997       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8998       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8999       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9000 #ifdef MOMENT
9001       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9002       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9003       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9004 #endif
9005 !      s1d=0.0d0
9006 !      s2d=0.0d0
9007 !      s8d=0.0d0
9008 !      s12d=0.0d0
9009 !      s13d=0.0d0
9010 #ifdef MOMENT
9011       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9012 #else
9013       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9014 #endif
9015 ! Derivatives in gamma(i+5)
9016 #ifdef MOMENT
9017       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9018       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9019       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9020 #endif
9021       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9022       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9023       s2d = scalar2(b1(1,itk),vtemp1d(1))
9024 #ifdef MOMENT
9025       call transpose2(AEA(1,1,2),atempd(1,1))
9026       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9027       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9028 #endif
9029       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9030       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9031 #ifdef MOMENT
9032       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9033       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9034       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9035 #endif
9036 !      s1d=0.0d0
9037 !      s2d=0.0d0
9038 !      s8d=0.0d0
9039 !      s12d=0.0d0
9040 !      s13d=0.0d0
9041 #ifdef MOMENT
9042       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9043                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9044 #else
9045       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9046                     -0.5d0*ekont*(s2d+s12d)
9047 #endif
9048 ! Cartesian derivatives
9049       do iii=1,2
9050         do kkk=1,5
9051           do lll=1,3
9052 #ifdef MOMENT
9053             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9054             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9055             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9056 #endif
9057             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9058             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9059                 vtemp1d(1))
9060             s2d = scalar2(b1(1,itk),vtemp1d(1))
9061 #ifdef MOMENT
9062             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9063             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9064             s8d = -(atempd(1,1)+atempd(2,2))* &
9065                  scalar2(cc(1,1,itl),vtemp2(1))
9066 #endif
9067             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9068                  auxmatd(1,1))
9069             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9070             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9071 !      s1d=0.0d0
9072 !      s2d=0.0d0
9073 !      s8d=0.0d0
9074 !      s12d=0.0d0
9075 !      s13d=0.0d0
9076 #ifdef MOMENT
9077             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9078               - 0.5d0*(s1d+s2d)
9079 #else
9080             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9081               - 0.5d0*s2d
9082 #endif
9083 #ifdef MOMENT
9084             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9085               - 0.5d0*(s8d+s12d)
9086 #else
9087             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9088               - 0.5d0*s12d
9089 #endif
9090           enddo
9091         enddo
9092       enddo
9093 #ifdef MOMENT
9094       do kkk=1,5
9095         do lll=1,3
9096           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9097             achuj_tempd(1,1))
9098           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9099           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9100           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9101           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9102           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9103             vtemp4d(1))
9104           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9105           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9106           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9107         enddo
9108       enddo
9109 #endif
9110 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9111 !d     &  16*eel_turn6_num
9112 !d      goto 1112
9113       if (j.lt.nres-1) then
9114         j1=j+1
9115         j2=j-1
9116       else
9117         j1=j-1
9118         j2=j-2
9119       endif
9120       if (l.lt.nres-1) then
9121         l1=l+1
9122         l2=l-1
9123       else
9124         l1=l-1
9125         l2=l-2
9126       endif
9127       do ll=1,3
9128 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9129 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9130 !grad        ghalf=0.5d0*ggg1(ll)
9131 !d        ghalf=0.0d0
9132         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9133         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9134         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9135           +ekont*derx_turn(ll,2,1)
9136         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9137         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9138           +ekont*derx_turn(ll,4,1)
9139         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9140         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9141         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9142 !grad        ghalf=0.5d0*ggg2(ll)
9143 !d        ghalf=0.0d0
9144         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9145           +ekont*derx_turn(ll,2,2)
9146         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9147         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9148           +ekont*derx_turn(ll,4,2)
9149         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9150         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9151         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9152       enddo
9153 !d      goto 1112
9154 !grad      do m=i+1,j-1
9155 !grad        do ll=1,3
9156 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9157 !grad        enddo
9158 !grad      enddo
9159 !grad      do m=k+1,l-1
9160 !grad        do ll=1,3
9161 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9162 !grad        enddo
9163 !grad      enddo
9164 !grad1112  continue
9165 !grad      do m=i+2,j2
9166 !grad        do ll=1,3
9167 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9168 !grad        enddo
9169 !grad      enddo
9170 !grad      do m=k+2,l2
9171 !grad        do ll=1,3
9172 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9173 !grad        enddo
9174 !grad      enddo
9175 !d      do iii=1,nres-3
9176 !d        write (2,*) iii,g_corr6_loc(iii)
9177 !d      enddo
9178       eello_turn6=ekont*eel_turn6
9179 !d      write (2,*) 'ekont',ekont
9180 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9181       return
9182       end function eello_turn6
9183 !-----------------------------------------------------------------------------
9184       subroutine MATVEC2(A1,V1,V2)
9185 !DIR$ INLINEALWAYS MATVEC2
9186 #ifndef OSF
9187 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9188 #endif
9189 !      implicit real*8 (a-h,o-z)
9190 !      include 'DIMENSIONS'
9191       real(kind=8),dimension(2) :: V1,V2
9192       real(kind=8),dimension(2,2) :: A1
9193       real(kind=8) :: vaux1,vaux2
9194 !      DO 1 I=1,2
9195 !        VI=0.0
9196 !        DO 3 K=1,2
9197 !    3     VI=VI+A1(I,K)*V1(K)
9198 !        Vaux(I)=VI
9199 !    1 CONTINUE
9200
9201       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9202       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9203
9204       v2(1)=vaux1
9205       v2(2)=vaux2
9206       end subroutine MATVEC2
9207 !-----------------------------------------------------------------------------
9208       subroutine MATMAT2(A1,A2,A3)
9209 #ifndef OSF
9210 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9211 #endif
9212 !      implicit real*8 (a-h,o-z)
9213 !      include 'DIMENSIONS'
9214       real(kind=8),dimension(2,2) :: A1,A2,A3
9215       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9216 !      DIMENSION AI3(2,2)
9217 !        DO  J=1,2
9218 !          A3IJ=0.0
9219 !          DO K=1,2
9220 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9221 !          enddo
9222 !          A3(I,J)=A3IJ
9223 !       enddo
9224 !      enddo
9225
9226       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9227       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9228       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9229       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9230
9231       A3(1,1)=AI3_11
9232       A3(2,1)=AI3_21
9233       A3(1,2)=AI3_12
9234       A3(2,2)=AI3_22
9235       end subroutine MATMAT2
9236 !-----------------------------------------------------------------------------
9237       real(kind=8) function scalar2(u,v)
9238 !DIR$ INLINEALWAYS scalar2
9239       implicit none
9240       real(kind=8),dimension(2) :: u,v
9241       real(kind=8) :: sc
9242       integer :: i
9243       scalar2=u(1)*v(1)+u(2)*v(2)
9244       return
9245       end function scalar2
9246 !-----------------------------------------------------------------------------
9247       subroutine transpose2(a,at)
9248 !DIR$ INLINEALWAYS transpose2
9249 #ifndef OSF
9250 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9251 #endif
9252       implicit none
9253       real(kind=8),dimension(2,2) :: a,at
9254       at(1,1)=a(1,1)
9255       at(1,2)=a(2,1)
9256       at(2,1)=a(1,2)
9257       at(2,2)=a(2,2)
9258       return
9259       end subroutine transpose2
9260 !-----------------------------------------------------------------------------
9261       subroutine transpose(n,a,at)
9262       implicit none
9263       integer :: n,i,j
9264       real(kind=8),dimension(n,n) :: a,at
9265       do i=1,n
9266         do j=1,n
9267           at(j,i)=a(i,j)
9268         enddo
9269       enddo
9270       return
9271       end subroutine transpose
9272 !-----------------------------------------------------------------------------
9273       subroutine prodmat3(a1,a2,kk,transp,prod)
9274 !DIR$ INLINEALWAYS prodmat3
9275 #ifndef OSF
9276 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9277 #endif
9278       implicit none
9279       integer :: i,j
9280       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9281       logical :: transp
9282 !rc      double precision auxmat(2,2),prod_(2,2)
9283
9284       if (transp) then
9285 !rc        call transpose2(kk(1,1),auxmat(1,1))
9286 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9287 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9288
9289            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9290        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9291            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9292        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9293            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9294        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9295            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9296        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9297
9298       else
9299 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9300 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9301
9302            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9303         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9304            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9305         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9306            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9307         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9308            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9309         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9310
9311       endif
9312 !      call transpose2(a2(1,1),a2t(1,1))
9313
9314 !rc      print *,transp
9315 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9316 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9317
9318       return
9319       end subroutine prodmat3
9320 !-----------------------------------------------------------------------------
9321 ! energy_p_new_barrier.F
9322 !-----------------------------------------------------------------------------
9323       subroutine sum_gradient
9324 !      implicit real*8 (a-h,o-z)
9325       use io_base, only: pdbout
9326 !      include 'DIMENSIONS'
9327 #ifndef ISNAN
9328       external proc_proc
9329 #ifdef WINPGI
9330 !MS$ATTRIBUTES C ::  proc_proc
9331 #endif
9332 #endif
9333 #ifdef MPI
9334       include 'mpif.h'
9335 #endif
9336       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9337                    gloc_scbuf !(3,maxres)
9338
9339       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9340 !#endif
9341 !el local variables
9342       integer :: i,j,k,ierror,ierr
9343       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9344                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9345                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9346                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9347                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9348                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9349                    gsccorr_max,gsccorrx_max,time00
9350
9351 !      include 'COMMON.SETUP'
9352 !      include 'COMMON.IOUNITS'
9353 !      include 'COMMON.FFIELD'
9354 !      include 'COMMON.DERIV'
9355 !      include 'COMMON.INTERACT'
9356 !      include 'COMMON.SBRIDGE'
9357 !      include 'COMMON.CHAIN'
9358 !      include 'COMMON.VAR'
9359 !      include 'COMMON.CONTROL'
9360 !      include 'COMMON.TIME1'
9361 !      include 'COMMON.MAXGRAD'
9362 !      include 'COMMON.SCCOR'
9363 #ifdef TIMING
9364       time01=MPI_Wtime()
9365 #endif
9366 #ifdef DEBUG
9367       write (iout,*) "sum_gradient gvdwc, gvdwx"
9368       do i=1,nres
9369         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9370          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9371       enddo
9372       call flush(iout)
9373 #endif
9374 #ifdef MPI
9375         gradbufc=0.0d0
9376         gradbufx=0.0d0
9377         gradbufc_sum=0.0d0
9378         gloc_scbuf=0.0d0
9379         glocbuf=0.0d0
9380 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9381         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9382           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9383 #endif
9384 !
9385 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9386 !            in virtual-bond-vector coordinates
9387 !
9388 #ifdef DEBUG
9389 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9390 !      do i=1,nres-1
9391 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9392 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9393 !      enddo
9394 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9395 !      do i=1,nres-1
9396 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9397 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9398 !      enddo
9399       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9400       do i=1,nres
9401         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9402          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9403          (gvdwc_scpp(j,i),j=1,3)
9404       enddo
9405       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9406       do i=1,nres
9407         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9408          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9409          (gelc_loc_long(j,i),j=1,3)
9410       enddo
9411       call flush(iout)
9412 #endif
9413 #ifdef SPLITELE
9414       do i=1,nct
9415         do j=1,3
9416           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9417                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9418                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9419                       wel_loc*gel_loc_long(j,i)+ &
9420                       wcorr*gradcorr_long(j,i)+ &
9421                       wcorr5*gradcorr5_long(j,i)+ &
9422                       wcorr6*gradcorr6_long(j,i)+ &
9423                       wturn6*gcorr6_turn_long(j,i)+ &
9424                       wstrain*ghpbc(j,i)
9425         enddo
9426       enddo
9427 #else
9428       do i=1,nct
9429         do j=1,3
9430           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9431                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9432                       welec*gelc_long(j,i)+ &
9433                       wbond*gradb(j,i)+ &
9434                       wel_loc*gel_loc_long(j,i)+ &
9435                       wcorr*gradcorr_long(j,i)+ &
9436                       wcorr5*gradcorr5_long(j,i)+ &
9437                       wcorr6*gradcorr6_long(j,i)+ &
9438                       wturn6*gcorr6_turn_long(j,i)+ &
9439                       wstrain*ghpbc(j,i)
9440         enddo
9441       enddo
9442 #endif
9443 #ifdef MPI
9444       if (nfgtasks.gt.1) then
9445       time00=MPI_Wtime()
9446 #ifdef DEBUG
9447       write (iout,*) "gradbufc before allreduce"
9448       do i=1,nres
9449         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9450       enddo
9451       call flush(iout)
9452 #endif
9453       do i=1,nres
9454         do j=1,3
9455           gradbufc_sum(j,i)=gradbufc(j,i)
9456         enddo
9457       enddo
9458 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9459 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9460 !      time_reduce=time_reduce+MPI_Wtime()-time00
9461 #ifdef DEBUG
9462 !      write (iout,*) "gradbufc_sum after allreduce"
9463 !      do i=1,nres
9464 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9465 !      enddo
9466 !      call flush(iout)
9467 #endif
9468 #ifdef TIMING
9469 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9470 #endif
9471       do i=nnt,nres
9472         do k=1,3
9473           gradbufc(k,i)=0.0d0
9474         enddo
9475       enddo
9476 #ifdef DEBUG
9477       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9478       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9479                         " jgrad_end  ",jgrad_end(i),&
9480                         i=igrad_start,igrad_end)
9481 #endif
9482 !
9483 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9484 ! do not parallelize this part.
9485 !
9486 !      do i=igrad_start,igrad_end
9487 !        do j=jgrad_start(i),jgrad_end(i)
9488 !          do k=1,3
9489 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9490 !          enddo
9491 !        enddo
9492 !      enddo
9493       do j=1,3
9494         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9495       enddo
9496       do i=nres-2,nnt,-1
9497         do j=1,3
9498           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9499         enddo
9500       enddo
9501 #ifdef DEBUG
9502       write (iout,*) "gradbufc after summing"
9503       do i=1,nres
9504         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9505       enddo
9506       call flush(iout)
9507 #endif
9508       else
9509 #endif
9510 !el#define DEBUG
9511 #ifdef DEBUG
9512       write (iout,*) "gradbufc"
9513       do i=1,nres
9514         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9515       enddo
9516       call flush(iout)
9517 #endif
9518 !el#undef DEBUG
9519       do i=1,nres
9520         do j=1,3
9521           gradbufc_sum(j,i)=gradbufc(j,i)
9522           gradbufc(j,i)=0.0d0
9523         enddo
9524       enddo
9525       do j=1,3
9526         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9527       enddo
9528       do i=nres-2,nnt,-1
9529         do j=1,3
9530           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9531         enddo
9532       enddo
9533 !      do i=nnt,nres-1
9534 !        do k=1,3
9535 !          gradbufc(k,i)=0.0d0
9536 !        enddo
9537 !        do j=i+1,nres
9538 !          do k=1,3
9539 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9540 !          enddo
9541 !        enddo
9542 !      enddo
9543 !el#define DEBUG
9544 #ifdef DEBUG
9545       write (iout,*) "gradbufc after summing"
9546       do i=1,nres
9547         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9548       enddo
9549       call flush(iout)
9550 #endif
9551 !el#undef DEBUG
9552 #ifdef MPI
9553       endif
9554 #endif
9555       do k=1,3
9556         gradbufc(k,nres)=0.0d0
9557       enddo
9558 !el----------------
9559 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9560 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9561 !el-----------------
9562       do i=1,nct
9563         do j=1,3
9564 #ifdef SPLITELE
9565           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9566                       wel_loc*gel_loc(j,i)+ &
9567                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9568                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9569                       wel_loc*gel_loc_long(j,i)+ &
9570                       wcorr*gradcorr_long(j,i)+ &
9571                       wcorr5*gradcorr5_long(j,i)+ &
9572                       wcorr6*gradcorr6_long(j,i)+ &
9573                       wturn6*gcorr6_turn_long(j,i))+ &
9574                       wbond*gradb(j,i)+ &
9575                       wcorr*gradcorr(j,i)+ &
9576                       wturn3*gcorr3_turn(j,i)+ &
9577                       wturn4*gcorr4_turn(j,i)+ &
9578                       wcorr5*gradcorr5(j,i)+ &
9579                       wcorr6*gradcorr6(j,i)+ &
9580                       wturn6*gcorr6_turn(j,i)+ &
9581                       wsccor*gsccorc(j,i) &
9582                      +wscloc*gscloc(j,i)
9583 #else
9584           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9585                       wel_loc*gel_loc(j,i)+ &
9586                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9587                       welec*gelc_long(j,i)+ &
9588                       wel_loc*gel_loc_long(j,i)+ &
9589 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9590                       wcorr5*gradcorr5_long(j,i)+ &
9591                       wcorr6*gradcorr6_long(j,i)+ &
9592                       wturn6*gcorr6_turn_long(j,i))+ &
9593                       wbond*gradb(j,i)+ &
9594                       wcorr*gradcorr(j,i)+ &
9595                       wturn3*gcorr3_turn(j,i)+ &
9596                       wturn4*gcorr4_turn(j,i)+ &
9597                       wcorr5*gradcorr5(j,i)+ &
9598                       wcorr6*gradcorr6(j,i)+ &
9599                       wturn6*gcorr6_turn(j,i)+ &
9600                       wsccor*gsccorc(j,i) &
9601                      +wscloc*gscloc(j,i)
9602 #endif
9603           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9604                         wbond*gradbx(j,i)+ &
9605                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9606                         wsccor*gsccorx(j,i) &
9607                        +wscloc*gsclocx(j,i)
9608         enddo
9609       enddo
9610 #ifdef DEBUG
9611       write (iout,*) "gloc before adding corr"
9612       do i=1,4*nres
9613         write (iout,*) i,gloc(i,icg)
9614       enddo
9615 #endif
9616       do i=1,nres-3
9617         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9618          +wcorr5*g_corr5_loc(i) &
9619          +wcorr6*g_corr6_loc(i) &
9620          +wturn4*gel_loc_turn4(i) &
9621          +wturn3*gel_loc_turn3(i) &
9622          +wturn6*gel_loc_turn6(i) &
9623          +wel_loc*gel_loc_loc(i)
9624       enddo
9625 #ifdef DEBUG
9626       write (iout,*) "gloc after adding corr"
9627       do i=1,4*nres
9628         write (iout,*) i,gloc(i,icg)
9629       enddo
9630 #endif
9631 #ifdef MPI
9632       if (nfgtasks.gt.1) then
9633         do j=1,3
9634           do i=1,nres
9635             gradbufc(j,i)=gradc(j,i,icg)
9636             gradbufx(j,i)=gradx(j,i,icg)
9637           enddo
9638         enddo
9639         do i=1,4*nres
9640           glocbuf(i)=gloc(i,icg)
9641         enddo
9642 !#define DEBUG
9643 #ifdef DEBUG
9644       write (iout,*) "gloc_sc before reduce"
9645       do i=1,nres
9646        do j=1,1
9647         write (iout,*) i,j,gloc_sc(j,i,icg)
9648        enddo
9649       enddo
9650 #endif
9651 !#undef DEBUG
9652         do i=1,nres
9653          do j=1,3
9654           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9655          enddo
9656         enddo
9657         time00=MPI_Wtime()
9658         call MPI_Barrier(FG_COMM,IERR)
9659         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9660         time00=MPI_Wtime()
9661         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9662           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9663         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9664           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9665         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9666           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9667         time_reduce=time_reduce+MPI_Wtime()-time00
9668         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9669           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9670         time_reduce=time_reduce+MPI_Wtime()-time00
9671 !#define DEBUG
9672 #ifdef DEBUG
9673       write (iout,*) "gloc_sc after reduce"
9674       do i=1,nres
9675        do j=1,1
9676         write (iout,*) i,j,gloc_sc(j,i,icg)
9677        enddo
9678       enddo
9679 #endif
9680 !#undef DEBUG
9681 #ifdef DEBUG
9682       write (iout,*) "gloc after reduce"
9683       do i=1,4*nres
9684         write (iout,*) i,gloc(i,icg)
9685       enddo
9686 #endif
9687       endif
9688 #endif
9689       if (gnorm_check) then
9690 !
9691 ! Compute the maximum elements of the gradient
9692 !
9693       gvdwc_max=0.0d0
9694       gvdwc_scp_max=0.0d0
9695       gelc_max=0.0d0
9696       gvdwpp_max=0.0d0
9697       gradb_max=0.0d0
9698       ghpbc_max=0.0d0
9699       gradcorr_max=0.0d0
9700       gel_loc_max=0.0d0
9701       gcorr3_turn_max=0.0d0
9702       gcorr4_turn_max=0.0d0
9703       gradcorr5_max=0.0d0
9704       gradcorr6_max=0.0d0
9705       gcorr6_turn_max=0.0d0
9706       gsccorc_max=0.0d0
9707       gscloc_max=0.0d0
9708       gvdwx_max=0.0d0
9709       gradx_scp_max=0.0d0
9710       ghpbx_max=0.0d0
9711       gradxorr_max=0.0d0
9712       gsccorx_max=0.0d0
9713       gsclocx_max=0.0d0
9714       do i=1,nct
9715         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9716         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9717         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9718         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9719          gvdwc_scp_max=gvdwc_scp_norm
9720         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9721         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9722         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9723         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9724         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9725         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9726         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9727         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9728         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9729         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9730         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9731         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9732         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9733           gcorr3_turn(1,i)))
9734         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9735           gcorr3_turn_max=gcorr3_turn_norm
9736         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9737           gcorr4_turn(1,i)))
9738         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9739           gcorr4_turn_max=gcorr4_turn_norm
9740         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9741         if (gradcorr5_norm.gt.gradcorr5_max) &
9742           gradcorr5_max=gradcorr5_norm
9743         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9744         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9745         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9746           gcorr6_turn(1,i)))
9747         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9748           gcorr6_turn_max=gcorr6_turn_norm
9749         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9750         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9751         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9752         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9753         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9754         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9755         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9756         if (gradx_scp_norm.gt.gradx_scp_max) &
9757           gradx_scp_max=gradx_scp_norm
9758         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9759         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9760         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9761         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9762         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9763         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9764         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9765         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9766       enddo
9767       if (gradout) then
9768 #ifdef AIX
9769         open(istat,file=statname,position="append")
9770 #else
9771         open(istat,file=statname,access="append")
9772 #endif
9773         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9774            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9775            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9776            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9777            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9778            gsccorx_max,gsclocx_max
9779         close(istat)
9780         if (gvdwc_max.gt.1.0d4) then
9781           write (iout,*) "gvdwc gvdwx gradb gradbx"
9782           do i=nnt,nct
9783             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9784               gradb(j,i),gradbx(j,i),j=1,3)
9785           enddo
9786           call pdbout(0.0d0,'cipiszcze',iout)
9787           call flush(iout)
9788         endif
9789       endif
9790       endif
9791 !el#define DEBUG
9792 #ifdef DEBUG
9793       write (iout,*) "gradc gradx gloc"
9794       do i=1,nres
9795         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9796          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9797       enddo
9798 #endif
9799 !el#undef DEBUG
9800 #ifdef TIMING
9801       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9802 #endif
9803       return
9804       end subroutine sum_gradient
9805 !-----------------------------------------------------------------------------
9806       subroutine sc_grad
9807 !      implicit real*8 (a-h,o-z)
9808       use calc_data
9809 !      include 'DIMENSIONS'
9810 !      include 'COMMON.CHAIN'
9811 !      include 'COMMON.DERIV'
9812 !      include 'COMMON.CALC'
9813 !      include 'COMMON.IOUNITS'
9814       real(kind=8), dimension(3) :: dcosom1,dcosom2
9815
9816       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9817       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9818       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9819            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9820 ! diagnostics only
9821 !      eom1=0.0d0
9822 !      eom2=0.0d0
9823 !      eom12=evdwij*eps1_om12
9824 ! end diagnostics
9825 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9826 !       " sigder",sigder
9827 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9828 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9829 !C      print *,sss_ele_cut,'in sc_grad'
9830       do k=1,3
9831         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9832         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9833       enddo
9834       do k=1,3
9835         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9836 !C      print *,'gg',k,gg(k)
9837       enddo
9838 !      write (iout,*) "gg",(gg(k),k=1,3)
9839       do k=1,3
9840         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9841                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9842                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9843                   *sss_ele_cut
9844
9845         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9846                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9847                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9848                   *sss_ele_cut
9849
9850 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9851 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9852 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9853 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9854       enddo
9855 !
9856 ! Calculate the components of the gradient in DC and X
9857 !
9858 !grad      do k=i,j-1
9859 !grad        do l=1,3
9860 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9861 !grad        enddo
9862 !grad      enddo
9863       do l=1,3
9864         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9865         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9866       enddo
9867       return
9868       end subroutine sc_grad
9869 #ifdef CRYST_THETA
9870 !-----------------------------------------------------------------------------
9871       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9872
9873       use comm_calcthet
9874 !      implicit real*8 (a-h,o-z)
9875 !      include 'DIMENSIONS'
9876 !      include 'COMMON.LOCAL'
9877 !      include 'COMMON.IOUNITS'
9878 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9879 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9880 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9881       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9882       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9883 !el      integer :: it
9884 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9885 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9886 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9887 !el local variables
9888
9889       delthec=thetai-thet_pred_mean
9890       delthe0=thetai-theta0i
9891 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9892       t3 = thetai-thet_pred_mean
9893       t6 = t3**2
9894       t9 = term1
9895       t12 = t3*sigcsq
9896       t14 = t12+t6*sigsqtc
9897       t16 = 1.0d0
9898       t21 = thetai-theta0i
9899       t23 = t21**2
9900       t26 = term2
9901       t27 = t21*t26
9902       t32 = termexp
9903       t40 = t32**2
9904       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9905        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9906        *(-t12*t9-ak*sig0inv*t27)
9907       return
9908       end subroutine mixder
9909 #endif
9910 !-----------------------------------------------------------------------------
9911 ! cartder.F
9912 !-----------------------------------------------------------------------------
9913       subroutine cartder
9914 !-----------------------------------------------------------------------------
9915 ! This subroutine calculates the derivatives of the consecutive virtual
9916 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9917 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9918 ! in the angles alpha and omega, describing the location of a side chain
9919 ! in its local coordinate system.
9920 !
9921 ! The derivatives are stored in the following arrays:
9922 !
9923 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9924 ! The structure is as follows:
9925 !
9926 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9927 ! 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)
9928 !         . . . . . . . . . . . .  . . . . . .
9929 ! 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)
9930 !                          .
9931 !                          .
9932 !                          .
9933 ! 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)
9934 !
9935 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9936 ! The structure is same as above.
9937 !
9938 ! DCDS - the derivatives of the side chain vectors in the local spherical
9939 ! andgles alph and omega:
9940 !
9941 ! 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)
9942 ! 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)
9943 !                          .
9944 !                          .
9945 !                          .
9946 ! 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)
9947 !
9948 ! Version of March '95, based on an early version of November '91.
9949 !
9950 !**********************************************************************
9951 !      implicit real*8 (a-h,o-z)
9952 !      include 'DIMENSIONS'
9953 !      include 'COMMON.VAR'
9954 !      include 'COMMON.CHAIN'
9955 !      include 'COMMON.DERIV'
9956 !      include 'COMMON.GEO'
9957 !      include 'COMMON.LOCAL'
9958 !      include 'COMMON.INTERACT'
9959       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9960       real(kind=8),dimension(3,3) :: dp,temp
9961 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9962       real(kind=8),dimension(3) :: xx,xx1
9963 !el local variables
9964       integer :: i,k,l,j,m,ind,ind1,jjj
9965       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9966                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9967                  sint2,xp,yp,xxp,yyp,zzp,dj
9968
9969 !      common /przechowalnia/ fromto
9970       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9971 ! get the position of the jth ijth fragment of the chain coordinate system
9972 ! in the fromto array.
9973 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9974 !
9975 !      maxdim=(nres-1)*(nres-2)/2
9976 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9977 ! calculate the derivatives of transformation matrix elements in theta
9978 !
9979
9980 !el      call flush(iout) !el
9981       do i=1,nres-2
9982         rdt(1,1,i)=-rt(1,2,i)
9983         rdt(1,2,i)= rt(1,1,i)
9984         rdt(1,3,i)= 0.0d0
9985         rdt(2,1,i)=-rt(2,2,i)
9986         rdt(2,2,i)= rt(2,1,i)
9987         rdt(2,3,i)= 0.0d0
9988         rdt(3,1,i)=-rt(3,2,i)
9989         rdt(3,2,i)= rt(3,1,i)
9990         rdt(3,3,i)= 0.0d0
9991       enddo
9992 !
9993 ! derivatives in phi
9994 !
9995       do i=2,nres-2
9996         drt(1,1,i)= 0.0d0
9997         drt(1,2,i)= 0.0d0
9998         drt(1,3,i)= 0.0d0
9999         drt(2,1,i)= rt(3,1,i)
10000         drt(2,2,i)= rt(3,2,i)
10001         drt(2,3,i)= rt(3,3,i)
10002         drt(3,1,i)=-rt(2,1,i)
10003         drt(3,2,i)=-rt(2,2,i)
10004         drt(3,3,i)=-rt(2,3,i)
10005       enddo
10006 !
10007 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10008 !
10009       do i=2,nres-2
10010         ind=indmat(i,i+1)
10011         do k=1,3
10012           do l=1,3
10013             temp(k,l)=rt(k,l,i)
10014           enddo
10015         enddo
10016         do k=1,3
10017           do l=1,3
10018             fromto(k,l,ind)=temp(k,l)
10019           enddo
10020         enddo
10021         do j=i+1,nres-2
10022           ind=indmat(i,j+1)
10023           do k=1,3
10024             do l=1,3
10025               dpkl=0.0d0
10026               do m=1,3
10027                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10028               enddo
10029               dp(k,l)=dpkl
10030               fromto(k,l,ind)=dpkl
10031             enddo
10032           enddo
10033           do k=1,3
10034             do l=1,3
10035               temp(k,l)=dp(k,l)
10036             enddo
10037           enddo
10038         enddo
10039       enddo
10040 !
10041 ! Calculate derivatives.
10042 !
10043       ind1=0
10044       do i=1,nres-2
10045         ind1=ind1+1
10046 !
10047 ! Derivatives of DC(i+1) in theta(i+2)
10048 !
10049         do j=1,3
10050           do k=1,2
10051             dpjk=0.0D0
10052             do l=1,3
10053               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10054             enddo
10055             dp(j,k)=dpjk
10056             prordt(j,k,i)=dp(j,k)
10057           enddo
10058           dp(j,3)=0.0D0
10059           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10060         enddo
10061 !
10062 ! Derivatives of SC(i+1) in theta(i+2)
10063 !
10064         xx1(1)=-0.5D0*xloc(2,i+1)
10065         xx1(2)= 0.5D0*xloc(1,i+1)
10066         do j=1,3
10067           xj=0.0D0
10068           do k=1,2
10069             xj=xj+r(j,k,i)*xx1(k)
10070           enddo
10071           xx(j)=xj
10072         enddo
10073         do j=1,3
10074           rj=0.0D0
10075           do k=1,3
10076             rj=rj+prod(j,k,i)*xx(k)
10077           enddo
10078           dxdv(j,ind1)=rj
10079         enddo
10080 !
10081 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10082 ! than the other off-diagonal derivatives.
10083 !
10084         do j=1,3
10085           dxoiij=0.0D0
10086           do k=1,3
10087             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10088           enddo
10089           dxdv(j,ind1+1)=dxoiij
10090         enddo
10091 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10092 !
10093 ! Derivatives of DC(i+1) in phi(i+2)
10094 !
10095         do j=1,3
10096           do k=1,3
10097             dpjk=0.0
10098             do l=2,3
10099               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10100             enddo
10101             dp(j,k)=dpjk
10102             prodrt(j,k,i)=dp(j,k)
10103           enddo
10104           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10105         enddo
10106 !
10107 ! Derivatives of SC(i+1) in phi(i+2)
10108 !
10109         xx(1)= 0.0D0
10110         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10111         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10112         do j=1,3
10113           rj=0.0D0
10114           do k=2,3
10115             rj=rj+prod(j,k,i)*xx(k)
10116           enddo
10117           dxdv(j+3,ind1)=-rj
10118         enddo
10119 !
10120 ! Derivatives of SC(i+1) in phi(i+3).
10121 !
10122         do j=1,3
10123           dxoiij=0.0D0
10124           do k=1,3
10125             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10126           enddo
10127           dxdv(j+3,ind1+1)=dxoiij
10128         enddo
10129 !
10130 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10131 ! theta(nres) and phi(i+3) thru phi(nres).
10132 !
10133         do j=i+1,nres-2
10134           ind1=ind1+1
10135           ind=indmat(i+1,j+1)
10136 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10137           do k=1,3
10138             do l=1,3
10139               tempkl=0.0D0
10140               do m=1,2
10141                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10142               enddo
10143               temp(k,l)=tempkl
10144             enddo
10145           enddo
10146 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10147 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10148 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10149 ! Derivatives of virtual-bond vectors in theta
10150           do k=1,3
10151             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10152           enddo
10153 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10154 ! Derivatives of SC vectors in theta
10155           do k=1,3
10156             dxoijk=0.0D0
10157             do l=1,3
10158               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10159             enddo
10160             dxdv(k,ind1+1)=dxoijk
10161           enddo
10162 !
10163 !--- Calculate the derivatives in phi
10164 !
10165           do k=1,3
10166             do l=1,3
10167               tempkl=0.0D0
10168               do m=1,3
10169                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10170               enddo
10171               temp(k,l)=tempkl
10172             enddo
10173           enddo
10174           do k=1,3
10175             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10176           enddo
10177           do k=1,3
10178             dxoijk=0.0D0
10179             do l=1,3
10180               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10181             enddo
10182             dxdv(k+3,ind1+1)=dxoijk
10183           enddo
10184         enddo
10185       enddo
10186 !
10187 ! Derivatives in alpha and omega:
10188 !
10189       do i=2,nres-1
10190 !       dsci=dsc(itype(i))
10191         dsci=vbld(i+nres)
10192 #ifdef OSF
10193         alphi=alph(i)
10194         omegi=omeg(i)
10195         if(alphi.ne.alphi) alphi=100.0
10196         if(omegi.ne.omegi) omegi=-100.0
10197 #else
10198         alphi=alph(i)
10199         omegi=omeg(i)
10200 #endif
10201 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10202         cosalphi=dcos(alphi)
10203         sinalphi=dsin(alphi)
10204         cosomegi=dcos(omegi)
10205         sinomegi=dsin(omegi)
10206         temp(1,1)=-dsci*sinalphi
10207         temp(2,1)= dsci*cosalphi*cosomegi
10208         temp(3,1)=-dsci*cosalphi*sinomegi
10209         temp(1,2)=0.0D0
10210         temp(2,2)=-dsci*sinalphi*sinomegi
10211         temp(3,2)=-dsci*sinalphi*cosomegi
10212         theta2=pi-0.5D0*theta(i+1)
10213         cost2=dcos(theta2)
10214         sint2=dsin(theta2)
10215         jjj=0
10216 !d      print *,((temp(l,k),l=1,3),k=1,2)
10217         do j=1,2
10218           xp=temp(1,j)
10219           yp=temp(2,j)
10220           xxp= xp*cost2+yp*sint2
10221           yyp=-xp*sint2+yp*cost2
10222           zzp=temp(3,j)
10223           xx(1)=xxp
10224           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10225           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10226           do k=1,3
10227             dj=0.0D0
10228             do l=1,3
10229               dj=dj+prod(k,l,i-1)*xx(l)
10230             enddo
10231             dxds(jjj+k,i)=dj
10232           enddo
10233           jjj=jjj+3
10234         enddo
10235       enddo
10236       return
10237       end subroutine cartder
10238 !-----------------------------------------------------------------------------
10239 ! checkder_p.F
10240 !-----------------------------------------------------------------------------
10241       subroutine check_cartgrad
10242 ! Check the gradient of Cartesian coordinates in internal coordinates.
10243 !      implicit real*8 (a-h,o-z)
10244 !      include 'DIMENSIONS'
10245 !      include 'COMMON.IOUNITS'
10246 !      include 'COMMON.VAR'
10247 !      include 'COMMON.CHAIN'
10248 !      include 'COMMON.GEO'
10249 !      include 'COMMON.LOCAL'
10250 !      include 'COMMON.DERIV'
10251       real(kind=8),dimension(6,nres) :: temp
10252       real(kind=8),dimension(3) :: xx,gg
10253       integer :: i,k,j,ii
10254       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10255 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10256 !
10257 ! Check the gradient of the virtual-bond and SC vectors in the internal
10258 ! coordinates.
10259 !
10260       aincr=1.0d-6
10261       aincr2=5.0d-7
10262       call cartder
10263       write (iout,'(a)') '**************** dx/dalpha'
10264       write (iout,'(a)')
10265       do i=2,nres-1
10266         alphi=alph(i)
10267         alph(i)=alph(i)+aincr
10268         do k=1,3
10269           temp(k,i)=dc(k,nres+i)
10270         enddo
10271         call chainbuild
10272         do k=1,3
10273           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10274           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10275         enddo
10276         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10277         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10278         write (iout,'(a)')
10279         alph(i)=alphi
10280         call chainbuild
10281       enddo
10282       write (iout,'(a)')
10283       write (iout,'(a)') '**************** dx/domega'
10284       write (iout,'(a)')
10285       do i=2,nres-1
10286         omegi=omeg(i)
10287         omeg(i)=omeg(i)+aincr
10288         do k=1,3
10289           temp(k,i)=dc(k,nres+i)
10290         enddo
10291         call chainbuild
10292         do k=1,3
10293           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10294           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10295                 (aincr*dabs(dxds(k+3,i))+aincr))
10296         enddo
10297         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10298             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10299         write (iout,'(a)')
10300         omeg(i)=omegi
10301         call chainbuild
10302       enddo
10303       write (iout,'(a)')
10304       write (iout,'(a)') '**************** dx/dtheta'
10305       write (iout,'(a)')
10306       do i=3,nres
10307         theti=theta(i)
10308         theta(i)=theta(i)+aincr
10309         do j=i-1,nres-1
10310           do k=1,3
10311             temp(k,j)=dc(k,nres+j)
10312           enddo
10313         enddo
10314         call chainbuild
10315         do j=i-1,nres-1
10316           ii = indmat(i-2,j)
10317 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10318           do k=1,3
10319             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10320             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10321                   (aincr*dabs(dxdv(k,ii))+aincr))
10322           enddo
10323           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10324               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10325           write(iout,'(a)')
10326         enddo
10327         write (iout,'(a)')
10328         theta(i)=theti
10329         call chainbuild
10330       enddo
10331       write (iout,'(a)') '***************** dx/dphi'
10332       write (iout,'(a)')
10333       do i=4,nres
10334         phi(i)=phi(i)+aincr
10335         do j=i-1,nres-1
10336           do k=1,3
10337             temp(k,j)=dc(k,nres+j)
10338           enddo
10339         enddo
10340         call chainbuild
10341         do j=i-1,nres-1
10342           ii = indmat(i-2,j)
10343 !         print *,'ii=',ii
10344           do k=1,3
10345             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10346             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10347                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10348           enddo
10349           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10350               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10351           write(iout,'(a)')
10352         enddo
10353         phi(i)=phi(i)-aincr
10354         call chainbuild
10355       enddo
10356       write (iout,'(a)') '****************** ddc/dtheta'
10357       do i=1,nres-2
10358         thet=theta(i+2)
10359         theta(i+2)=thet+aincr
10360         do j=i,nres
10361           do k=1,3
10362             temp(k,j)=dc(k,j)
10363           enddo
10364         enddo
10365         call chainbuild
10366         do j=i+1,nres-1
10367           ii = indmat(i,j)
10368 !         print *,'ii=',ii
10369           do k=1,3
10370             gg(k)=(dc(k,j)-temp(k,j))/aincr
10371             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10372                  (aincr*dabs(dcdv(k,ii))+aincr))
10373           enddo
10374           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10375                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10376           write (iout,'(a)')
10377         enddo
10378         do j=1,nres
10379           do k=1,3
10380             dc(k,j)=temp(k,j)
10381           enddo
10382         enddo
10383         theta(i+2)=thet
10384       enddo
10385       write (iout,'(a)') '******************* ddc/dphi'
10386       do i=1,nres-3
10387         phii=phi(i+3)
10388         phi(i+3)=phii+aincr
10389         do j=1,nres
10390           do k=1,3
10391             temp(k,j)=dc(k,j)
10392           enddo
10393         enddo
10394         call chainbuild
10395         do j=i+2,nres-1
10396           ii = indmat(i+1,j)
10397 !         print *,'ii=',ii
10398           do k=1,3
10399             gg(k)=(dc(k,j)-temp(k,j))/aincr
10400             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10401                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10402           enddo
10403           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10404                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10405           write (iout,'(a)')
10406         enddo
10407         do j=1,nres
10408           do k=1,3
10409             dc(k,j)=temp(k,j)
10410           enddo
10411         enddo
10412         phi(i+3)=phii
10413       enddo
10414       return
10415       end subroutine check_cartgrad
10416 !-----------------------------------------------------------------------------
10417       subroutine check_ecart
10418 ! Check the gradient of the energy in Cartesian coordinates.
10419 !     implicit real*8 (a-h,o-z)
10420 !     include 'DIMENSIONS'
10421 !     include 'COMMON.CHAIN'
10422 !     include 'COMMON.DERIV'
10423 !     include 'COMMON.IOUNITS'
10424 !     include 'COMMON.VAR'
10425 !     include 'COMMON.CONTACTS'
10426       use comm_srutu
10427 !el      integer :: icall
10428 !el      common /srutu/ icall
10429       real(kind=8),dimension(6) :: ggg
10430       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10431       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10432       real(kind=8),dimension(6,nres) :: grad_s
10433       real(kind=8),dimension(0:n_ene) :: energia,energia1
10434       integer :: uiparm(1)
10435       real(kind=8) :: urparm(1)
10436 !EL      external fdum
10437       integer :: nf,i,j,k
10438       real(kind=8) :: aincr,etot,etot1
10439       icg=1
10440       nf=0
10441       nfl=0
10442       call zerograd
10443       aincr=1.0D-5
10444       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
10445       nf=0
10446       icall=0
10447       call geom_to_var(nvar,x)
10448       call etotal(energia)
10449       etot=energia(0)
10450 !el      call enerprint(energia)
10451       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10452       icall =1
10453       do i=1,nres
10454         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10455       enddo
10456       do i=1,nres
10457         do j=1,3
10458           grad_s(j,i)=gradc(j,i,icg)
10459           grad_s(j+3,i)=gradx(j,i,icg)
10460         enddo
10461       enddo
10462       call flush(iout)
10463       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10464       do i=1,nres
10465         do j=1,3
10466           xx(j)=c(j,i+nres)
10467           ddc(j)=dc(j,i)
10468           ddx(j)=dc(j,i+nres)
10469         enddo
10470         do j=1,3
10471           dc(j,i)=dc(j,i)+aincr
10472           do k=i+1,nres
10473             c(j,k)=c(j,k)+aincr
10474             c(j,k+nres)=c(j,k+nres)+aincr
10475           enddo
10476           call etotal(energia1)
10477           etot1=energia1(0)
10478           ggg(j)=(etot1-etot)/aincr
10479           dc(j,i)=ddc(j)
10480           do k=i+1,nres
10481             c(j,k)=c(j,k)-aincr
10482             c(j,k+nres)=c(j,k+nres)-aincr
10483           enddo
10484         enddo
10485         do j=1,3
10486           c(j,i+nres)=c(j,i+nres)+aincr
10487           dc(j,i+nres)=dc(j,i+nres)+aincr
10488           call etotal(energia1)
10489           etot1=energia1(0)
10490           ggg(j+3)=(etot1-etot)/aincr
10491           c(j,i+nres)=xx(j)
10492           dc(j,i+nres)=ddx(j)
10493         enddo
10494         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10495          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10496       enddo
10497       return
10498       end subroutine check_ecart
10499 #ifdef CARGRAD
10500 !-----------------------------------------------------------------------------
10501       subroutine check_ecartint
10502 ! Check the gradient of the energy in Cartesian coordinates.
10503       use io_base, only: intout
10504 !      implicit real*8 (a-h,o-z)
10505 !      include 'DIMENSIONS'
10506 !      include 'COMMON.CONTROL'
10507 !      include 'COMMON.CHAIN'
10508 !      include 'COMMON.DERIV'
10509 !      include 'COMMON.IOUNITS'
10510 !      include 'COMMON.VAR'
10511 !      include 'COMMON.CONTACTS'
10512 !      include 'COMMON.MD'
10513 !      include 'COMMON.LOCAL'
10514 !      include 'COMMON.SPLITELE'
10515       use comm_srutu
10516 !el      integer :: icall
10517 !el      common /srutu/ icall
10518       real(kind=8),dimension(6) :: ggg,ggg1
10519       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10520       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10521       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10522       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10523       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10524       real(kind=8),dimension(0:n_ene) :: energia,energia1
10525       integer :: uiparm(1)
10526       real(kind=8) :: urparm(1)
10527 !EL      external fdum
10528       integer :: i,j,k,nf
10529       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10530                    etot21,etot22
10531       r_cut=2.0d0
10532       rlambd=0.3d0
10533       icg=1
10534       nf=0
10535       nfl=0
10536       call intout
10537 !      call intcartderiv
10538 !      call checkintcartgrad
10539       call zerograd
10540       aincr=1.0D-5
10541       write(iout,*) 'Calling CHECK_ECARTINT.'
10542       nf=0
10543       icall=0
10544       write (iout,*) "Before geom_to_var"
10545       call geom_to_var(nvar,x)
10546       write (iout,*) "after geom_to_var"
10547       write (iout,*) "split_ene ",split_ene
10548       call flush(iout)
10549       if (.not.split_ene) then
10550         write(iout,*) 'Calling CHECK_ECARTINT if'
10551         call etotal(energia)
10552 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10553         etot=energia(0)
10554         write (iout,*) "etot",etot
10555         call flush(iout)
10556 !el        call enerprint(energia)
10557 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10558         call flush(iout)
10559         write (iout,*) "enter cartgrad"
10560         call flush(iout)
10561         call cartgrad
10562 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10563         write (iout,*) "exit cartgrad"
10564         call flush(iout)
10565         icall =1
10566         do i=1,nres
10567           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10568         enddo
10569         do j=1,3
10570           grad_s(j,0)=gcart(j,0)
10571         enddo
10572 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10573         do i=1,nres
10574           do j=1,3
10575             grad_s(j,i)=gcart(j,i)
10576             grad_s(j+3,i)=gxcart(j,i)
10577           enddo
10578         enddo
10579       else
10580 write(iout,*) 'Calling CHECK_ECARTIN else.'
10581 !- split gradient check
10582         call zerograd
10583         call etotal_long(energia)
10584 !el        call enerprint(energia)
10585         call flush(iout)
10586         write (iout,*) "enter cartgrad"
10587         call flush(iout)
10588         call cartgrad
10589         write (iout,*) "exit cartgrad"
10590         call flush(iout)
10591         icall =1
10592         write (iout,*) "longrange grad"
10593         do i=1,nres
10594           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10595           (gxcart(j,i),j=1,3)
10596         enddo
10597         do j=1,3
10598           grad_s(j,0)=gcart(j,0)
10599         enddo
10600         do i=1,nres
10601           do j=1,3
10602             grad_s(j,i)=gcart(j,i)
10603             grad_s(j+3,i)=gxcart(j,i)
10604           enddo
10605         enddo
10606         call zerograd
10607         call etotal_short(energia)
10608 !el        call enerprint(energia)
10609         call flush(iout)
10610         write (iout,*) "enter cartgrad"
10611         call flush(iout)
10612         call cartgrad
10613         write (iout,*) "exit cartgrad"
10614         call flush(iout)
10615         icall =1
10616         write (iout,*) "shortrange grad"
10617         do i=1,nres
10618           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10619           (gxcart(j,i),j=1,3)
10620         enddo
10621         do j=1,3
10622           grad_s1(j,0)=gcart(j,0)
10623         enddo
10624         do i=1,nres
10625           do j=1,3
10626             grad_s1(j,i)=gcart(j,i)
10627             grad_s1(j+3,i)=gxcart(j,i)
10628           enddo
10629         enddo
10630       endif
10631       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10632 !      do i=1,nres
10633       do i=nnt,nct
10634         do j=1,3
10635           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10636           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10637           ddc(j)=c(j,i)
10638           ddx(j)=c(j,i+nres)
10639           dcnorm_safe1(j)=dc_norm(j,i-1)
10640           dcnorm_safe2(j)=dc_norm(j,i)
10641           dxnorm_safe(j)=dc_norm(j,i+nres)
10642         enddo
10643         do j=1,3
10644           c(j,i)=ddc(j)+aincr
10645           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10646           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10647           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10648           dc(j,i)=c(j,i+1)-c(j,i)
10649           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10650           call int_from_cart1(.false.)
10651           if (.not.split_ene) then
10652             call etotal(energia1)
10653             etot1=energia1(0)
10654             write (iout,*) "ij",i,j," etot1",etot1
10655           else
10656 !- split gradient
10657             call etotal_long(energia1)
10658             etot11=energia1(0)
10659             call etotal_short(energia1)
10660             etot12=energia1(0)
10661           endif
10662 !- end split gradient
10663 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10664           c(j,i)=ddc(j)-aincr
10665           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10666           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10667           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10668           dc(j,i)=c(j,i+1)-c(j,i)
10669           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10670           call int_from_cart1(.false.)
10671           if (.not.split_ene) then
10672             call etotal(energia1)
10673             etot2=energia1(0)
10674             write (iout,*) "ij",i,j," etot2",etot2
10675             ggg(j)=(etot1-etot2)/(2*aincr)
10676           else
10677 !- split gradient
10678             call etotal_long(energia1)
10679             etot21=energia1(0)
10680             ggg(j)=(etot11-etot21)/(2*aincr)
10681             call etotal_short(energia1)
10682             etot22=energia1(0)
10683             ggg1(j)=(etot12-etot22)/(2*aincr)
10684 !- end split gradient
10685 !            write (iout,*) "etot21",etot21," etot22",etot22
10686           endif
10687 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10688           c(j,i)=ddc(j)
10689           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10690           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10691           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10692           dc(j,i)=c(j,i+1)-c(j,i)
10693           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10694           dc_norm(j,i-1)=dcnorm_safe1(j)
10695           dc_norm(j,i)=dcnorm_safe2(j)
10696           dc_norm(j,i+nres)=dxnorm_safe(j)
10697         enddo
10698         do j=1,3
10699           c(j,i+nres)=ddx(j)+aincr
10700           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10701           call int_from_cart1(.false.)
10702           if (.not.split_ene) then
10703             call etotal(energia1)
10704             etot1=energia1(0)
10705           else
10706 !- split gradient
10707             call etotal_long(energia1)
10708             etot11=energia1(0)
10709             call etotal_short(energia1)
10710             etot12=energia1(0)
10711           endif
10712 !- end split gradient
10713           c(j,i+nres)=ddx(j)-aincr
10714           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10715           call int_from_cart1(.false.)
10716           if (.not.split_ene) then
10717             call etotal(energia1)
10718             etot2=energia1(0)
10719             ggg(j+3)=(etot1-etot2)/(2*aincr)
10720           else
10721 !- split gradient
10722             call etotal_long(energia1)
10723             etot21=energia1(0)
10724             ggg(j+3)=(etot11-etot21)/(2*aincr)
10725             call etotal_short(energia1)
10726             etot22=energia1(0)
10727             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10728 !- end split gradient
10729           endif
10730 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10731           c(j,i+nres)=ddx(j)
10732           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10733           dc_norm(j,i+nres)=dxnorm_safe(j)
10734           call int_from_cart1(.false.)
10735         enddo
10736         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10737          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10738         if (split_ene) then
10739           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10740          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10741          k=1,6)
10742          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10743          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10744          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10745         endif
10746       enddo
10747       return
10748       end subroutine check_ecartint
10749 #else
10750 !-----------------------------------------------------------------------------
10751       subroutine check_ecartint
10752 ! Check the gradient of the energy in Cartesian coordinates.
10753       use io_base, only: intout
10754 !      implicit real*8 (a-h,o-z)
10755 !      include 'DIMENSIONS'
10756 !      include 'COMMON.CONTROL'
10757 !      include 'COMMON.CHAIN'
10758 !      include 'COMMON.DERIV'
10759 !      include 'COMMON.IOUNITS'
10760 !      include 'COMMON.VAR'
10761 !      include 'COMMON.CONTACTS'
10762 !      include 'COMMON.MD'
10763 !      include 'COMMON.LOCAL'
10764 !      include 'COMMON.SPLITELE'
10765       use comm_srutu
10766 !el      integer :: icall
10767 !el      common /srutu/ icall
10768       real(kind=8),dimension(6) :: ggg,ggg1
10769       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10770       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10771       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10772       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10773       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10774       real(kind=8),dimension(0:n_ene) :: energia,energia1
10775       integer :: uiparm(1)
10776       real(kind=8) :: urparm(1)
10777 !EL      external fdum
10778       integer :: i,j,k,nf
10779       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10780                    etot21,etot22
10781       r_cut=2.0d0
10782       rlambd=0.3d0
10783       icg=1
10784       nf=0
10785       nfl=0
10786       call intout
10787 !      call intcartderiv
10788 !      call checkintcartgrad
10789       call zerograd
10790       aincr=2.0D-5
10791       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
10792       nf=0
10793       icall=0
10794       call geom_to_var(nvar,x)
10795       if (.not.split_ene) then
10796         call etotal(energia)
10797         etot=energia(0)
10798 !el        call enerprint(energia)
10799         call flush(iout)
10800         write (iout,*) "enter cartgrad"
10801         call flush(iout)
10802         call cartgrad
10803         write (iout,*) "exit cartgrad"
10804         call flush(iout)
10805         icall =1
10806         do i=1,nres
10807           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10808         enddo
10809         do j=1,3
10810           grad_s(j,0)=gcart(j,0)
10811         enddo
10812         do i=1,nres
10813           do j=1,3
10814             grad_s(j,i)=gcart(j,i)
10815             grad_s(j+3,i)=gxcart(j,i)
10816           enddo
10817         enddo
10818       else
10819 !- split gradient check
10820         call zerograd
10821         call etotal_long(energia)
10822 !el        call enerprint(energia)
10823         call flush(iout)
10824         write (iout,*) "enter cartgrad"
10825         call flush(iout)
10826         call cartgrad
10827         write (iout,*) "exit cartgrad"
10828         call flush(iout)
10829         icall =1
10830         write (iout,*) "longrange grad"
10831         do i=1,nres
10832           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10833           (gxcart(j,i),j=1,3)
10834         enddo
10835         do j=1,3
10836           grad_s(j,0)=gcart(j,0)
10837         enddo
10838         do i=1,nres
10839           do j=1,3
10840             grad_s(j,i)=gcart(j,i)
10841             grad_s(j+3,i)=gxcart(j,i)
10842           enddo
10843         enddo
10844         call zerograd
10845         call etotal_short(energia)
10846 !el        call enerprint(energia)
10847         call flush(iout)
10848         write (iout,*) "enter cartgrad"
10849         call flush(iout)
10850         call cartgrad
10851         write (iout,*) "exit cartgrad"
10852         call flush(iout)
10853         icall =1
10854         write (iout,*) "shortrange grad"
10855         do i=1,nres
10856           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10857           (gxcart(j,i),j=1,3)
10858         enddo
10859         do j=1,3
10860           grad_s1(j,0)=gcart(j,0)
10861         enddo
10862         do i=1,nres
10863           do j=1,3
10864             grad_s1(j,i)=gcart(j,i)
10865             grad_s1(j+3,i)=gxcart(j,i)
10866           enddo
10867         enddo
10868       endif
10869       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10870       do i=0,nres
10871         do j=1,3
10872           xx(j)=c(j,i+nres)
10873           ddc(j)=dc(j,i)
10874           ddx(j)=dc(j,i+nres)
10875           do k=1,3
10876             dcnorm_safe(k)=dc_norm(k,i)
10877             dxnorm_safe(k)=dc_norm(k,i+nres)
10878           enddo
10879         enddo
10880         do j=1,3
10881           dc(j,i)=ddc(j)+aincr
10882           call chainbuild_cart
10883 #ifdef MPI
10884 ! Broadcast the order to compute internal coordinates to the slaves.
10885 !          if (nfgtasks.gt.1)
10886 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10887 #endif
10888 !          call int_from_cart1(.false.)
10889           if (.not.split_ene) then
10890             call etotal(energia1)
10891             etot1=energia1(0)
10892           else
10893 !- split gradient
10894             call etotal_long(energia1)
10895             etot11=energia1(0)
10896             call etotal_short(energia1)
10897             etot12=energia1(0)
10898 !            write (iout,*) "etot11",etot11," etot12",etot12
10899           endif
10900 !- end split gradient
10901 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10902           dc(j,i)=ddc(j)-aincr
10903           call chainbuild_cart
10904 !          call int_from_cart1(.false.)
10905           if (.not.split_ene) then
10906             call etotal(energia1)
10907             etot2=energia1(0)
10908             ggg(j)=(etot1-etot2)/(2*aincr)
10909           else
10910 !- split gradient
10911             call etotal_long(energia1)
10912             etot21=energia1(0)
10913             ggg(j)=(etot11-etot21)/(2*aincr)
10914             call etotal_short(energia1)
10915             etot22=energia1(0)
10916             ggg1(j)=(etot12-etot22)/(2*aincr)
10917 !- end split gradient
10918 !            write (iout,*) "etot21",etot21," etot22",etot22
10919           endif
10920 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10921           dc(j,i)=ddc(j)
10922           call chainbuild_cart
10923         enddo
10924         do j=1,3
10925           dc(j,i+nres)=ddx(j)+aincr
10926           call chainbuild_cart
10927 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10928 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10929 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10930 !          write (iout,*) "dxnormnorm",dsqrt(
10931 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10932 !          write (iout,*) "dxnormnormsafe",dsqrt(
10933 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10934 !          write (iout,*)
10935           if (.not.split_ene) then
10936             call etotal(energia1)
10937             etot1=energia1(0)
10938           else
10939 !- split gradient
10940             call etotal_long(energia1)
10941             etot11=energia1(0)
10942             call etotal_short(energia1)
10943             etot12=energia1(0)
10944           endif
10945 !- end split gradient
10946 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10947           dc(j,i+nres)=ddx(j)-aincr
10948           call chainbuild_cart
10949 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10950 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10951 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10952 !          write (iout,*)
10953 !          write (iout,*) "dxnormnorm",dsqrt(
10954 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10955 !          write (iout,*) "dxnormnormsafe",dsqrt(
10956 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10957           if (.not.split_ene) then
10958             call etotal(energia1)
10959             etot2=energia1(0)
10960             ggg(j+3)=(etot1-etot2)/(2*aincr)
10961           else
10962 !- split gradient
10963             call etotal_long(energia1)
10964             etot21=energia1(0)
10965             ggg(j+3)=(etot11-etot21)/(2*aincr)
10966             call etotal_short(energia1)
10967             etot22=energia1(0)
10968             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10969 !- end split gradient
10970           endif
10971 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10972           dc(j,i+nres)=ddx(j)
10973           call chainbuild_cart
10974         enddo
10975         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10976          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10977         if (split_ene) then
10978           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10979          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10980          k=1,6)
10981          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10982          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10983          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10984         endif
10985       enddo
10986       return
10987       end subroutine check_ecartint
10988 #endif
10989 !-----------------------------------------------------------------------------
10990       subroutine check_eint
10991 ! Check the gradient of energy in internal coordinates.
10992 !      implicit real*8 (a-h,o-z)
10993 !      include 'DIMENSIONS'
10994 !      include 'COMMON.CHAIN'
10995 !      include 'COMMON.DERIV'
10996 !      include 'COMMON.IOUNITS'
10997 !      include 'COMMON.VAR'
10998 !      include 'COMMON.GEO'
10999       use comm_srutu
11000 !el      integer :: icall
11001 !el      common /srutu/ icall
11002       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11003       integer :: uiparm(1)
11004       real(kind=8) :: urparm(1)
11005       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11006       character(len=6) :: key
11007 !EL      external fdum
11008       integer :: i,ii,nf
11009       real(kind=8) :: xi,aincr,etot,etot1,etot2
11010       call zerograd
11011       aincr=1.0D-7
11012       print '(a)','Calling CHECK_INT.'
11013       nf=0
11014       nfl=0
11015       icg=1
11016       call geom_to_var(nvar,x)
11017       call var_to_geom(nvar,x)
11018       call chainbuild
11019       icall=1
11020       print *,'ICG=',ICG
11021       call etotal(energia)
11022       etot = energia(0)
11023 !el      call enerprint(energia)
11024       print *,'ICG=',ICG
11025 #ifdef MPL
11026       if (MyID.ne.BossID) then
11027         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11028         nf=x(nvar+1)
11029         nfl=x(nvar+2)
11030         icg=x(nvar+3)
11031       endif
11032 #endif
11033       nf=1
11034       nfl=3
11035 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11036       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11037 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11038       icall=1
11039       do i=1,nvar
11040         xi=x(i)
11041         x(i)=xi-0.5D0*aincr
11042         call var_to_geom(nvar,x)
11043         call chainbuild
11044         call etotal(energia1)
11045         etot1=energia1(0)
11046         x(i)=xi+0.5D0*aincr
11047         call var_to_geom(nvar,x)
11048         call chainbuild
11049         call etotal(energia2)
11050         etot2=energia2(0)
11051         gg(i)=(etot2-etot1)/aincr
11052         write (iout,*) i,etot1,etot2
11053         x(i)=xi
11054       enddo
11055       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11056           '     RelDiff*100% '
11057       do i=1,nvar
11058         if (i.le.nphi) then
11059           ii=i
11060           key = ' phi'
11061         else if (i.le.nphi+ntheta) then
11062           ii=i-nphi
11063           key=' theta'
11064         else if (i.le.nphi+ntheta+nside) then
11065            ii=i-(nphi+ntheta)
11066            key=' alpha'
11067         else
11068            ii=i-(nphi+ntheta+nside)
11069            key=' omega'
11070         endif
11071         write (iout,'(i3,a,i3,3(1pd16.6))') &
11072        i,key,ii,gg(i),gana(i),&
11073        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11074       enddo
11075       return
11076       end subroutine check_eint
11077 !-----------------------------------------------------------------------------
11078 ! econstr_local.F
11079 !-----------------------------------------------------------------------------
11080       subroutine Econstr_back
11081 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11082 !      implicit real*8 (a-h,o-z)
11083 !      include 'DIMENSIONS'
11084 !      include 'COMMON.CONTROL'
11085 !      include 'COMMON.VAR'
11086 !      include 'COMMON.MD'
11087       use MD_data
11088 !#ifndef LANG0
11089 !      include 'COMMON.LANGEVIN'
11090 !#else
11091 !      include 'COMMON.LANGEVIN.lang0'
11092 !#endif
11093 !      include 'COMMON.CHAIN'
11094 !      include 'COMMON.DERIV'
11095 !      include 'COMMON.GEO'
11096 !      include 'COMMON.LOCAL'
11097 !      include 'COMMON.INTERACT'
11098 !      include 'COMMON.IOUNITS'
11099 !      include 'COMMON.NAMES'
11100 !      include 'COMMON.TIME1'
11101       integer :: i,j,ii,k
11102       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11103
11104       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11105       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11106       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11107
11108       Uconst_back=0.0d0
11109       do i=1,nres
11110         dutheta(i)=0.0d0
11111         dugamma(i)=0.0d0
11112         do j=1,3
11113           duscdiff(j,i)=0.0d0
11114           duscdiffx(j,i)=0.0d0
11115         enddo
11116       enddo
11117       do i=1,nfrag_back
11118         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11119 !
11120 ! Deviations from theta angles
11121 !
11122         utheta_i=0.0d0
11123         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11124           dtheta_i=theta(j)-thetaref(j)
11125           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11126           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11127         enddo
11128         utheta(i)=utheta_i/(ii-1)
11129 !
11130 ! Deviations from gamma angles
11131 !
11132         ugamma_i=0.0d0
11133         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11134           dgamma_i=pinorm(phi(j)-phiref(j))
11135 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11136           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11137           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11138 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11139         enddo
11140         ugamma(i)=ugamma_i/(ii-2)
11141 !
11142 ! Deviations from local SC geometry
11143 !
11144         uscdiff(i)=0.0d0
11145         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11146           dxx=xxtab(j)-xxref(j)
11147           dyy=yytab(j)-yyref(j)
11148           dzz=zztab(j)-zzref(j)
11149           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11150           do k=1,3
11151             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11152              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11153              (ii-1)
11154             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11155              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11156              (ii-1)
11157             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11158            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11159             /(ii-1)
11160           enddo
11161 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11162 !     &      xxref(j),yyref(j),zzref(j)
11163         enddo
11164         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11165 !        write (iout,*) i," uscdiff",uscdiff(i)
11166 !
11167 ! Put together deviations from local geometry
11168 !
11169         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11170           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11171 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11172 !     &   " uconst_back",uconst_back
11173         utheta(i)=dsqrt(utheta(i))
11174         ugamma(i)=dsqrt(ugamma(i))
11175         uscdiff(i)=dsqrt(uscdiff(i))
11176       enddo
11177       return
11178       end subroutine Econstr_back
11179 !-----------------------------------------------------------------------------
11180 ! energy_p_new-sep_barrier.F
11181 !-----------------------------------------------------------------------------
11182       real(kind=8) function sscale(r)
11183 !      include "COMMON.SPLITELE"
11184       real(kind=8) :: r,gamm
11185       if(r.lt.r_cut-rlamb) then
11186         sscale=1.0d0
11187       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11188         gamm=(r-(r_cut-rlamb))/rlamb
11189         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11190       else
11191         sscale=0d0
11192       endif
11193       return
11194       end function sscale
11195       real(kind=8) function sscale_grad(r)
11196 !      include "COMMON.SPLITELE"
11197       real(kind=8) :: r,gamm
11198       if(r.lt.r_cut-rlamb) then
11199         sscale_grad=0.0d0
11200       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11201         gamm=(r-(r_cut-rlamb))/rlamb
11202         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11203       else
11204         sscale_grad=0d0
11205       endif
11206       return
11207       end function sscale_grad
11208
11209 !!!!!!!!!! PBCSCALE
11210       real(kind=8) function sscale_ele(r)
11211 !      include "COMMON.SPLITELE"
11212       real(kind=8) :: r,gamm
11213       if(r.lt.r_cut_ele-rlamb_ele) then
11214         sscale_ele=1.0d0
11215       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11216         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11217         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11218       else
11219         sscale_ele=0d0
11220       endif
11221       return
11222       end function sscale_ele
11223
11224       real(kind=8)  function sscagrad_ele(r)
11225       real(kind=8) :: r,gamm
11226 !      include "COMMON.SPLITELE"
11227       if(r.lt.r_cut_ele-rlamb_ele) then
11228         sscagrad_ele=0.0d0
11229       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11230         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11231         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11232       else
11233         sscagrad_ele=0.0d0
11234       endif
11235       return
11236       end function sscagrad_ele
11237 !!!!!!!!!!!!!!!
11238 !-----------------------------------------------------------------------------
11239       subroutine elj_long(evdw)
11240 !
11241 ! This subroutine calculates the interaction energy of nonbonded side chains
11242 ! assuming the LJ potential of interaction.
11243 !
11244 !      implicit real*8 (a-h,o-z)
11245 !      include 'DIMENSIONS'
11246 !      include 'COMMON.GEO'
11247 !      include 'COMMON.VAR'
11248 !      include 'COMMON.LOCAL'
11249 !      include 'COMMON.CHAIN'
11250 !      include 'COMMON.DERIV'
11251 !      include 'COMMON.INTERACT'
11252 !      include 'COMMON.TORSION'
11253 !      include 'COMMON.SBRIDGE'
11254 !      include 'COMMON.NAMES'
11255 !      include 'COMMON.IOUNITS'
11256 !      include 'COMMON.CONTACTS'
11257       real(kind=8),parameter :: accur=1.0d-10
11258       real(kind=8),dimension(3) :: gg
11259 !el local variables
11260       integer :: i,iint,j,k,itypi,itypi1,itypj
11261       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11262       real(kind=8) :: e1,e2,evdwij,evdw
11263 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11264       evdw=0.0D0
11265       do i=iatsc_s,iatsc_e
11266         itypi=itype(i)
11267         if (itypi.eq.ntyp1) cycle
11268         itypi1=itype(i+1)
11269         xi=c(1,nres+i)
11270         yi=c(2,nres+i)
11271         zi=c(3,nres+i)
11272 !
11273 ! Calculate SC interaction energy.
11274 !
11275         do iint=1,nint_gr(i)
11276 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11277 !d   &                  'iend=',iend(i,iint)
11278           do j=istart(i,iint),iend(i,iint)
11279             itypj=itype(j)
11280             if (itypj.eq.ntyp1) cycle
11281             xj=c(1,nres+j)-xi
11282             yj=c(2,nres+j)-yi
11283             zj=c(3,nres+j)-zi
11284             rij=xj*xj+yj*yj+zj*zj
11285             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11286             if (sss.lt.1.0d0) then
11287               rrij=1.0D0/rij
11288               eps0ij=eps(itypi,itypj)
11289               fac=rrij**expon2
11290               e1=fac*fac*aa(itypi,itypj)
11291               e2=fac*bb(itypi,itypj)
11292               evdwij=e1+e2
11293               evdw=evdw+(1.0d0-sss)*evdwij
11294 !
11295 ! Calculate the components of the gradient in DC and X
11296 !
11297               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11298               gg(1)=xj*fac
11299               gg(2)=yj*fac
11300               gg(3)=zj*fac
11301               do k=1,3
11302                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11303                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11304                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11305                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11306               enddo
11307             endif
11308           enddo      ! j
11309         enddo        ! iint
11310       enddo          ! i
11311       do i=1,nct
11312         do j=1,3
11313           gvdwc(j,i)=expon*gvdwc(j,i)
11314           gvdwx(j,i)=expon*gvdwx(j,i)
11315         enddo
11316       enddo
11317 !******************************************************************************
11318 !
11319 !                              N O T E !!!
11320 !
11321 ! To save time, the factor of EXPON has been extracted from ALL components
11322 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11323 ! use!
11324 !
11325 !******************************************************************************
11326       return
11327       end subroutine elj_long
11328 !-----------------------------------------------------------------------------
11329       subroutine elj_short(evdw)
11330 !
11331 ! This subroutine calculates the interaction energy of nonbonded side chains
11332 ! assuming the LJ potential of interaction.
11333 !
11334 !      implicit real*8 (a-h,o-z)
11335 !      include 'DIMENSIONS'
11336 !      include 'COMMON.GEO'
11337 !      include 'COMMON.VAR'
11338 !      include 'COMMON.LOCAL'
11339 !      include 'COMMON.CHAIN'
11340 !      include 'COMMON.DERIV'
11341 !      include 'COMMON.INTERACT'
11342 !      include 'COMMON.TORSION'
11343 !      include 'COMMON.SBRIDGE'
11344 !      include 'COMMON.NAMES'
11345 !      include 'COMMON.IOUNITS'
11346 !      include 'COMMON.CONTACTS'
11347       real(kind=8),parameter :: accur=1.0d-10
11348       real(kind=8),dimension(3) :: gg
11349 !el local variables
11350       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11351       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11352       real(kind=8) :: e1,e2,evdwij,evdw
11353 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11354       evdw=0.0D0
11355       do i=iatsc_s,iatsc_e
11356         itypi=itype(i)
11357         if (itypi.eq.ntyp1) cycle
11358         itypi1=itype(i+1)
11359         xi=c(1,nres+i)
11360         yi=c(2,nres+i)
11361         zi=c(3,nres+i)
11362 ! Change 12/1/95
11363         num_conti=0
11364 !
11365 ! Calculate SC interaction energy.
11366 !
11367         do iint=1,nint_gr(i)
11368 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11369 !d   &                  'iend=',iend(i,iint)
11370           do j=istart(i,iint),iend(i,iint)
11371             itypj=itype(j)
11372             if (itypj.eq.ntyp1) cycle
11373             xj=c(1,nres+j)-xi
11374             yj=c(2,nres+j)-yi
11375             zj=c(3,nres+j)-zi
11376 ! Change 12/1/95 to calculate four-body interactions
11377             rij=xj*xj+yj*yj+zj*zj
11378             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11379             if (sss.gt.0.0d0) then
11380               rrij=1.0D0/rij
11381               eps0ij=eps(itypi,itypj)
11382               fac=rrij**expon2
11383               e1=fac*fac*aa(itypi,itypj)
11384               e2=fac*bb(itypi,itypj)
11385               evdwij=e1+e2
11386               evdw=evdw+sss*evdwij
11387 !
11388 ! Calculate the components of the gradient in DC and X
11389 !
11390               fac=-rrij*(e1+evdwij)*sss
11391               gg(1)=xj*fac
11392               gg(2)=yj*fac
11393               gg(3)=zj*fac
11394               do k=1,3
11395                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11396                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11397                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11398                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11399               enddo
11400             endif
11401           enddo      ! j
11402         enddo        ! iint
11403       enddo          ! i
11404       do i=1,nct
11405         do j=1,3
11406           gvdwc(j,i)=expon*gvdwc(j,i)
11407           gvdwx(j,i)=expon*gvdwx(j,i)
11408         enddo
11409       enddo
11410 !******************************************************************************
11411 !
11412 !                              N O T E !!!
11413 !
11414 ! To save time, the factor of EXPON has been extracted from ALL components
11415 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11416 ! use!
11417 !
11418 !******************************************************************************
11419       return
11420       end subroutine elj_short
11421 !-----------------------------------------------------------------------------
11422       subroutine eljk_long(evdw)
11423 !
11424 ! This subroutine calculates the interaction energy of nonbonded side chains
11425 ! assuming the LJK potential of interaction.
11426 !
11427 !      implicit real*8 (a-h,o-z)
11428 !      include 'DIMENSIONS'
11429 !      include 'COMMON.GEO'
11430 !      include 'COMMON.VAR'
11431 !      include 'COMMON.LOCAL'
11432 !      include 'COMMON.CHAIN'
11433 !      include 'COMMON.DERIV'
11434 !      include 'COMMON.INTERACT'
11435 !      include 'COMMON.IOUNITS'
11436 !      include 'COMMON.NAMES'
11437       real(kind=8),dimension(3) :: gg
11438       logical :: scheck
11439 !el local variables
11440       integer :: i,iint,j,k,itypi,itypi1,itypj
11441       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11442                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11443 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11444       evdw=0.0D0
11445       do i=iatsc_s,iatsc_e
11446         itypi=itype(i)
11447         if (itypi.eq.ntyp1) cycle
11448         itypi1=itype(i+1)
11449         xi=c(1,nres+i)
11450         yi=c(2,nres+i)
11451         zi=c(3,nres+i)
11452 !
11453 ! Calculate SC interaction energy.
11454 !
11455         do iint=1,nint_gr(i)
11456           do j=istart(i,iint),iend(i,iint)
11457             itypj=itype(j)
11458             if (itypj.eq.ntyp1) cycle
11459             xj=c(1,nres+j)-xi
11460             yj=c(2,nres+j)-yi
11461             zj=c(3,nres+j)-zi
11462             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11463             fac_augm=rrij**expon
11464             e_augm=augm(itypi,itypj)*fac_augm
11465             r_inv_ij=dsqrt(rrij)
11466             rij=1.0D0/r_inv_ij
11467             sss=sscale(rij/sigma(itypi,itypj))
11468             if (sss.lt.1.0d0) then
11469               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11470               fac=r_shift_inv**expon
11471               e1=fac*fac*aa(itypi,itypj)
11472               e2=fac*bb(itypi,itypj)
11473               evdwij=e_augm+e1+e2
11474 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11475 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11476 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11477 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11478 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11479 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11480 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11481               evdw=evdw+(1.0d0-sss)*evdwij
11482 !
11483 ! Calculate the components of the gradient in DC and X
11484 !
11485               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11486               fac=fac*(1.0d0-sss)
11487               gg(1)=xj*fac
11488               gg(2)=yj*fac
11489               gg(3)=zj*fac
11490               do k=1,3
11491                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11492                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11493                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11494                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11495               enddo
11496             endif
11497           enddo      ! j
11498         enddo        ! iint
11499       enddo          ! i
11500       do i=1,nct
11501         do j=1,3
11502           gvdwc(j,i)=expon*gvdwc(j,i)
11503           gvdwx(j,i)=expon*gvdwx(j,i)
11504         enddo
11505       enddo
11506       return
11507       end subroutine eljk_long
11508 !-----------------------------------------------------------------------------
11509       subroutine eljk_short(evdw)
11510 !
11511 ! This subroutine calculates the interaction energy of nonbonded side chains
11512 ! assuming the LJK potential of interaction.
11513 !
11514 !      implicit real*8 (a-h,o-z)
11515 !      include 'DIMENSIONS'
11516 !      include 'COMMON.GEO'
11517 !      include 'COMMON.VAR'
11518 !      include 'COMMON.LOCAL'
11519 !      include 'COMMON.CHAIN'
11520 !      include 'COMMON.DERIV'
11521 !      include 'COMMON.INTERACT'
11522 !      include 'COMMON.IOUNITS'
11523 !      include 'COMMON.NAMES'
11524       real(kind=8),dimension(3) :: gg
11525       logical :: scheck
11526 !el local variables
11527       integer :: i,iint,j,k,itypi,itypi1,itypj
11528       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11529                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11530 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11531       evdw=0.0D0
11532       do i=iatsc_s,iatsc_e
11533         itypi=itype(i)
11534         if (itypi.eq.ntyp1) cycle
11535         itypi1=itype(i+1)
11536         xi=c(1,nres+i)
11537         yi=c(2,nres+i)
11538         zi=c(3,nres+i)
11539 !
11540 ! Calculate SC interaction energy.
11541 !
11542         do iint=1,nint_gr(i)
11543           do j=istart(i,iint),iend(i,iint)
11544             itypj=itype(j)
11545             if (itypj.eq.ntyp1) cycle
11546             xj=c(1,nres+j)-xi
11547             yj=c(2,nres+j)-yi
11548             zj=c(3,nres+j)-zi
11549             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11550             fac_augm=rrij**expon
11551             e_augm=augm(itypi,itypj)*fac_augm
11552             r_inv_ij=dsqrt(rrij)
11553             rij=1.0D0/r_inv_ij
11554             sss=sscale(rij/sigma(itypi,itypj))
11555             if (sss.gt.0.0d0) then
11556               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11557               fac=r_shift_inv**expon
11558               e1=fac*fac*aa(itypi,itypj)
11559               e2=fac*bb(itypi,itypj)
11560               evdwij=e_augm+e1+e2
11561 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11562 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11563 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11564 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11565 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11566 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11567 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11568               evdw=evdw+sss*evdwij
11569 !
11570 ! Calculate the components of the gradient in DC and X
11571 !
11572               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11573               fac=fac*sss
11574               gg(1)=xj*fac
11575               gg(2)=yj*fac
11576               gg(3)=zj*fac
11577               do k=1,3
11578                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11579                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11580                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11581                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11582               enddo
11583             endif
11584           enddo      ! j
11585         enddo        ! iint
11586       enddo          ! i
11587       do i=1,nct
11588         do j=1,3
11589           gvdwc(j,i)=expon*gvdwc(j,i)
11590           gvdwx(j,i)=expon*gvdwx(j,i)
11591         enddo
11592       enddo
11593       return
11594       end subroutine eljk_short
11595 !-----------------------------------------------------------------------------
11596       subroutine ebp_long(evdw)
11597 !
11598 ! This subroutine calculates the interaction energy of nonbonded side chains
11599 ! assuming the Berne-Pechukas potential of interaction.
11600 !
11601       use calc_data
11602 !      implicit real*8 (a-h,o-z)
11603 !      include 'DIMENSIONS'
11604 !      include 'COMMON.GEO'
11605 !      include 'COMMON.VAR'
11606 !      include 'COMMON.LOCAL'
11607 !      include 'COMMON.CHAIN'
11608 !      include 'COMMON.DERIV'
11609 !      include 'COMMON.NAMES'
11610 !      include 'COMMON.INTERACT'
11611 !      include 'COMMON.IOUNITS'
11612 !      include 'COMMON.CALC'
11613       use comm_srutu
11614 !el      integer :: icall
11615 !el      common /srutu/ icall
11616 !     double precision rrsave(maxdim)
11617       logical :: lprn
11618 !el local variables
11619       integer :: iint,itypi,itypi1,itypj
11620       real(kind=8) :: rrij,xi,yi,zi,fac
11621       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11622       evdw=0.0D0
11623 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11624       evdw=0.0D0
11625 !     if (icall.eq.0) then
11626 !       lprn=.true.
11627 !     else
11628         lprn=.false.
11629 !     endif
11630 !el      ind=0
11631       do i=iatsc_s,iatsc_e
11632         itypi=itype(i)
11633         if (itypi.eq.ntyp1) cycle
11634         itypi1=itype(i+1)
11635         xi=c(1,nres+i)
11636         yi=c(2,nres+i)
11637         zi=c(3,nres+i)
11638         dxi=dc_norm(1,nres+i)
11639         dyi=dc_norm(2,nres+i)
11640         dzi=dc_norm(3,nres+i)
11641 !        dsci_inv=dsc_inv(itypi)
11642         dsci_inv=vbld_inv(i+nres)
11643 !
11644 ! Calculate SC interaction energy.
11645 !
11646         do iint=1,nint_gr(i)
11647           do j=istart(i,iint),iend(i,iint)
11648 !el            ind=ind+1
11649             itypj=itype(j)
11650             if (itypj.eq.ntyp1) cycle
11651 !            dscj_inv=dsc_inv(itypj)
11652             dscj_inv=vbld_inv(j+nres)
11653             chi1=chi(itypi,itypj)
11654             chi2=chi(itypj,itypi)
11655             chi12=chi1*chi2
11656             chip1=chip(itypi)
11657             chip2=chip(itypj)
11658             chip12=chip1*chip2
11659             alf1=alp(itypi)
11660             alf2=alp(itypj)
11661             alf12=0.5D0*(alf1+alf2)
11662             xj=c(1,nres+j)-xi
11663             yj=c(2,nres+j)-yi
11664             zj=c(3,nres+j)-zi
11665             dxj=dc_norm(1,nres+j)
11666             dyj=dc_norm(2,nres+j)
11667             dzj=dc_norm(3,nres+j)
11668             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11669             rij=dsqrt(rrij)
11670             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11671
11672             if (sss.lt.1.0d0) then
11673
11674 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11675               call sc_angular
11676 ! Calculate whole angle-dependent part of epsilon and contributions
11677 ! to its derivatives
11678               fac=(rrij*sigsq)**expon2
11679               e1=fac*fac*aa(itypi,itypj)
11680               e2=fac*bb(itypi,itypj)
11681               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11682               eps2der=evdwij*eps3rt
11683               eps3der=evdwij*eps2rt
11684               evdwij=evdwij*eps2rt*eps3rt
11685               evdw=evdw+evdwij*(1.0d0-sss)
11686               if (lprn) then
11687               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11688               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11689 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11690 !d     &          restyp(itypi),i,restyp(itypj),j,
11691 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11692 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11693 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11694 !d     &          evdwij
11695               endif
11696 ! Calculate gradient components.
11697               e1=e1*eps1*eps2rt**2*eps3rt**2
11698               fac=-expon*(e1+evdwij)
11699               sigder=fac/sigsq
11700               fac=rrij*fac
11701 ! Calculate radial part of the gradient
11702               gg(1)=xj*fac
11703               gg(2)=yj*fac
11704               gg(3)=zj*fac
11705 ! Calculate the angular part of the gradient and sum add the contributions
11706 ! to the appropriate components of the Cartesian gradient.
11707               call sc_grad_scale(1.0d0-sss)
11708             endif
11709           enddo      ! j
11710         enddo        ! iint
11711       enddo          ! i
11712 !     stop
11713       return
11714       end subroutine ebp_long
11715 !-----------------------------------------------------------------------------
11716       subroutine ebp_short(evdw)
11717 !
11718 ! This subroutine calculates the interaction energy of nonbonded side chains
11719 ! assuming the Berne-Pechukas potential of interaction.
11720 !
11721       use calc_data
11722 !      implicit real*8 (a-h,o-z)
11723 !      include 'DIMENSIONS'
11724 !      include 'COMMON.GEO'
11725 !      include 'COMMON.VAR'
11726 !      include 'COMMON.LOCAL'
11727 !      include 'COMMON.CHAIN'
11728 !      include 'COMMON.DERIV'
11729 !      include 'COMMON.NAMES'
11730 !      include 'COMMON.INTERACT'
11731 !      include 'COMMON.IOUNITS'
11732 !      include 'COMMON.CALC'
11733       use comm_srutu
11734 !el      integer :: icall
11735 !el      common /srutu/ icall
11736 !     double precision rrsave(maxdim)
11737       logical :: lprn
11738 !el local variables
11739       integer :: iint,itypi,itypi1,itypj
11740       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11741       real(kind=8) :: sss,e1,e2,evdw
11742       evdw=0.0D0
11743 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11744       evdw=0.0D0
11745 !     if (icall.eq.0) then
11746 !       lprn=.true.
11747 !     else
11748         lprn=.false.
11749 !     endif
11750 !el      ind=0
11751       do i=iatsc_s,iatsc_e
11752         itypi=itype(i)
11753         if (itypi.eq.ntyp1) cycle
11754         itypi1=itype(i+1)
11755         xi=c(1,nres+i)
11756         yi=c(2,nres+i)
11757         zi=c(3,nres+i)
11758         dxi=dc_norm(1,nres+i)
11759         dyi=dc_norm(2,nres+i)
11760         dzi=dc_norm(3,nres+i)
11761 !        dsci_inv=dsc_inv(itypi)
11762         dsci_inv=vbld_inv(i+nres)
11763 !
11764 ! Calculate SC interaction energy.
11765 !
11766         do iint=1,nint_gr(i)
11767           do j=istart(i,iint),iend(i,iint)
11768 !el            ind=ind+1
11769             itypj=itype(j)
11770             if (itypj.eq.ntyp1) cycle
11771 !            dscj_inv=dsc_inv(itypj)
11772             dscj_inv=vbld_inv(j+nres)
11773             chi1=chi(itypi,itypj)
11774             chi2=chi(itypj,itypi)
11775             chi12=chi1*chi2
11776             chip1=chip(itypi)
11777             chip2=chip(itypj)
11778             chip12=chip1*chip2
11779             alf1=alp(itypi)
11780             alf2=alp(itypj)
11781             alf12=0.5D0*(alf1+alf2)
11782             xj=c(1,nres+j)-xi
11783             yj=c(2,nres+j)-yi
11784             zj=c(3,nres+j)-zi
11785             dxj=dc_norm(1,nres+j)
11786             dyj=dc_norm(2,nres+j)
11787             dzj=dc_norm(3,nres+j)
11788             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11789             rij=dsqrt(rrij)
11790             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11791
11792             if (sss.gt.0.0d0) then
11793
11794 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11795               call sc_angular
11796 ! Calculate whole angle-dependent part of epsilon and contributions
11797 ! to its derivatives
11798               fac=(rrij*sigsq)**expon2
11799               e1=fac*fac*aa(itypi,itypj)
11800               e2=fac*bb(itypi,itypj)
11801               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11802               eps2der=evdwij*eps3rt
11803               eps3der=evdwij*eps2rt
11804               evdwij=evdwij*eps2rt*eps3rt
11805               evdw=evdw+evdwij*sss
11806               if (lprn) then
11807               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11808               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11809 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11810 !d     &          restyp(itypi),i,restyp(itypj),j,
11811 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11812 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11813 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11814 !d     &          evdwij
11815               endif
11816 ! Calculate gradient components.
11817               e1=e1*eps1*eps2rt**2*eps3rt**2
11818               fac=-expon*(e1+evdwij)
11819               sigder=fac/sigsq
11820               fac=rrij*fac
11821 ! Calculate radial part of the gradient
11822               gg(1)=xj*fac
11823               gg(2)=yj*fac
11824               gg(3)=zj*fac
11825 ! Calculate the angular part of the gradient and sum add the contributions
11826 ! to the appropriate components of the Cartesian gradient.
11827               call sc_grad_scale(sss)
11828             endif
11829           enddo      ! j
11830         enddo        ! iint
11831       enddo          ! i
11832 !     stop
11833       return
11834       end subroutine ebp_short
11835 !-----------------------------------------------------------------------------
11836       subroutine egb_long(evdw)
11837 !
11838 ! This subroutine calculates the interaction energy of nonbonded side chains
11839 ! assuming the Gay-Berne potential of interaction.
11840 !
11841       use calc_data
11842 !      implicit real*8 (a-h,o-z)
11843 !      include 'DIMENSIONS'
11844 !      include 'COMMON.GEO'
11845 !      include 'COMMON.VAR'
11846 !      include 'COMMON.LOCAL'
11847 !      include 'COMMON.CHAIN'
11848 !      include 'COMMON.DERIV'
11849 !      include 'COMMON.NAMES'
11850 !      include 'COMMON.INTERACT'
11851 !      include 'COMMON.IOUNITS'
11852 !      include 'COMMON.CALC'
11853 !      include 'COMMON.CONTROL'
11854       logical :: lprn
11855 !el local variables
11856       integer :: iint,itypi,itypi1,itypj,subchap
11857       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11858       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11859       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11860                     dist_temp, dist_init
11861
11862       evdw=0.0D0
11863 !cccc      energy_dec=.false.
11864 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11865       evdw=0.0D0
11866       lprn=.false.
11867 !     if (icall.eq.0) lprn=.false.
11868 !el      ind=0
11869       do i=iatsc_s,iatsc_e
11870         itypi=itype(i)
11871         if (itypi.eq.ntyp1) cycle
11872         itypi1=itype(i+1)
11873         xi=c(1,nres+i)
11874         yi=c(2,nres+i)
11875         zi=c(3,nres+i)
11876           xi=mod(xi,boxxsize)
11877           if (xi.lt.0) xi=xi+boxxsize
11878           yi=mod(yi,boxysize)
11879           if (yi.lt.0) yi=yi+boxysize
11880           zi=mod(zi,boxzsize)
11881           if (zi.lt.0) zi=zi+boxzsize
11882         dxi=dc_norm(1,nres+i)
11883         dyi=dc_norm(2,nres+i)
11884         dzi=dc_norm(3,nres+i)
11885 !        dsci_inv=dsc_inv(itypi)
11886         dsci_inv=vbld_inv(i+nres)
11887 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11888 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11889 !
11890 ! Calculate SC interaction energy.
11891 !
11892         do iint=1,nint_gr(i)
11893           do j=istart(i,iint),iend(i,iint)
11894 !el            ind=ind+1
11895             itypj=itype(j)
11896             if (itypj.eq.ntyp1) cycle
11897 !            dscj_inv=dsc_inv(itypj)
11898             dscj_inv=vbld_inv(j+nres)
11899 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11900 !     &       1.0d0/vbld(j+nres)
11901 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11902             sig0ij=sigma(itypi,itypj)
11903             chi1=chi(itypi,itypj)
11904             chi2=chi(itypj,itypi)
11905             chi12=chi1*chi2
11906             chip1=chip(itypi)
11907             chip2=chip(itypj)
11908             chip12=chip1*chip2
11909             alf1=alp(itypi)
11910             alf2=alp(itypj)
11911             alf12=0.5D0*(alf1+alf2)
11912             xj=c(1,nres+j)
11913             yj=c(2,nres+j)
11914             zj=c(3,nres+j)
11915 ! Searching for nearest neighbour
11916           xj=mod(xj,boxxsize)
11917           if (xj.lt.0) xj=xj+boxxsize
11918           yj=mod(yj,boxysize)
11919           if (yj.lt.0) yj=yj+boxysize
11920           zj=mod(zj,boxzsize)
11921           if (zj.lt.0) zj=zj+boxzsize
11922           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11923           xj_safe=xj
11924           yj_safe=yj
11925           zj_safe=zj
11926           subchap=0
11927           do xshift=-1,1
11928           do yshift=-1,1
11929           do zshift=-1,1
11930           xj=xj_safe+xshift*boxxsize
11931           yj=yj_safe+yshift*boxysize
11932           zj=zj_safe+zshift*boxzsize
11933           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11934           if(dist_temp.lt.dist_init) then
11935             dist_init=dist_temp
11936             xj_temp=xj
11937             yj_temp=yj
11938             zj_temp=zj
11939             subchap=1
11940           endif
11941           enddo
11942           enddo
11943           enddo
11944           if (subchap.eq.1) then
11945           xj=xj_temp-xi
11946           yj=yj_temp-yi
11947           zj=zj_temp-zi
11948           else
11949           xj=xj_safe-xi
11950           yj=yj_safe-yi
11951           zj=zj_safe-zi
11952           endif
11953
11954             dxj=dc_norm(1,nres+j)
11955             dyj=dc_norm(2,nres+j)
11956             dzj=dc_norm(3,nres+j)
11957             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11958             rij=dsqrt(rrij)
11959             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11960             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11961             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11962             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11963             if (sss_ele_cut.le.0.0) cycle
11964             if (sss.lt.1.0d0) then
11965
11966 ! Calculate angle-dependent terms of energy and contributions to their
11967 ! derivatives.
11968               call sc_angular
11969               sigsq=1.0D0/sigsq
11970               sig=sig0ij*dsqrt(sigsq)
11971               rij_shift=1.0D0/rij-sig+sig0ij
11972 ! for diagnostics; uncomment
11973 !              rij_shift=1.2*sig0ij
11974 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11975               if (rij_shift.le.0.0D0) then
11976                 evdw=1.0D20
11977 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11978 !d     &          restyp(itypi),i,restyp(itypj),j,
11979 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11980                 return
11981               endif
11982               sigder=-sig*sigsq
11983 !---------------------------------------------------------------
11984               rij_shift=1.0D0/rij_shift
11985               fac=rij_shift**expon
11986               e1=fac*fac*aa(itypi,itypj)
11987               e2=fac*bb(itypi,itypj)
11988               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11989               eps2der=evdwij*eps3rt
11990               eps3der=evdwij*eps2rt
11991 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11992 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11993               evdwij=evdwij*eps2rt*eps3rt
11994               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11995               if (lprn) then
11996               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11997               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11998               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11999                 restyp(itypi),i,restyp(itypj),j,&
12000                 epsi,sigm,chi1,chi2,chip1,chip2,&
12001                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12002                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12003                 evdwij
12004               endif
12005
12006               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12007                               'evdw',i,j,evdwij
12008 !              if (energy_dec) write (iout,*) &
12009 !                              'evdw',i,j,evdwij,"egb_long"
12010
12011 ! Calculate gradient components.
12012               e1=e1*eps1*eps2rt**2*eps3rt**2
12013               fac=-expon*(e1+evdwij)*rij_shift
12014               sigder=fac*sigder
12015               fac=rij*fac
12016               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12017             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
12018             /sigmaii(itypi,itypj))
12019 !              fac=0.0d0
12020 ! Calculate the radial part of the gradient
12021               gg(1)=xj*fac
12022               gg(2)=yj*fac
12023               gg(3)=zj*fac
12024 ! Calculate angular part of the gradient.
12025               call sc_grad_scale(1.0d0-sss)
12026             endif
12027           enddo      ! j
12028         enddo        ! iint
12029       enddo          ! i
12030 !      write (iout,*) "Number of loop steps in EGB:",ind
12031 !ccc      energy_dec=.false.
12032       return
12033       end subroutine egb_long
12034 !-----------------------------------------------------------------------------
12035       subroutine egb_short(evdw)
12036 !
12037 ! This subroutine calculates the interaction energy of nonbonded side chains
12038 ! assuming the Gay-Berne potential of interaction.
12039 !
12040       use calc_data
12041 !      implicit real*8 (a-h,o-z)
12042 !      include 'DIMENSIONS'
12043 !      include 'COMMON.GEO'
12044 !      include 'COMMON.VAR'
12045 !      include 'COMMON.LOCAL'
12046 !      include 'COMMON.CHAIN'
12047 !      include 'COMMON.DERIV'
12048 !      include 'COMMON.NAMES'
12049 !      include 'COMMON.INTERACT'
12050 !      include 'COMMON.IOUNITS'
12051 !      include 'COMMON.CALC'
12052 !      include 'COMMON.CONTROL'
12053       logical :: lprn
12054 !el local variables
12055       integer :: iint,itypi,itypi1,itypj,subchap
12056       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
12057       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
12058       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12059                     dist_temp, dist_init
12060       evdw=0.0D0
12061 !cccc      energy_dec=.false.
12062 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12063       evdw=0.0D0
12064       lprn=.false.
12065 !     if (icall.eq.0) lprn=.false.
12066 !el      ind=0
12067       do i=iatsc_s,iatsc_e
12068         itypi=itype(i)
12069         if (itypi.eq.ntyp1) cycle
12070         itypi1=itype(i+1)
12071         xi=c(1,nres+i)
12072         yi=c(2,nres+i)
12073         zi=c(3,nres+i)
12074           xi=mod(xi,boxxsize)
12075           if (xi.lt.0) xi=xi+boxxsize
12076           yi=mod(yi,boxysize)
12077           if (yi.lt.0) yi=yi+boxysize
12078           zi=mod(zi,boxzsize)
12079           if (zi.lt.0) zi=zi+boxzsize
12080         dxi=dc_norm(1,nres+i)
12081         dyi=dc_norm(2,nres+i)
12082         dzi=dc_norm(3,nres+i)
12083 !        dsci_inv=dsc_inv(itypi)
12084         dsci_inv=vbld_inv(i+nres)
12085
12086         dxi=dc_norm(1,nres+i)
12087         dyi=dc_norm(2,nres+i)
12088         dzi=dc_norm(3,nres+i)
12089 !        dsci_inv=dsc_inv(itypi)
12090         dsci_inv=vbld_inv(i+nres)
12091 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12092 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12093 !
12094 ! Calculate SC interaction energy.
12095 !
12096         do iint=1,nint_gr(i)
12097           do j=istart(i,iint),iend(i,iint)
12098 !el            ind=ind+1
12099             itypj=itype(j)
12100             if (itypj.eq.ntyp1) cycle
12101 !            dscj_inv=dsc_inv(itypj)
12102             dscj_inv=vbld_inv(j+nres)
12103 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12104 !     &       1.0d0/vbld(j+nres)
12105 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12106             sig0ij=sigma(itypi,itypj)
12107             chi1=chi(itypi,itypj)
12108             chi2=chi(itypj,itypi)
12109             chi12=chi1*chi2
12110             chip1=chip(itypi)
12111             chip2=chip(itypj)
12112             chip12=chip1*chip2
12113             alf1=alp(itypi)
12114             alf2=alp(itypj)
12115             alf12=0.5D0*(alf1+alf2)
12116 !            xj=c(1,nres+j)-xi
12117 !            yj=c(2,nres+j)-yi
12118 !            zj=c(3,nres+j)-zi
12119             xj=c(1,nres+j)
12120             yj=c(2,nres+j)
12121             zj=c(3,nres+j)
12122 ! Searching for nearest neighbour
12123           xj=mod(xj,boxxsize)
12124           if (xj.lt.0) xj=xj+boxxsize
12125           yj=mod(yj,boxysize)
12126           if (yj.lt.0) yj=yj+boxysize
12127           zj=mod(zj,boxzsize)
12128           if (zj.lt.0) zj=zj+boxzsize
12129           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12130           xj_safe=xj
12131           yj_safe=yj
12132           zj_safe=zj
12133           subchap=0
12134           do xshift=-1,1
12135           do yshift=-1,1
12136           do zshift=-1,1
12137           xj=xj_safe+xshift*boxxsize
12138           yj=yj_safe+yshift*boxysize
12139           zj=zj_safe+zshift*boxzsize
12140           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12141           if(dist_temp.lt.dist_init) then
12142             dist_init=dist_temp
12143             xj_temp=xj
12144             yj_temp=yj
12145             zj_temp=zj
12146             subchap=1
12147           endif
12148           enddo
12149           enddo
12150           enddo
12151           if (subchap.eq.1) then
12152           xj=xj_temp-xi
12153           yj=yj_temp-yi
12154           zj=zj_temp-zi
12155           else
12156           xj=xj_safe-xi
12157           yj=yj_safe-yi
12158           zj=zj_safe-zi
12159           endif
12160
12161             dxj=dc_norm(1,nres+j)
12162             dyj=dc_norm(2,nres+j)
12163             dzj=dc_norm(3,nres+j)
12164             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12165             rij=dsqrt(rrij)
12166             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12167             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12168             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12169             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12170             if (sss_ele_cut.le.0.0) cycle
12171
12172             if (sss.gt.0.0d0) then
12173
12174 ! Calculate angle-dependent terms of energy and contributions to their
12175 ! derivatives.
12176               call sc_angular
12177               sigsq=1.0D0/sigsq
12178               sig=sig0ij*dsqrt(sigsq)
12179               rij_shift=1.0D0/rij-sig+sig0ij
12180 ! for diagnostics; uncomment
12181 !              rij_shift=1.2*sig0ij
12182 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12183               if (rij_shift.le.0.0D0) then
12184                 evdw=1.0D20
12185 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12186 !d     &          restyp(itypi),i,restyp(itypj),j,
12187 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12188                 return
12189               endif
12190               sigder=-sig*sigsq
12191 !---------------------------------------------------------------
12192               rij_shift=1.0D0/rij_shift
12193               fac=rij_shift**expon
12194               e1=fac*fac*aa(itypi,itypj)
12195               e2=fac*bb(itypi,itypj)
12196               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12197               eps2der=evdwij*eps3rt
12198               eps3der=evdwij*eps2rt
12199 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12200 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12201               evdwij=evdwij*eps2rt*eps3rt
12202               evdw=evdw+evdwij*sss*sss_ele_cut
12203               if (lprn) then
12204               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12205               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12206               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12207                 restyp(itypi),i,restyp(itypj),j,&
12208                 epsi,sigm,chi1,chi2,chip1,chip2,&
12209                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12210                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12211                 evdwij
12212               endif
12213
12214               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12215                               'evdw',i,j,evdwij
12216 !              if (energy_dec) write (iout,*) &
12217 !                              'evdw',i,j,evdwij,"egb_short"
12218
12219 ! Calculate gradient components.
12220               e1=e1*eps1*eps2rt**2*eps3rt**2
12221               fac=-expon*(e1+evdwij)*rij_shift
12222               sigder=fac*sigder
12223               fac=rij*fac
12224               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12225             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12226             /sigmaii(itypi,itypj))
12227
12228 !              fac=0.0d0
12229 ! Calculate the radial part of the gradient
12230               gg(1)=xj*fac
12231               gg(2)=yj*fac
12232               gg(3)=zj*fac
12233 ! Calculate angular part of the gradient.
12234               call sc_grad_scale(sss)
12235             endif
12236           enddo      ! j
12237         enddo        ! iint
12238       enddo          ! i
12239 !      write (iout,*) "Number of loop steps in EGB:",ind
12240 !ccc      energy_dec=.false.
12241       return
12242       end subroutine egb_short
12243 !-----------------------------------------------------------------------------
12244       subroutine egbv_long(evdw)
12245 !
12246 ! This subroutine calculates the interaction energy of nonbonded side chains
12247 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12248 !
12249       use calc_data
12250 !      implicit real*8 (a-h,o-z)
12251 !      include 'DIMENSIONS'
12252 !      include 'COMMON.GEO'
12253 !      include 'COMMON.VAR'
12254 !      include 'COMMON.LOCAL'
12255 !      include 'COMMON.CHAIN'
12256 !      include 'COMMON.DERIV'
12257 !      include 'COMMON.NAMES'
12258 !      include 'COMMON.INTERACT'
12259 !      include 'COMMON.IOUNITS'
12260 !      include 'COMMON.CALC'
12261       use comm_srutu
12262 !el      integer :: icall
12263 !el      common /srutu/ icall
12264       logical :: lprn
12265 !el local variables
12266       integer :: iint,itypi,itypi1,itypj
12267       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12268       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12269       evdw=0.0D0
12270 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12271       evdw=0.0D0
12272       lprn=.false.
12273 !     if (icall.eq.0) lprn=.true.
12274 !el      ind=0
12275       do i=iatsc_s,iatsc_e
12276         itypi=itype(i)
12277         if (itypi.eq.ntyp1) cycle
12278         itypi1=itype(i+1)
12279         xi=c(1,nres+i)
12280         yi=c(2,nres+i)
12281         zi=c(3,nres+i)
12282         dxi=dc_norm(1,nres+i)
12283         dyi=dc_norm(2,nres+i)
12284         dzi=dc_norm(3,nres+i)
12285 !        dsci_inv=dsc_inv(itypi)
12286         dsci_inv=vbld_inv(i+nres)
12287 !
12288 ! Calculate SC interaction energy.
12289 !
12290         do iint=1,nint_gr(i)
12291           do j=istart(i,iint),iend(i,iint)
12292 !el            ind=ind+1
12293             itypj=itype(j)
12294             if (itypj.eq.ntyp1) cycle
12295 !            dscj_inv=dsc_inv(itypj)
12296             dscj_inv=vbld_inv(j+nres)
12297             sig0ij=sigma(itypi,itypj)
12298             r0ij=r0(itypi,itypj)
12299             chi1=chi(itypi,itypj)
12300             chi2=chi(itypj,itypi)
12301             chi12=chi1*chi2
12302             chip1=chip(itypi)
12303             chip2=chip(itypj)
12304             chip12=chip1*chip2
12305             alf1=alp(itypi)
12306             alf2=alp(itypj)
12307             alf12=0.5D0*(alf1+alf2)
12308             xj=c(1,nres+j)-xi
12309             yj=c(2,nres+j)-yi
12310             zj=c(3,nres+j)-zi
12311             dxj=dc_norm(1,nres+j)
12312             dyj=dc_norm(2,nres+j)
12313             dzj=dc_norm(3,nres+j)
12314             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12315             rij=dsqrt(rrij)
12316
12317             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12318
12319             if (sss.lt.1.0d0) then
12320
12321 ! Calculate angle-dependent terms of energy and contributions to their
12322 ! derivatives.
12323               call sc_angular
12324               sigsq=1.0D0/sigsq
12325               sig=sig0ij*dsqrt(sigsq)
12326               rij_shift=1.0D0/rij-sig+r0ij
12327 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12328               if (rij_shift.le.0.0D0) then
12329                 evdw=1.0D20
12330                 return
12331               endif
12332               sigder=-sig*sigsq
12333 !---------------------------------------------------------------
12334               rij_shift=1.0D0/rij_shift
12335               fac=rij_shift**expon
12336               e1=fac*fac*aa(itypi,itypj)
12337               e2=fac*bb(itypi,itypj)
12338               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12339               eps2der=evdwij*eps3rt
12340               eps3der=evdwij*eps2rt
12341               fac_augm=rrij**expon
12342               e_augm=augm(itypi,itypj)*fac_augm
12343               evdwij=evdwij*eps2rt*eps3rt
12344               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12345               if (lprn) then
12346               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12347               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12348               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12349                 restyp(itypi),i,restyp(itypj),j,&
12350                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12351                 chi1,chi2,chip1,chip2,&
12352                 eps1,eps2rt**2,eps3rt**2,&
12353                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12354                 evdwij+e_augm
12355               endif
12356 ! Calculate gradient components.
12357               e1=e1*eps1*eps2rt**2*eps3rt**2
12358               fac=-expon*(e1+evdwij)*rij_shift
12359               sigder=fac*sigder
12360               fac=rij*fac-2*expon*rrij*e_augm
12361 ! Calculate the radial part of the gradient
12362               gg(1)=xj*fac
12363               gg(2)=yj*fac
12364               gg(3)=zj*fac
12365 ! Calculate angular part of the gradient.
12366               call sc_grad_scale(1.0d0-sss)
12367             endif
12368           enddo      ! j
12369         enddo        ! iint
12370       enddo          ! i
12371       end subroutine egbv_long
12372 !-----------------------------------------------------------------------------
12373       subroutine egbv_short(evdw)
12374 !
12375 ! This subroutine calculates the interaction energy of nonbonded side chains
12376 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12377 !
12378       use calc_data
12379 !      implicit real*8 (a-h,o-z)
12380 !      include 'DIMENSIONS'
12381 !      include 'COMMON.GEO'
12382 !      include 'COMMON.VAR'
12383 !      include 'COMMON.LOCAL'
12384 !      include 'COMMON.CHAIN'
12385 !      include 'COMMON.DERIV'
12386 !      include 'COMMON.NAMES'
12387 !      include 'COMMON.INTERACT'
12388 !      include 'COMMON.IOUNITS'
12389 !      include 'COMMON.CALC'
12390       use comm_srutu
12391 !el      integer :: icall
12392 !el      common /srutu/ icall
12393       logical :: lprn
12394 !el local variables
12395       integer :: iint,itypi,itypi1,itypj
12396       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12397       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12398       evdw=0.0D0
12399 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12400       evdw=0.0D0
12401       lprn=.false.
12402 !     if (icall.eq.0) lprn=.true.
12403 !el      ind=0
12404       do i=iatsc_s,iatsc_e
12405         itypi=itype(i)
12406         if (itypi.eq.ntyp1) cycle
12407         itypi1=itype(i+1)
12408         xi=c(1,nres+i)
12409         yi=c(2,nres+i)
12410         zi=c(3,nres+i)
12411         dxi=dc_norm(1,nres+i)
12412         dyi=dc_norm(2,nres+i)
12413         dzi=dc_norm(3,nres+i)
12414 !        dsci_inv=dsc_inv(itypi)
12415         dsci_inv=vbld_inv(i+nres)
12416 !
12417 ! Calculate SC interaction energy.
12418 !
12419         do iint=1,nint_gr(i)
12420           do j=istart(i,iint),iend(i,iint)
12421 !el            ind=ind+1
12422             itypj=itype(j)
12423             if (itypj.eq.ntyp1) cycle
12424 !            dscj_inv=dsc_inv(itypj)
12425             dscj_inv=vbld_inv(j+nres)
12426             sig0ij=sigma(itypi,itypj)
12427             r0ij=r0(itypi,itypj)
12428             chi1=chi(itypi,itypj)
12429             chi2=chi(itypj,itypi)
12430             chi12=chi1*chi2
12431             chip1=chip(itypi)
12432             chip2=chip(itypj)
12433             chip12=chip1*chip2
12434             alf1=alp(itypi)
12435             alf2=alp(itypj)
12436             alf12=0.5D0*(alf1+alf2)
12437             xj=c(1,nres+j)-xi
12438             yj=c(2,nres+j)-yi
12439             zj=c(3,nres+j)-zi
12440             dxj=dc_norm(1,nres+j)
12441             dyj=dc_norm(2,nres+j)
12442             dzj=dc_norm(3,nres+j)
12443             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12444             rij=dsqrt(rrij)
12445
12446             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12447
12448             if (sss.gt.0.0d0) then
12449
12450 ! Calculate angle-dependent terms of energy and contributions to their
12451 ! derivatives.
12452               call sc_angular
12453               sigsq=1.0D0/sigsq
12454               sig=sig0ij*dsqrt(sigsq)
12455               rij_shift=1.0D0/rij-sig+r0ij
12456 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12457               if (rij_shift.le.0.0D0) then
12458                 evdw=1.0D20
12459                 return
12460               endif
12461               sigder=-sig*sigsq
12462 !---------------------------------------------------------------
12463               rij_shift=1.0D0/rij_shift
12464               fac=rij_shift**expon
12465               e1=fac*fac*aa(itypi,itypj)
12466               e2=fac*bb(itypi,itypj)
12467               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12468               eps2der=evdwij*eps3rt
12469               eps3der=evdwij*eps2rt
12470               fac_augm=rrij**expon
12471               e_augm=augm(itypi,itypj)*fac_augm
12472               evdwij=evdwij*eps2rt*eps3rt
12473               evdw=evdw+(evdwij+e_augm)*sss
12474               if (lprn) then
12475               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12476               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12477               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12478                 restyp(itypi),i,restyp(itypj),j,&
12479                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12480                 chi1,chi2,chip1,chip2,&
12481                 eps1,eps2rt**2,eps3rt**2,&
12482                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12483                 evdwij+e_augm
12484               endif
12485 ! Calculate gradient components.
12486               e1=e1*eps1*eps2rt**2*eps3rt**2
12487               fac=-expon*(e1+evdwij)*rij_shift
12488               sigder=fac*sigder
12489               fac=rij*fac-2*expon*rrij*e_augm
12490 ! Calculate the radial part of the gradient
12491               gg(1)=xj*fac
12492               gg(2)=yj*fac
12493               gg(3)=zj*fac
12494 ! Calculate angular part of the gradient.
12495               call sc_grad_scale(sss)
12496             endif
12497           enddo      ! j
12498         enddo        ! iint
12499       enddo          ! i
12500       end subroutine egbv_short
12501 !-----------------------------------------------------------------------------
12502       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12503 !
12504 ! This subroutine calculates the average interaction energy and its gradient
12505 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12506 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12507 ! The potential depends both on the distance of peptide-group centers and on
12508 ! the orientation of the CA-CA virtual bonds.
12509 !
12510 !      implicit real*8 (a-h,o-z)
12511
12512       use comm_locel
12513 #ifdef MPI
12514       include 'mpif.h'
12515 #endif
12516 !      include 'DIMENSIONS'
12517 !      include 'COMMON.CONTROL'
12518 !      include 'COMMON.SETUP'
12519 !      include 'COMMON.IOUNITS'
12520 !      include 'COMMON.GEO'
12521 !      include 'COMMON.VAR'
12522 !      include 'COMMON.LOCAL'
12523 !      include 'COMMON.CHAIN'
12524 !      include 'COMMON.DERIV'
12525 !      include 'COMMON.INTERACT'
12526 !      include 'COMMON.CONTACTS'
12527 !      include 'COMMON.TORSION'
12528 !      include 'COMMON.VECTORS'
12529 !      include 'COMMON.FFIELD'
12530 !      include 'COMMON.TIME1'
12531       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12532       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12533       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12534 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12535       real(kind=8),dimension(4) :: muij
12536 !el      integer :: num_conti,j1,j2
12537 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12538 !el                   dz_normi,xmedi,ymedi,zmedi
12539 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12540 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12541 !el          num_conti,j1,j2
12542 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12543 #ifdef MOMENT
12544       real(kind=8) :: scal_el=1.0d0
12545 #else
12546       real(kind=8) :: scal_el=0.5d0
12547 #endif
12548 ! 12/13/98
12549 ! 13-go grudnia roku pamietnego...
12550       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12551                                              0.0d0,1.0d0,0.0d0,&
12552                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12553 !el local variables
12554       integer :: i,j,k
12555       real(kind=8) :: fac
12556       real(kind=8) :: dxj,dyj,dzj
12557       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12558
12559 !      allocate(num_cont_hb(nres)) !(maxres)
12560 !d      write(iout,*) 'In EELEC'
12561 !d      do i=1,nloctyp
12562 !d        write(iout,*) 'Type',i
12563 !d        write(iout,*) 'B1',B1(:,i)
12564 !d        write(iout,*) 'B2',B2(:,i)
12565 !d        write(iout,*) 'CC',CC(:,:,i)
12566 !d        write(iout,*) 'DD',DD(:,:,i)
12567 !d        write(iout,*) 'EE',EE(:,:,i)
12568 !d      enddo
12569 !d      call check_vecgrad
12570 !d      stop
12571       if (icheckgrad.eq.1) then
12572         do i=1,nres-1
12573           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12574           do k=1,3
12575             dc_norm(k,i)=dc(k,i)*fac
12576           enddo
12577 !          write (iout,*) 'i',i,' fac',fac
12578         enddo
12579       endif
12580       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12581           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12582           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12583 !        call vec_and_deriv
12584 #ifdef TIMING
12585         time01=MPI_Wtime()
12586 #endif
12587         call set_matrices
12588 #ifdef TIMING
12589         time_mat=time_mat+MPI_Wtime()-time01
12590 #endif
12591       endif
12592 !d      do i=1,nres-1
12593 !d        write (iout,*) 'i=',i
12594 !d        do k=1,3
12595 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12596 !d        enddo
12597 !d        do k=1,3
12598 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12599 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12600 !d        enddo
12601 !d      enddo
12602       t_eelecij=0.0d0
12603       ees=0.0D0
12604       evdw1=0.0D0
12605       eel_loc=0.0d0
12606       eello_turn3=0.0d0
12607       eello_turn4=0.0d0
12608 !el      ind=0
12609       do i=1,nres
12610         num_cont_hb(i)=0
12611       enddo
12612 !d      print '(a)','Enter EELEC'
12613 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12614 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12615 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12616       do i=1,nres
12617         gel_loc_loc(i)=0.0d0
12618         gcorr_loc(i)=0.0d0
12619       enddo
12620 !
12621 !
12622 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12623 !
12624 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12625 !
12626       do i=iturn3_start,iturn3_end
12627         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12628         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12629         dxi=dc(1,i)
12630         dyi=dc(2,i)
12631         dzi=dc(3,i)
12632         dx_normi=dc_norm(1,i)
12633         dy_normi=dc_norm(2,i)
12634         dz_normi=dc_norm(3,i)
12635         xmedi=c(1,i)+0.5d0*dxi
12636         ymedi=c(2,i)+0.5d0*dyi
12637         zmedi=c(3,i)+0.5d0*dzi
12638           xmedi=dmod(xmedi,boxxsize)
12639           if (xmedi.lt.0) xmedi=xmedi+boxxsize
12640           ymedi=dmod(ymedi,boxysize)
12641           if (ymedi.lt.0) ymedi=ymedi+boxysize
12642           zmedi=dmod(zmedi,boxzsize)
12643           if (zmedi.lt.0) zmedi=zmedi+boxzsize
12644         num_conti=0
12645         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12646         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12647         num_cont_hb(i)=num_conti
12648       enddo
12649       do i=iturn4_start,iturn4_end
12650         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12651           .or. itype(i+3).eq.ntyp1 &
12652           .or. itype(i+4).eq.ntyp1) cycle
12653         dxi=dc(1,i)
12654         dyi=dc(2,i)
12655         dzi=dc(3,i)
12656         dx_normi=dc_norm(1,i)
12657         dy_normi=dc_norm(2,i)
12658         dz_normi=dc_norm(3,i)
12659         xmedi=c(1,i)+0.5d0*dxi
12660         ymedi=c(2,i)+0.5d0*dyi
12661         zmedi=c(3,i)+0.5d0*dzi
12662           xmedi=dmod(xmedi,boxxsize)
12663           if (xmedi.lt.0) xmedi=xmedi+boxxsize
12664           ymedi=dmod(ymedi,boxysize)
12665           if (ymedi.lt.0) ymedi=ymedi+boxysize
12666           zmedi=dmod(zmedi,boxzsize)
12667           if (zmedi.lt.0) zmedi=zmedi+boxzsize
12668         num_conti=num_cont_hb(i)
12669         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12670         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12671           call eturn4(i,eello_turn4)
12672         num_cont_hb(i)=num_conti
12673       enddo   ! i
12674 !
12675 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12676 !
12677       do i=iatel_s,iatel_e
12678         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12679         dxi=dc(1,i)
12680         dyi=dc(2,i)
12681         dzi=dc(3,i)
12682         dx_normi=dc_norm(1,i)
12683         dy_normi=dc_norm(2,i)
12684         dz_normi=dc_norm(3,i)
12685         xmedi=c(1,i)+0.5d0*dxi
12686         ymedi=c(2,i)+0.5d0*dyi
12687         zmedi=c(3,i)+0.5d0*dzi
12688           xmedi=dmod(xmedi,boxxsize)
12689           if (xmedi.lt.0) xmedi=xmedi+boxxsize
12690           ymedi=dmod(ymedi,boxysize)
12691           if (ymedi.lt.0) ymedi=ymedi+boxysize
12692           zmedi=dmod(zmedi,boxzsize)
12693           if (zmedi.lt.0) zmedi=zmedi+boxzsize
12694 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12695         num_conti=num_cont_hb(i)
12696         do j=ielstart(i),ielend(i)
12697           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12698           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12699         enddo ! j
12700         num_cont_hb(i)=num_conti
12701       enddo   ! i
12702 !      write (iout,*) "Number of loop steps in EELEC:",ind
12703 !d      do i=1,nres
12704 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12705 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12706 !d      enddo
12707 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12708 !cc      eel_loc=eel_loc+eello_turn3
12709 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12710       return
12711       end subroutine eelec_scale
12712 !-----------------------------------------------------------------------------
12713       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12714 !      implicit real*8 (a-h,o-z)
12715
12716       use comm_locel
12717 !      include 'DIMENSIONS'
12718 #ifdef MPI
12719       include "mpif.h"
12720 #endif
12721 !      include 'COMMON.CONTROL'
12722 !      include 'COMMON.IOUNITS'
12723 !      include 'COMMON.GEO'
12724 !      include 'COMMON.VAR'
12725 !      include 'COMMON.LOCAL'
12726 !      include 'COMMON.CHAIN'
12727 !      include 'COMMON.DERIV'
12728 !      include 'COMMON.INTERACT'
12729 !      include 'COMMON.CONTACTS'
12730 !      include 'COMMON.TORSION'
12731 !      include 'COMMON.VECTORS'
12732 !      include 'COMMON.FFIELD'
12733 !      include 'COMMON.TIME1'
12734       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
12735       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12736       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12737 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12738       real(kind=8),dimension(4) :: muij
12739       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12740                     dist_temp, dist_init,sss_grad
12741       integer xshift,yshift,zshift
12742
12743 !el      integer :: num_conti,j1,j2
12744 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12745 !el                   dz_normi,xmedi,ymedi,zmedi
12746 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12747 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12748 !el          num_conti,j1,j2
12749 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12750 #ifdef MOMENT
12751       real(kind=8) :: scal_el=1.0d0
12752 #else
12753       real(kind=8) :: scal_el=0.5d0
12754 #endif
12755 ! 12/13/98
12756 ! 13-go grudnia roku pamietnego...
12757       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12758                                              0.0d0,1.0d0,0.0d0,&
12759                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12760 !el local variables
12761       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
12762       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12763       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12764       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12765       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12766       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12767       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12768                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12769                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12770                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12771                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12772                   ecosam,ecosbm,ecosgm,ghalf,time00
12773 !      integer :: maxconts
12774 !      maxconts = nres/4
12775 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12776 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12777 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12778 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12779 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12780 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12781 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12782 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12783 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12784 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12785 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12786 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12787 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12788
12789 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12790 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12791
12792 #ifdef MPI
12793           time00=MPI_Wtime()
12794 #endif
12795 !d      write (iout,*) "eelecij",i,j
12796 !el          ind=ind+1
12797           iteli=itel(i)
12798           itelj=itel(j)
12799           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12800           aaa=app(iteli,itelj)
12801           bbb=bpp(iteli,itelj)
12802           ael6i=ael6(iteli,itelj)
12803           ael3i=ael3(iteli,itelj)
12804           dxj=dc(1,j)
12805           dyj=dc(2,j)
12806           dzj=dc(3,j)
12807           dx_normj=dc_norm(1,j)
12808           dy_normj=dc_norm(2,j)
12809           dz_normj=dc_norm(3,j)
12810 !          xj=c(1,j)+0.5D0*dxj-xmedi
12811 !          yj=c(2,j)+0.5D0*dyj-ymedi
12812 !          zj=c(3,j)+0.5D0*dzj-zmedi
12813           xj=c(1,j)+0.5D0*dxj
12814           yj=c(2,j)+0.5D0*dyj
12815           zj=c(3,j)+0.5D0*dzj
12816           xj=mod(xj,boxxsize)
12817           if (xj.lt.0) xj=xj+boxxsize
12818           yj=mod(yj,boxysize)
12819           if (yj.lt.0) yj=yj+boxysize
12820           zj=mod(zj,boxzsize)
12821           if (zj.lt.0) zj=zj+boxzsize
12822       isubchap=0
12823       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
12824       xj_safe=xj
12825       yj_safe=yj
12826       zj_safe=zj
12827       do xshift=-1,1
12828       do yshift=-1,1
12829       do zshift=-1,1
12830           xj=xj_safe+xshift*boxxsize
12831           yj=yj_safe+yshift*boxysize
12832           zj=zj_safe+zshift*boxzsize
12833           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
12834           if(dist_temp.lt.dist_init) then
12835             dist_init=dist_temp
12836             xj_temp=xj
12837             yj_temp=yj
12838             zj_temp=zj
12839             isubchap=1
12840           endif
12841        enddo
12842        enddo
12843        enddo
12844        if (isubchap.eq.1) then
12845 !C          print *,i,j
12846           xj=xj_temp-xmedi
12847           yj=yj_temp-ymedi
12848           zj=zj_temp-zmedi
12849        else
12850           xj=xj_safe-xmedi
12851           yj=yj_safe-ymedi
12852           zj=zj_safe-zmedi
12853        endif
12854
12855           rij=xj*xj+yj*yj+zj*zj
12856           rrmij=1.0D0/rij
12857           rij=dsqrt(rij)
12858           rmij=1.0D0/rij
12859 ! For extracting the short-range part of Evdwpp
12860           sss=sscale(rij/rpp(iteli,itelj))
12861             sss_ele_cut=sscale_ele(rij)
12862             sss_ele_grad=sscagrad_ele(rij)
12863             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
12864 !             sss_ele_cut=1.0d0
12865 !             sss_ele_grad=0.0d0
12866             if (sss_ele_cut.le.0.0) go to 128
12867
12868           r3ij=rrmij*rmij
12869           r6ij=r3ij*r3ij
12870           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12871           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12872           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12873           fac=cosa-3.0D0*cosb*cosg
12874           ev1=aaa*r6ij*r6ij
12875 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12876           if (j.eq.i+2) ev1=scal_el*ev1
12877           ev2=bbb*r6ij
12878           fac3=ael6i*r6ij
12879           fac4=ael3i*r3ij
12880           evdwij=ev1+ev2
12881           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12882           el2=fac4*fac
12883           eesij=el1+el2
12884 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12885           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12886           ees=ees+eesij*sss_ele_cut
12887           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
12888 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12889 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12890 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12891 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12892
12893           if (energy_dec) then
12894               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12895               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12896           endif
12897
12898 !
12899 ! Calculate contributions to the Cartesian gradient.
12900 !
12901 #ifdef SPLITELE
12902           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
12903           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
12904           fac1=fac
12905           erij(1)=xj*rmij
12906           erij(2)=yj*rmij
12907           erij(3)=zj*rmij
12908 !
12909 ! Radial derivatives. First process both termini of the fragment (i,j)
12910 !
12911           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
12912           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
12913           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
12914 !          do k=1,3
12915 !            ghalf=0.5D0*ggg(k)
12916 !            gelc(k,i)=gelc(k,i)+ghalf
12917 !            gelc(k,j)=gelc(k,j)+ghalf
12918 !          enddo
12919 ! 9/28/08 AL Gradient compotents will be summed only at the end
12920           do k=1,3
12921             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12922             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12923           enddo
12924 !
12925 ! Loop over residues i+1 thru j-1.
12926 !
12927 !grad          do k=i+1,j-1
12928 !grad            do l=1,3
12929 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12930 !grad            enddo
12931 !grad          enddo
12932           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
12933           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
12934           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
12935           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
12936           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
12937           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
12938 !          do k=1,3
12939 !            ghalf=0.5D0*ggg(k)
12940 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12941 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12942 !          enddo
12943 ! 9/28/08 AL Gradient compotents will be summed only at the end
12944           do k=1,3
12945             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12946             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12947           enddo
12948 !
12949 ! Loop over residues i+1 thru j-1.
12950 !
12951 !grad          do k=i+1,j-1
12952 !grad            do l=1,3
12953 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12954 !grad            enddo
12955 !grad          enddo
12956 #else
12957           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
12958           facel=(el1+eesij)*sss_ele_cut
12959           fac1=fac
12960           fac=-3*rrmij*(facvdw+facvdw+facel)
12961           erij(1)=xj*rmij
12962           erij(2)=yj*rmij
12963           erij(3)=zj*rmij
12964 !
12965 ! Radial derivatives. First process both termini of the fragment (i,j)
12966 !
12967           ggg(1)=fac*xj
12968           ggg(2)=fac*yj
12969           ggg(3)=fac*zj
12970 !          do k=1,3
12971 !            ghalf=0.5D0*ggg(k)
12972 !            gelc(k,i)=gelc(k,i)+ghalf
12973 !            gelc(k,j)=gelc(k,j)+ghalf
12974 !          enddo
12975 ! 9/28/08 AL Gradient compotents will be summed only at the end
12976           do k=1,3
12977             gelc_long(k,j)=gelc(k,j)+ggg(k)
12978             gelc_long(k,i)=gelc(k,i)-ggg(k)
12979           enddo
12980 !
12981 ! Loop over residues i+1 thru j-1.
12982 !
12983 !grad          do k=i+1,j-1
12984 !grad            do l=1,3
12985 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12986 !grad            enddo
12987 !grad          enddo
12988 ! 9/28/08 AL Gradient compotents will be summed only at the end
12989           ggg(1)=facvdw*xj
12990           ggg(2)=facvdw*yj
12991           ggg(3)=facvdw*zj
12992           do k=1,3
12993             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12994             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12995           enddo
12996 #endif
12997 !
12998 ! Angular part
12999 !
13000           ecosa=2.0D0*fac3*fac1+fac4
13001           fac4=-3.0D0*fac4
13002           fac3=-6.0D0*fac3
13003           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
13004           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
13005           do k=1,3
13006             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13007             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13008           enddo
13009 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
13010 !d   &          (dcosg(k),k=1,3)
13011           do k=1,3
13012             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
13013           enddo
13014 !          do k=1,3
13015 !            ghalf=0.5D0*ggg(k)
13016 !            gelc(k,i)=gelc(k,i)+ghalf
13017 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
13018 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13019 !            gelc(k,j)=gelc(k,j)+ghalf
13020 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
13021 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13022 !          enddo
13023 !grad          do k=i+1,j-1
13024 !grad            do l=1,3
13025 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13026 !grad            enddo
13027 !grad          enddo
13028           do k=1,3
13029             gelc(k,i)=gelc(k,i) &
13030                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13031                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
13032                      *sss_ele_cut
13033             gelc(k,j)=gelc(k,j) &
13034                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13035                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
13036                      *sss_ele_cut
13037             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13038             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13039           enddo
13040           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13041               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
13042               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13043 !
13044 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
13045 !   energy of a peptide unit is assumed in the form of a second-order
13046 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
13047 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
13048 !   are computed for EVERY pair of non-contiguous peptide groups.
13049 !
13050           if (j.lt.nres-1) then
13051             j1=j+1
13052             j2=j-1
13053           else
13054             j1=j-1
13055             j2=j-2
13056           endif
13057           kkk=0
13058           do k=1,2
13059             do l=1,2
13060               kkk=kkk+1
13061               muij(kkk)=mu(k,i)*mu(l,j)
13062             enddo
13063           enddo
13064 !d         write (iout,*) 'EELEC: i',i,' j',j
13065 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
13066 !d          write(iout,*) 'muij',muij
13067           ury=scalar(uy(1,i),erij)
13068           urz=scalar(uz(1,i),erij)
13069           vry=scalar(uy(1,j),erij)
13070           vrz=scalar(uz(1,j),erij)
13071           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
13072           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
13073           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
13074           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
13075           fac=dsqrt(-ael6i)*r3ij
13076           a22=a22*fac
13077           a23=a23*fac
13078           a32=a32*fac
13079           a33=a33*fac
13080 !d          write (iout,'(4i5,4f10.5)')
13081 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
13082 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
13083 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
13084 !d     &      uy(:,j),uz(:,j)
13085 !d          write (iout,'(4f10.5)')
13086 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
13087 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
13088 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
13089 !d           write (iout,'(9f10.5/)')
13090 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
13091 ! Derivatives of the elements of A in virtual-bond vectors
13092           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
13093           do k=1,3
13094             uryg(k,1)=scalar(erder(1,k),uy(1,i))
13095             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
13096             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
13097             urzg(k,1)=scalar(erder(1,k),uz(1,i))
13098             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
13099             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
13100             vryg(k,1)=scalar(erder(1,k),uy(1,j))
13101             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
13102             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
13103             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
13104             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
13105             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
13106           enddo
13107 ! Compute radial contributions to the gradient
13108           facr=-3.0d0*rrmij
13109           a22der=a22*facr
13110           a23der=a23*facr
13111           a32der=a32*facr
13112           a33der=a33*facr
13113           agg(1,1)=a22der*xj
13114           agg(2,1)=a22der*yj
13115           agg(3,1)=a22der*zj
13116           agg(1,2)=a23der*xj
13117           agg(2,2)=a23der*yj
13118           agg(3,2)=a23der*zj
13119           agg(1,3)=a32der*xj
13120           agg(2,3)=a32der*yj
13121           agg(3,3)=a32der*zj
13122           agg(1,4)=a33der*xj
13123           agg(2,4)=a33der*yj
13124           agg(3,4)=a33der*zj
13125 ! Add the contributions coming from er
13126           fac3=-3.0d0*fac
13127           do k=1,3
13128             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
13129             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
13130             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
13131             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
13132           enddo
13133           do k=1,3
13134 ! Derivatives in DC(i)
13135 !grad            ghalf1=0.5d0*agg(k,1)
13136 !grad            ghalf2=0.5d0*agg(k,2)
13137 !grad            ghalf3=0.5d0*agg(k,3)
13138 !grad            ghalf4=0.5d0*agg(k,4)
13139             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
13140             -3.0d0*uryg(k,2)*vry)!+ghalf1
13141             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
13142             -3.0d0*uryg(k,2)*vrz)!+ghalf2
13143             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
13144             -3.0d0*urzg(k,2)*vry)!+ghalf3
13145             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
13146             -3.0d0*urzg(k,2)*vrz)!+ghalf4
13147 ! Derivatives in DC(i+1)
13148             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
13149             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
13150             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
13151             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
13152             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
13153             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
13154             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
13155             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
13156 ! Derivatives in DC(j)
13157             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
13158             -3.0d0*vryg(k,2)*ury)!+ghalf1
13159             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
13160             -3.0d0*vrzg(k,2)*ury)!+ghalf2
13161             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
13162             -3.0d0*vryg(k,2)*urz)!+ghalf3
13163             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
13164             -3.0d0*vrzg(k,2)*urz)!+ghalf4
13165 ! Derivatives in DC(j+1) or DC(nres-1)
13166             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
13167             -3.0d0*vryg(k,3)*ury)
13168             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
13169             -3.0d0*vrzg(k,3)*ury)
13170             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
13171             -3.0d0*vryg(k,3)*urz)
13172             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
13173             -3.0d0*vrzg(k,3)*urz)
13174 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
13175 !grad              do l=1,4
13176 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
13177 !grad              enddo
13178 !grad            endif
13179           enddo
13180           acipa(1,1)=a22
13181           acipa(1,2)=a23
13182           acipa(2,1)=a32
13183           acipa(2,2)=a33
13184           a22=-a22
13185           a23=-a23
13186           do l=1,2
13187             do k=1,3
13188               agg(k,l)=-agg(k,l)
13189               aggi(k,l)=-aggi(k,l)
13190               aggi1(k,l)=-aggi1(k,l)
13191               aggj(k,l)=-aggj(k,l)
13192               aggj1(k,l)=-aggj1(k,l)
13193             enddo
13194           enddo
13195           if (j.lt.nres-1) then
13196             a22=-a22
13197             a32=-a32
13198             do l=1,3,2
13199               do k=1,3
13200                 agg(k,l)=-agg(k,l)
13201                 aggi(k,l)=-aggi(k,l)
13202                 aggi1(k,l)=-aggi1(k,l)
13203                 aggj(k,l)=-aggj(k,l)
13204                 aggj1(k,l)=-aggj1(k,l)
13205               enddo
13206             enddo
13207           else
13208             a22=-a22
13209             a23=-a23
13210             a32=-a32
13211             a33=-a33
13212             do l=1,4
13213               do k=1,3
13214                 agg(k,l)=-agg(k,l)
13215                 aggi(k,l)=-aggi(k,l)
13216                 aggi1(k,l)=-aggi1(k,l)
13217                 aggj(k,l)=-aggj(k,l)
13218                 aggj1(k,l)=-aggj1(k,l)
13219               enddo
13220             enddo
13221           endif
13222           ENDIF ! WCORR
13223           IF (wel_loc.gt.0.0d0) THEN
13224 ! Contribution to the local-electrostatic energy coming from the i-j pair
13225           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
13226            +a33*muij(4)
13227 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
13228
13229           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13230                   'eelloc',i,j,eel_loc_ij
13231 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
13232
13233           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
13234 ! Partial derivatives in virtual-bond dihedral angles gamma
13235           if (i.gt.1) &
13236           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
13237                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
13238                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
13239                  *sss_ele_cut
13240           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
13241                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
13242                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
13243                  *sss_ele_cut
13244            xtemp(1)=xj
13245            xtemp(2)=yj
13246            xtemp(3)=zj
13247
13248 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
13249           do l=1,3
13250             ggg(l)=(agg(l,1)*muij(1)+ &
13251                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
13252             *sss_ele_cut &
13253              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
13254
13255             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
13256             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
13257 !grad            ghalf=0.5d0*ggg(l)
13258 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
13259 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
13260           enddo
13261 !grad          do k=i+1,j2
13262 !grad            do l=1,3
13263 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
13264 !grad            enddo
13265 !grad          enddo
13266 ! Remaining derivatives of eello
13267           do l=1,3
13268             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
13269                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
13270             *sss_ele_cut
13271
13272             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
13273                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
13274             *sss_ele_cut
13275
13276             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
13277                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
13278             *sss_ele_cut
13279
13280             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
13281                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
13282             *sss_ele_cut
13283
13284           enddo
13285           ENDIF
13286 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13287 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13288           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13289              .and. num_conti.le.maxconts) then
13290 !            write (iout,*) i,j," entered corr"
13291 !
13292 ! Calculate the contact function. The ith column of the array JCONT will
13293 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13294 ! greater than I). The arrays FACONT and GACONT will contain the values of
13295 ! the contact function and its derivative.
13296 !           r0ij=1.02D0*rpp(iteli,itelj)
13297 !           r0ij=1.11D0*rpp(iteli,itelj)
13298             r0ij=2.20D0*rpp(iteli,itelj)
13299 !           r0ij=1.55D0*rpp(iteli,itelj)
13300             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13301 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13302             if (fcont.gt.0.0D0) then
13303               num_conti=num_conti+1
13304               if (num_conti.gt.maxconts) then
13305 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13306                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13307                                ' will skip next contacts for this conf.',num_conti
13308               else
13309                 jcont_hb(num_conti,i)=j
13310 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13311 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13312                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13313                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13314 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13315 !  terms.
13316                 d_cont(num_conti,i)=rij
13317 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13318 !     --- Electrostatic-interaction matrix ---
13319                 a_chuj(1,1,num_conti,i)=a22
13320                 a_chuj(1,2,num_conti,i)=a23
13321                 a_chuj(2,1,num_conti,i)=a32
13322                 a_chuj(2,2,num_conti,i)=a33
13323 !     --- Gradient of rij
13324                 do kkk=1,3
13325                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13326                 enddo
13327                 kkll=0
13328                 do k=1,2
13329                   do l=1,2
13330                     kkll=kkll+1
13331                     do m=1,3
13332                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13333                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13334                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13335                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13336                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13337                     enddo
13338                   enddo
13339                 enddo
13340                 ENDIF
13341                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13342 ! Calculate contact energies
13343                 cosa4=4.0D0*cosa
13344                 wij=cosa-3.0D0*cosb*cosg
13345                 cosbg1=cosb+cosg
13346                 cosbg2=cosb-cosg
13347 !               fac3=dsqrt(-ael6i)/r0ij**3
13348                 fac3=dsqrt(-ael6i)*r3ij
13349 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13350                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13351                 if (ees0tmp.gt.0) then
13352                   ees0pij=dsqrt(ees0tmp)
13353                 else
13354                   ees0pij=0
13355                 endif
13356 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13357                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13358                 if (ees0tmp.gt.0) then
13359                   ees0mij=dsqrt(ees0tmp)
13360                 else
13361                   ees0mij=0
13362                 endif
13363 !               ees0mij=0.0D0
13364                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
13365                      *sss_ele_cut
13366
13367                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
13368                      *sss_ele_cut
13369
13370 ! Diagnostics. Comment out or remove after debugging!
13371 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13372 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13373 !               ees0m(num_conti,i)=0.0D0
13374 ! End diagnostics.
13375 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13376 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13377 ! Angular derivatives of the contact function
13378                 ees0pij1=fac3/ees0pij
13379                 ees0mij1=fac3/ees0mij
13380                 fac3p=-3.0D0*fac3*rrmij
13381                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13382                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13383 !               ees0mij1=0.0D0
13384                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13385                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13386                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13387                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13388                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13389                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13390                 ecosap=ecosa1+ecosa2
13391                 ecosbp=ecosb1+ecosb2
13392                 ecosgp=ecosg1+ecosg2
13393                 ecosam=ecosa1-ecosa2
13394                 ecosbm=ecosb1-ecosb2
13395                 ecosgm=ecosg1-ecosg2
13396 ! Diagnostics
13397 !               ecosap=ecosa1
13398 !               ecosbp=ecosb1
13399 !               ecosgp=ecosg1
13400 !               ecosam=0.0D0
13401 !               ecosbm=0.0D0
13402 !               ecosgm=0.0D0
13403 ! End diagnostics
13404                 facont_hb(num_conti,i)=fcont
13405                 fprimcont=fprimcont/rij
13406 !d              facont_hb(num_conti,i)=1.0D0
13407 ! Following line is for diagnostics.
13408 !d              fprimcont=0.0D0
13409                 do k=1,3
13410                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13411                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13412                 enddo
13413                 do k=1,3
13414                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13415                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13416                 enddo
13417 !                gggp(1)=gggp(1)+ees0pijp*xj
13418 !                gggp(2)=gggp(2)+ees0pijp*yj
13419 !                gggp(3)=gggp(3)+ees0pijp*zj
13420 !                gggm(1)=gggm(1)+ees0mijp*xj
13421 !                gggm(2)=gggm(2)+ees0mijp*yj
13422 !                gggm(3)=gggm(3)+ees0mijp*zj
13423                 gggp(1)=gggp(1)+ees0pijp*xj &
13424                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
13425                 gggp(2)=gggp(2)+ees0pijp*yj &
13426                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
13427                 gggp(3)=gggp(3)+ees0pijp*zj &
13428                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
13429
13430                 gggm(1)=gggm(1)+ees0mijp*xj &
13431                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
13432
13433                 gggm(2)=gggm(2)+ees0mijp*yj &
13434                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
13435
13436                 gggm(3)=gggm(3)+ees0mijp*zj &
13437                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
13438
13439 ! Derivatives due to the contact function
13440                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13441                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13442                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13443                 do k=1,3
13444 !
13445 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13446 !          following the change of gradient-summation algorithm.
13447 !
13448 !grad                  ghalfp=0.5D0*gggp(k)
13449 !grad                  ghalfm=0.5D0*gggm(k)
13450 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
13451 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13452 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13453 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
13454 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13455 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13456 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
13457 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
13458 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13459 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13460 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
13461 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13462 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13463 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
13464                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
13465                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13466                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
13467                      *sss_ele_cut
13468
13469                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
13470                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13471                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
13472                      *sss_ele_cut
13473
13474                   gacontp_hb3(k,num_conti,i)=gggp(k) &
13475                      *sss_ele_cut
13476
13477                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
13478                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13479                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
13480                      *sss_ele_cut
13481
13482                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
13483                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13484                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
13485                      *sss_ele_cut
13486
13487                   gacontm_hb3(k,num_conti,i)=gggm(k) &
13488                      *sss_ele_cut
13489
13490                 enddo
13491               ENDIF ! wcorr
13492               endif  ! num_conti.le.maxconts
13493             endif  ! fcont.gt.0
13494           endif    ! j.gt.i+1
13495           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13496             do k=1,4
13497               do l=1,3
13498                 ghalf=0.5d0*agg(l,k)
13499                 aggi(l,k)=aggi(l,k)+ghalf
13500                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13501                 aggj(l,k)=aggj(l,k)+ghalf
13502               enddo
13503             enddo
13504             if (j.eq.nres-1 .and. i.lt.j-2) then
13505               do k=1,4
13506                 do l=1,3
13507                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13508                 enddo
13509               enddo
13510             endif
13511           endif
13512  128      continue
13513 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13514       return
13515       end subroutine eelecij_scale
13516 !-----------------------------------------------------------------------------
13517       subroutine evdwpp_short(evdw1)
13518 !
13519 ! Compute Evdwpp
13520 !
13521 !      implicit real*8 (a-h,o-z)
13522 !      include 'DIMENSIONS'
13523 !      include 'COMMON.CONTROL'
13524 !      include 'COMMON.IOUNITS'
13525 !      include 'COMMON.GEO'
13526 !      include 'COMMON.VAR'
13527 !      include 'COMMON.LOCAL'
13528 !      include 'COMMON.CHAIN'
13529 !      include 'COMMON.DERIV'
13530 !      include 'COMMON.INTERACT'
13531 !      include 'COMMON.CONTACTS'
13532 !      include 'COMMON.TORSION'
13533 !      include 'COMMON.VECTORS'
13534 !      include 'COMMON.FFIELD'
13535       real(kind=8),dimension(3) :: ggg
13536 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13537 #ifdef MOMENT
13538       real(kind=8) :: scal_el=1.0d0
13539 #else
13540       real(kind=8) :: scal_el=0.5d0
13541 #endif
13542 !el local variables
13543       integer :: i,j,k,iteli,itelj,num_conti,isubchap
13544       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13545       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13546                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13547                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13548       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13549                     dist_temp, dist_init,sss_grad
13550       integer xshift,yshift,zshift
13551
13552
13553       evdw1=0.0D0
13554 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13555 !     & " iatel_e_vdw",iatel_e_vdw
13556       call flush(iout)
13557       do i=iatel_s_vdw,iatel_e_vdw
13558         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13559         dxi=dc(1,i)
13560         dyi=dc(2,i)
13561         dzi=dc(3,i)
13562         dx_normi=dc_norm(1,i)
13563         dy_normi=dc_norm(2,i)
13564         dz_normi=dc_norm(3,i)
13565         xmedi=c(1,i)+0.5d0*dxi
13566         ymedi=c(2,i)+0.5d0*dyi
13567         zmedi=c(3,i)+0.5d0*dzi
13568           xmedi=dmod(xmedi,boxxsize)
13569           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13570           ymedi=dmod(ymedi,boxysize)
13571           if (ymedi.lt.0) ymedi=ymedi+boxysize
13572           zmedi=dmod(zmedi,boxzsize)
13573           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13574         num_conti=0
13575 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13576 !     &   ' ielend',ielend_vdw(i)
13577         call flush(iout)
13578         do j=ielstart_vdw(i),ielend_vdw(i)
13579           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13580 !el          ind=ind+1
13581           iteli=itel(i)
13582           itelj=itel(j)
13583           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13584           aaa=app(iteli,itelj)
13585           bbb=bpp(iteli,itelj)
13586           dxj=dc(1,j)
13587           dyj=dc(2,j)
13588           dzj=dc(3,j)
13589           dx_normj=dc_norm(1,j)
13590           dy_normj=dc_norm(2,j)
13591           dz_normj=dc_norm(3,j)
13592 !          xj=c(1,j)+0.5D0*dxj-xmedi
13593 !          yj=c(2,j)+0.5D0*dyj-ymedi
13594 !          zj=c(3,j)+0.5D0*dzj-zmedi
13595           xj=c(1,j)+0.5D0*dxj
13596           yj=c(2,j)+0.5D0*dyj
13597           zj=c(3,j)+0.5D0*dzj
13598           xj=mod(xj,boxxsize)
13599           if (xj.lt.0) xj=xj+boxxsize
13600           yj=mod(yj,boxysize)
13601           if (yj.lt.0) yj=yj+boxysize
13602           zj=mod(zj,boxzsize)
13603           if (zj.lt.0) zj=zj+boxzsize
13604       isubchap=0
13605       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13606       xj_safe=xj
13607       yj_safe=yj
13608       zj_safe=zj
13609       do xshift=-1,1
13610       do yshift=-1,1
13611       do zshift=-1,1
13612           xj=xj_safe+xshift*boxxsize
13613           yj=yj_safe+yshift*boxysize
13614           zj=zj_safe+zshift*boxzsize
13615           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13616           if(dist_temp.lt.dist_init) then
13617             dist_init=dist_temp
13618             xj_temp=xj
13619             yj_temp=yj
13620             zj_temp=zj
13621             isubchap=1
13622           endif
13623        enddo
13624        enddo
13625        enddo
13626        if (isubchap.eq.1) then
13627 !C          print *,i,j
13628           xj=xj_temp-xmedi
13629           yj=yj_temp-ymedi
13630           zj=zj_temp-zmedi
13631        else
13632           xj=xj_safe-xmedi
13633           yj=yj_safe-ymedi
13634           zj=zj_safe-zmedi
13635        endif
13636
13637           rij=xj*xj+yj*yj+zj*zj
13638           rrmij=1.0D0/rij
13639           rij=dsqrt(rij)
13640           sss=sscale(rij/rpp(iteli,itelj))
13641             sss_ele_cut=sscale_ele(rij)
13642             sss_ele_grad=sscagrad_ele(rij)
13643             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13644             if (sss_ele_cut.le.0.0) cycle
13645           if (sss.gt.0.0d0) then
13646             rmij=1.0D0/rij
13647             r3ij=rrmij*rmij
13648             r6ij=r3ij*r3ij
13649             ev1=aaa*r6ij*r6ij
13650 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13651             if (j.eq.i+2) ev1=scal_el*ev1
13652             ev2=bbb*r6ij
13653             evdwij=ev1+ev2
13654             if (energy_dec) then
13655               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13656             endif
13657             evdw1=evdw1+evdwij*sss*sss_ele_cut
13658 !
13659 ! Calculate contributions to the Cartesian gradient.
13660 !
13661             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
13662 !            ggg(1)=facvdw*xj
13663 !            ggg(2)=facvdw*yj
13664 !            ggg(3)=facvdw*zj
13665           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
13666           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
13667           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
13668           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
13669           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
13670           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
13671
13672             do k=1,3
13673               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13674               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13675             enddo
13676           endif
13677         enddo ! j
13678       enddo   ! i
13679       return
13680       end subroutine evdwpp_short
13681 !-----------------------------------------------------------------------------
13682       subroutine escp_long(evdw2,evdw2_14)
13683 !
13684 ! This subroutine calculates the excluded-volume interaction energy between
13685 ! peptide-group centers and side chains and its gradient in virtual-bond and
13686 ! side-chain vectors.
13687 !
13688 !      implicit real*8 (a-h,o-z)
13689 !      include 'DIMENSIONS'
13690 !      include 'COMMON.GEO'
13691 !      include 'COMMON.VAR'
13692 !      include 'COMMON.LOCAL'
13693 !      include 'COMMON.CHAIN'
13694 !      include 'COMMON.DERIV'
13695 !      include 'COMMON.INTERACT'
13696 !      include 'COMMON.FFIELD'
13697 !      include 'COMMON.IOUNITS'
13698 !      include 'COMMON.CONTROL'
13699       real(kind=8),dimension(3) :: ggg
13700 !el local variables
13701       integer :: i,iint,j,k,iteli,itypj,subchap
13702       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
13703       real(kind=8) :: evdw2,evdw2_14,evdwij
13704       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13705                     dist_temp, dist_init
13706
13707       evdw2=0.0D0
13708       evdw2_14=0.0d0
13709 !d    print '(a)','Enter ESCP'
13710 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13711       do i=iatscp_s,iatscp_e
13712         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13713         iteli=itel(i)
13714         xi=0.5D0*(c(1,i)+c(1,i+1))
13715         yi=0.5D0*(c(2,i)+c(2,i+1))
13716         zi=0.5D0*(c(3,i)+c(3,i+1))
13717           xi=mod(xi,boxxsize)
13718           if (xi.lt.0) xi=xi+boxxsize
13719           yi=mod(yi,boxysize)
13720           if (yi.lt.0) yi=yi+boxysize
13721           zi=mod(zi,boxzsize)
13722           if (zi.lt.0) zi=zi+boxzsize
13723
13724         do iint=1,nscp_gr(i)
13725
13726         do j=iscpstart(i,iint),iscpend(i,iint)
13727           itypj=itype(j)
13728           if (itypj.eq.ntyp1) cycle
13729 ! Uncomment following three lines for SC-p interactions
13730 !         xj=c(1,nres+j)-xi
13731 !         yj=c(2,nres+j)-yi
13732 !         zj=c(3,nres+j)-zi
13733 ! Uncomment following three lines for Ca-p interactions
13734           xj=c(1,j)
13735           yj=c(2,j)
13736           zj=c(3,j)
13737           xj=mod(xj,boxxsize)
13738           if (xj.lt.0) xj=xj+boxxsize
13739           yj=mod(yj,boxysize)
13740           if (yj.lt.0) yj=yj+boxysize
13741           zj=mod(zj,boxzsize)
13742           if (zj.lt.0) zj=zj+boxzsize
13743       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13744       xj_safe=xj
13745       yj_safe=yj
13746       zj_safe=zj
13747       subchap=0
13748       do xshift=-1,1
13749       do yshift=-1,1
13750       do zshift=-1,1
13751           xj=xj_safe+xshift*boxxsize
13752           yj=yj_safe+yshift*boxysize
13753           zj=zj_safe+zshift*boxzsize
13754           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13755           if(dist_temp.lt.dist_init) then
13756             dist_init=dist_temp
13757             xj_temp=xj
13758             yj_temp=yj
13759             zj_temp=zj
13760             subchap=1
13761           endif
13762        enddo
13763        enddo
13764        enddo
13765        if (subchap.eq.1) then
13766           xj=xj_temp-xi
13767           yj=yj_temp-yi
13768           zj=zj_temp-zi
13769        else
13770           xj=xj_safe-xi
13771           yj=yj_safe-yi
13772           zj=zj_safe-zi
13773        endif
13774           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13775
13776           rij=dsqrt(1.0d0/rrij)
13777             sss_ele_cut=sscale_ele(rij)
13778             sss_ele_grad=sscagrad_ele(rij)
13779 !            print *,sss_ele_cut,sss_ele_grad,&
13780 !            (rij),r_cut_ele,rlamb_ele
13781             if (sss_ele_cut.le.0.0) cycle
13782           sss=sscale((rij/rscp(itypj,iteli)))
13783           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
13784           if (sss.lt.1.0d0) then
13785
13786             fac=rrij**expon2
13787             e1=fac*fac*aad(itypj,iteli)
13788             e2=fac*bad(itypj,iteli)
13789             if (iabs(j-i) .le. 2) then
13790               e1=scal14*e1
13791               e2=scal14*e2
13792               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
13793             endif
13794             evdwij=e1+e2
13795             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
13796             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13797                 'evdw2',i,j,sss,evdwij
13798 !
13799 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13800 !
13801             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
13802             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
13803             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
13804             ggg(1)=xj*fac
13805             ggg(2)=yj*fac
13806             ggg(3)=zj*fac
13807 ! Uncomment following three lines for SC-p interactions
13808 !           do k=1,3
13809 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13810 !           enddo
13811 ! Uncomment following line for SC-p interactions
13812 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13813             do k=1,3
13814               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13815               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13816             enddo
13817           endif
13818         enddo
13819
13820         enddo ! iint
13821       enddo ! i
13822       do i=1,nct
13823         do j=1,3
13824           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13825           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13826           gradx_scp(j,i)=expon*gradx_scp(j,i)
13827         enddo
13828       enddo
13829 !******************************************************************************
13830 !
13831 !                              N O T E !!!
13832 !
13833 ! To save time the factor EXPON has been extracted from ALL components
13834 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13835 ! use!
13836 !
13837 !******************************************************************************
13838       return
13839       end subroutine escp_long
13840 !-----------------------------------------------------------------------------
13841       subroutine escp_short(evdw2,evdw2_14)
13842 !
13843 ! This subroutine calculates the excluded-volume interaction energy between
13844 ! peptide-group centers and side chains and its gradient in virtual-bond and
13845 ! side-chain vectors.
13846 !
13847 !      implicit real*8 (a-h,o-z)
13848 !      include 'DIMENSIONS'
13849 !      include 'COMMON.GEO'
13850 !      include 'COMMON.VAR'
13851 !      include 'COMMON.LOCAL'
13852 !      include 'COMMON.CHAIN'
13853 !      include 'COMMON.DERIV'
13854 !      include 'COMMON.INTERACT'
13855 !      include 'COMMON.FFIELD'
13856 !      include 'COMMON.IOUNITS'
13857 !      include 'COMMON.CONTROL'
13858       real(kind=8),dimension(3) :: ggg
13859 !el local variables
13860       integer :: i,iint,j,k,iteli,itypj,subchap
13861       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
13862       real(kind=8) :: evdw2,evdw2_14,evdwij
13863       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13864                     dist_temp, dist_init
13865
13866       evdw2=0.0D0
13867       evdw2_14=0.0d0
13868 !d    print '(a)','Enter ESCP'
13869 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13870       do i=iatscp_s,iatscp_e
13871         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13872         iteli=itel(i)
13873         xi=0.5D0*(c(1,i)+c(1,i+1))
13874         yi=0.5D0*(c(2,i)+c(2,i+1))
13875         zi=0.5D0*(c(3,i)+c(3,i+1))
13876           xi=mod(xi,boxxsize)
13877           if (xi.lt.0) xi=xi+boxxsize
13878           yi=mod(yi,boxysize)
13879           if (yi.lt.0) yi=yi+boxysize
13880           zi=mod(zi,boxzsize)
13881           if (zi.lt.0) zi=zi+boxzsize
13882
13883         do iint=1,nscp_gr(i)
13884
13885         do j=iscpstart(i,iint),iscpend(i,iint)
13886           itypj=itype(j)
13887           if (itypj.eq.ntyp1) cycle
13888 ! Uncomment following three lines for SC-p interactions
13889 !         xj=c(1,nres+j)-xi
13890 !         yj=c(2,nres+j)-yi
13891 !         zj=c(3,nres+j)-zi
13892 ! Uncomment following three lines for Ca-p interactions
13893 !          xj=c(1,j)-xi
13894 !          yj=c(2,j)-yi
13895 !          zj=c(3,j)-zi
13896           xj=c(1,j)
13897           yj=c(2,j)
13898           zj=c(3,j)
13899           xj=mod(xj,boxxsize)
13900           if (xj.lt.0) xj=xj+boxxsize
13901           yj=mod(yj,boxysize)
13902           if (yj.lt.0) yj=yj+boxysize
13903           zj=mod(zj,boxzsize)
13904           if (zj.lt.0) zj=zj+boxzsize
13905       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13906       xj_safe=xj
13907       yj_safe=yj
13908       zj_safe=zj
13909       subchap=0
13910       do xshift=-1,1
13911       do yshift=-1,1
13912       do zshift=-1,1
13913           xj=xj_safe+xshift*boxxsize
13914           yj=yj_safe+yshift*boxysize
13915           zj=zj_safe+zshift*boxzsize
13916           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13917           if(dist_temp.lt.dist_init) then
13918             dist_init=dist_temp
13919             xj_temp=xj
13920             yj_temp=yj
13921             zj_temp=zj
13922             subchap=1
13923           endif
13924        enddo
13925        enddo
13926        enddo
13927        if (subchap.eq.1) then
13928           xj=xj_temp-xi
13929           yj=yj_temp-yi
13930           zj=zj_temp-zi
13931        else
13932           xj=xj_safe-xi
13933           yj=yj_safe-yi
13934           zj=zj_safe-zi
13935        endif
13936
13937           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13938           rij=dsqrt(1.0d0/rrij)
13939             sss_ele_cut=sscale_ele(rij)
13940             sss_ele_grad=sscagrad_ele(rij)
13941 !            print *,sss_ele_cut,sss_ele_grad,&
13942 !            (rij),r_cut_ele,rlamb_ele
13943             if (sss_ele_cut.le.0.0) cycle
13944           sss=sscale(rij/rscp(itypj,iteli))
13945           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
13946           if (sss.gt.0.0d0) then
13947
13948             fac=rrij**expon2
13949             e1=fac*fac*aad(itypj,iteli)
13950             e2=fac*bad(itypj,iteli)
13951             if (iabs(j-i) .le. 2) then
13952               e1=scal14*e1
13953               e2=scal14*e2
13954               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
13955             endif
13956             evdwij=e1+e2
13957             evdw2=evdw2+evdwij*sss*sss_ele_cut
13958             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13959                 'evdw2',i,j,sss,evdwij
13960 !
13961 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13962 !
13963             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
13964             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
13965             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
13966
13967             ggg(1)=xj*fac
13968             ggg(2)=yj*fac
13969             ggg(3)=zj*fac
13970 ! Uncomment following three lines for SC-p interactions
13971 !           do k=1,3
13972 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13973 !           enddo
13974 ! Uncomment following line for SC-p interactions
13975 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13976             do k=1,3
13977               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13978               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13979             enddo
13980           endif
13981         enddo
13982
13983         enddo ! iint
13984       enddo ! i
13985       do i=1,nct
13986         do j=1,3
13987           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13988           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13989           gradx_scp(j,i)=expon*gradx_scp(j,i)
13990         enddo
13991       enddo
13992 !******************************************************************************
13993 !
13994 !                              N O T E !!!
13995 !
13996 ! To save time the factor EXPON has been extracted from ALL components
13997 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13998 ! use!
13999 !
14000 !******************************************************************************
14001       return
14002       end subroutine escp_short
14003 !-----------------------------------------------------------------------------
14004 ! energy_p_new-sep_barrier.F
14005 !-----------------------------------------------------------------------------
14006       subroutine sc_grad_scale(scalfac)
14007 !      implicit real*8 (a-h,o-z)
14008       use calc_data
14009 !      include 'DIMENSIONS'
14010 !      include 'COMMON.CHAIN'
14011 !      include 'COMMON.DERIV'
14012 !      include 'COMMON.CALC'
14013 !      include 'COMMON.IOUNITS'
14014       real(kind=8),dimension(3) :: dcosom1,dcosom2
14015       real(kind=8) :: scalfac
14016 !el local variables
14017 !      integer :: i,j,k,l
14018
14019       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
14020       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
14021       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
14022            -2.0D0*alf12*eps3der+sigder*sigsq_om12
14023 ! diagnostics only
14024 !      eom1=0.0d0
14025 !      eom2=0.0d0
14026 !      eom12=evdwij*eps1_om12
14027 ! end diagnostics
14028 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
14029 !     &  " sigder",sigder
14030 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
14031 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
14032       do k=1,3
14033         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
14034         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
14035       enddo
14036       do k=1,3
14037         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
14038          *sss_ele_cut
14039       enddo
14040 !      write (iout,*) "gg",(gg(k),k=1,3)
14041       do k=1,3
14042         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
14043                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
14044                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
14045                  *sss_ele_cut
14046         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
14047                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
14048                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
14049          *sss_ele_cut
14050 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
14051 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
14052 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
14053 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
14054       enddo
14055 !
14056 ! Calculate the components of the gradient in DC and X
14057 !
14058       do l=1,3
14059         gvdwc(l,i)=gvdwc(l,i)-gg(l)
14060         gvdwc(l,j)=gvdwc(l,j)+gg(l)
14061       enddo
14062       return
14063       end subroutine sc_grad_scale
14064 !-----------------------------------------------------------------------------
14065 ! energy_split-sep.F
14066 !-----------------------------------------------------------------------------
14067       subroutine etotal_long(energia)
14068 !
14069 ! Compute the long-range slow-varying contributions to the energy
14070 !
14071 !      implicit real*8 (a-h,o-z)
14072 !      include 'DIMENSIONS'
14073       use MD_data, only: totT,usampl,eq_time
14074 #ifndef ISNAN
14075       external proc_proc
14076 #ifdef WINPGI
14077 !MS$ATTRIBUTES C ::  proc_proc
14078 #endif
14079 #endif
14080 #ifdef MPI
14081       include "mpif.h"
14082       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
14083 #endif
14084 !      include 'COMMON.SETUP'
14085 !      include 'COMMON.IOUNITS'
14086 !      include 'COMMON.FFIELD'
14087 !      include 'COMMON.DERIV'
14088 !      include 'COMMON.INTERACT'
14089 !      include 'COMMON.SBRIDGE'
14090 !      include 'COMMON.CHAIN'
14091 !      include 'COMMON.VAR'
14092 !      include 'COMMON.LOCAL'
14093 !      include 'COMMON.MD'
14094       real(kind=8),dimension(0:n_ene) :: energia
14095 !el local variables
14096       integer :: i,n_corr,n_corr1,ierror,ierr
14097       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
14098                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
14099                   ecorr,ecorr5,ecorr6,eturn6,time00
14100 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
14101 !elwrite(iout,*)"in etotal long"
14102
14103       if (modecalc.eq.12.or.modecalc.eq.14) then
14104 #ifdef MPI
14105 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
14106 #else
14107         call int_from_cart1(.false.)
14108 #endif
14109       endif
14110 !elwrite(iout,*)"in etotal long"
14111
14112 #ifdef MPI
14113 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
14114 !     & " absolute rank",myrank," nfgtasks",nfgtasks
14115       call flush(iout)
14116       if (nfgtasks.gt.1) then
14117         time00=MPI_Wtime()
14118 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
14119         if (fg_rank.eq.0) then
14120           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
14121 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
14122 !          call flush(iout)
14123 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
14124 ! FG slaves as WEIGHTS array.
14125           weights_(1)=wsc
14126           weights_(2)=wscp
14127           weights_(3)=welec
14128           weights_(4)=wcorr
14129           weights_(5)=wcorr5
14130           weights_(6)=wcorr6
14131           weights_(7)=wel_loc
14132           weights_(8)=wturn3
14133           weights_(9)=wturn4
14134           weights_(10)=wturn6
14135           weights_(11)=wang
14136           weights_(12)=wscloc
14137           weights_(13)=wtor
14138           weights_(14)=wtor_d
14139           weights_(15)=wstrain
14140           weights_(16)=wvdwpp
14141           weights_(17)=wbond
14142           weights_(18)=scal14
14143           weights_(21)=wsccor
14144 ! FG Master broadcasts the WEIGHTS_ array
14145           call MPI_Bcast(weights_(1),n_ene,&
14146               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14147         else
14148 ! FG slaves receive the WEIGHTS array
14149           call MPI_Bcast(weights(1),n_ene,&
14150               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14151           wsc=weights(1)
14152           wscp=weights(2)
14153           welec=weights(3)
14154           wcorr=weights(4)
14155           wcorr5=weights(5)
14156           wcorr6=weights(6)
14157           wel_loc=weights(7)
14158           wturn3=weights(8)
14159           wturn4=weights(9)
14160           wturn6=weights(10)
14161           wang=weights(11)
14162           wscloc=weights(12)
14163           wtor=weights(13)
14164           wtor_d=weights(14)
14165           wstrain=weights(15)
14166           wvdwpp=weights(16)
14167           wbond=weights(17)
14168           scal14=weights(18)
14169           wsccor=weights(21)
14170         endif
14171         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
14172           king,FG_COMM,IERR)
14173          time_Bcast=time_Bcast+MPI_Wtime()-time00
14174          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
14175 !        call chainbuild_cart
14176 !        call int_from_cart1(.false.)
14177       endif
14178 !      write (iout,*) 'Processor',myrank,
14179 !     &  ' calling etotal_short ipot=',ipot
14180 !      call flush(iout)
14181 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14182 #endif
14183 !d    print *,'nnt=',nnt,' nct=',nct
14184 !
14185 !elwrite(iout,*)"in etotal long"
14186 ! Compute the side-chain and electrostatic interaction energy
14187 !
14188       goto (101,102,103,104,105,106) ipot
14189 ! Lennard-Jones potential.
14190   101 call elj_long(evdw)
14191 !d    print '(a)','Exit ELJ'
14192       goto 107
14193 ! Lennard-Jones-Kihara potential (shifted).
14194   102 call eljk_long(evdw)
14195       goto 107
14196 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14197   103 call ebp_long(evdw)
14198       goto 107
14199 ! Gay-Berne potential (shifted LJ, angular dependence).
14200   104 call egb_long(evdw)
14201       goto 107
14202 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14203   105 call egbv_long(evdw)
14204       goto 107
14205 ! Soft-sphere potential
14206   106 call e_softsphere(evdw)
14207 !
14208 ! Calculate electrostatic (H-bonding) energy of the main chain.
14209 !
14210   107 continue
14211       call vec_and_deriv
14212       if (ipot.lt.6) then
14213 #ifdef SPLITELE
14214          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
14215              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
14216              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
14217              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
14218 #else
14219          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
14220              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
14221              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
14222              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
14223 #endif
14224            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14225          else
14226             ees=0
14227             evdw1=0
14228             eel_loc=0
14229             eello_turn3=0
14230             eello_turn4=0
14231          endif
14232       else
14233 !        write (iout,*) "Soft-spheer ELEC potential"
14234         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
14235          eello_turn4)
14236       endif
14237 !
14238 ! Calculate excluded-volume interaction energy between peptide groups
14239 ! and side chains.
14240 !
14241       if (ipot.lt.6) then
14242        if(wscp.gt.0d0) then
14243         call escp_long(evdw2,evdw2_14)
14244        else
14245         evdw2=0
14246         evdw2_14=0
14247        endif
14248       else
14249         call escp_soft_sphere(evdw2,evdw2_14)
14250       endif
14251 !
14252 ! 12/1/95 Multi-body terms
14253 !
14254       n_corr=0
14255       n_corr1=0
14256       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
14257           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
14258          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
14259 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
14260 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
14261       else
14262          ecorr=0.0d0
14263          ecorr5=0.0d0
14264          ecorr6=0.0d0
14265          eturn6=0.0d0
14266       endif
14267       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
14268          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
14269       endif
14270 !
14271 ! If performing constraint dynamics, call the constraint energy
14272 !  after the equilibration time
14273       if(usampl.and.totT.gt.eq_time) then
14274          call EconstrQ
14275          call Econstr_back
14276       else
14277          Uconst=0.0d0
14278          Uconst_back=0.0d0
14279       endif
14280 !
14281 ! Sum the energies
14282 !
14283       do i=1,n_ene
14284         energia(i)=0.0d0
14285       enddo
14286       energia(1)=evdw
14287 #ifdef SCP14
14288       energia(2)=evdw2-evdw2_14
14289       energia(18)=evdw2_14
14290 #else
14291       energia(2)=evdw2
14292       energia(18)=0.0d0
14293 #endif
14294 #ifdef SPLITELE
14295       energia(3)=ees
14296       energia(16)=evdw1
14297 #else
14298       energia(3)=ees+evdw1
14299       energia(16)=0.0d0
14300 #endif
14301       energia(4)=ecorr
14302       energia(5)=ecorr5
14303       energia(6)=ecorr6
14304       energia(7)=eel_loc
14305       energia(8)=eello_turn3
14306       energia(9)=eello_turn4
14307       energia(10)=eturn6
14308       energia(20)=Uconst+Uconst_back
14309       call sum_energy(energia,.true.)
14310 !      write (iout,*) "Exit ETOTAL_LONG"
14311       call flush(iout)
14312       return
14313       end subroutine etotal_long
14314 !-----------------------------------------------------------------------------
14315       subroutine etotal_short(energia)
14316 !
14317 ! Compute the short-range fast-varying contributions to the energy
14318 !
14319 !      implicit real*8 (a-h,o-z)
14320 !      include 'DIMENSIONS'
14321 #ifndef ISNAN
14322       external proc_proc
14323 #ifdef WINPGI
14324 !MS$ATTRIBUTES C ::  proc_proc
14325 #endif
14326 #endif
14327 #ifdef MPI
14328       include "mpif.h"
14329       integer :: ierror,ierr
14330       real(kind=8),dimension(n_ene) :: weights_
14331       real(kind=8) :: time00
14332 #endif
14333 !      include 'COMMON.SETUP'
14334 !      include 'COMMON.IOUNITS'
14335 !      include 'COMMON.FFIELD'
14336 !      include 'COMMON.DERIV'
14337 !      include 'COMMON.INTERACT'
14338 !      include 'COMMON.SBRIDGE'
14339 !      include 'COMMON.CHAIN'
14340 !      include 'COMMON.VAR'
14341 !      include 'COMMON.LOCAL'
14342       real(kind=8),dimension(0:n_ene) :: energia
14343 !el local variables
14344       integer :: i,nres6
14345       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
14346       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
14347       nres6=6*nres
14348
14349 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
14350 !      call flush(iout)
14351       if (modecalc.eq.12.or.modecalc.eq.14) then
14352 #ifdef MPI
14353         if (fg_rank.eq.0) call int_from_cart1(.false.)
14354 #else
14355         call int_from_cart1(.false.)
14356 #endif
14357       endif
14358 #ifdef MPI
14359 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
14360 !     & " absolute rank",myrank," nfgtasks",nfgtasks
14361 !      call flush(iout)
14362       if (nfgtasks.gt.1) then
14363         time00=MPI_Wtime()
14364 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
14365         if (fg_rank.eq.0) then
14366           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
14367 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
14368 !          call flush(iout)
14369 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
14370 ! FG slaves as WEIGHTS array.
14371           weights_(1)=wsc
14372           weights_(2)=wscp
14373           weights_(3)=welec
14374           weights_(4)=wcorr
14375           weights_(5)=wcorr5
14376           weights_(6)=wcorr6
14377           weights_(7)=wel_loc
14378           weights_(8)=wturn3
14379           weights_(9)=wturn4
14380           weights_(10)=wturn6
14381           weights_(11)=wang
14382           weights_(12)=wscloc
14383           weights_(13)=wtor
14384           weights_(14)=wtor_d
14385           weights_(15)=wstrain
14386           weights_(16)=wvdwpp
14387           weights_(17)=wbond
14388           weights_(18)=scal14
14389           weights_(21)=wsccor
14390 ! FG Master broadcasts the WEIGHTS_ array
14391           call MPI_Bcast(weights_(1),n_ene,&
14392               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14393         else
14394 ! FG slaves receive the WEIGHTS array
14395           call MPI_Bcast(weights(1),n_ene,&
14396               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14397           wsc=weights(1)
14398           wscp=weights(2)
14399           welec=weights(3)
14400           wcorr=weights(4)
14401           wcorr5=weights(5)
14402           wcorr6=weights(6)
14403           wel_loc=weights(7)
14404           wturn3=weights(8)
14405           wturn4=weights(9)
14406           wturn6=weights(10)
14407           wang=weights(11)
14408           wscloc=weights(12)
14409           wtor=weights(13)
14410           wtor_d=weights(14)
14411           wstrain=weights(15)
14412           wvdwpp=weights(16)
14413           wbond=weights(17)
14414           scal14=weights(18)
14415           wsccor=weights(21)
14416         endif
14417 !        write (iout,*),"Processor",myrank," BROADCAST weights"
14418         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
14419           king,FG_COMM,IERR)
14420 !        write (iout,*) "Processor",myrank," BROADCAST c"
14421         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
14422           king,FG_COMM,IERR)
14423 !        write (iout,*) "Processor",myrank," BROADCAST dc"
14424         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
14425           king,FG_COMM,IERR)
14426 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
14427         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
14428           king,FG_COMM,IERR)
14429 !        write (iout,*) "Processor",myrank," BROADCAST theta"
14430         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
14431           king,FG_COMM,IERR)
14432 !        write (iout,*) "Processor",myrank," BROADCAST phi"
14433         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
14434           king,FG_COMM,IERR)
14435 !        write (iout,*) "Processor",myrank," BROADCAST alph"
14436         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
14437           king,FG_COMM,IERR)
14438 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
14439         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
14440           king,FG_COMM,IERR)
14441 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
14442         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
14443           king,FG_COMM,IERR)
14444          time_Bcast=time_Bcast+MPI_Wtime()-time00
14445 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
14446       endif
14447 !      write (iout,*) 'Processor',myrank,
14448 !     &  ' calling etotal_short ipot=',ipot
14449 !      call flush(iout)
14450 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14451 #endif
14452 !      call int_from_cart1(.false.)
14453 !
14454 ! Compute the side-chain and electrostatic interaction energy
14455 !
14456       goto (101,102,103,104,105,106) ipot
14457 ! Lennard-Jones potential.
14458   101 call elj_short(evdw)
14459 !d    print '(a)','Exit ELJ'
14460       goto 107
14461 ! Lennard-Jones-Kihara potential (shifted).
14462   102 call eljk_short(evdw)
14463       goto 107
14464 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14465   103 call ebp_short(evdw)
14466       goto 107
14467 ! Gay-Berne potential (shifted LJ, angular dependence).
14468   104 call egb_short(evdw)
14469       goto 107
14470 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14471   105 call egbv_short(evdw)
14472       goto 107
14473 ! Soft-sphere potential - already dealt with in the long-range part
14474   106 evdw=0.0d0
14475 !  106 call e_softsphere_short(evdw)
14476 !
14477 ! Calculate electrostatic (H-bonding) energy of the main chain.
14478 !
14479   107 continue
14480 !
14481 ! Calculate the short-range part of Evdwpp
14482 !
14483       call evdwpp_short(evdw1)
14484 !
14485 ! Calculate the short-range part of ESCp
14486 !
14487       if (ipot.lt.6) then
14488         call escp_short(evdw2,evdw2_14)
14489       endif
14490 !
14491 ! Calculate the bond-stretching energy
14492 !
14493       call ebond(estr)
14494 !
14495 ! Calculate the disulfide-bridge and other energy and the contributions
14496 ! from other distance constraints.
14497       call edis(ehpb)
14498 !
14499 ! Calculate the virtual-bond-angle energy.
14500 !
14501       call ebend(ebe)
14502 !
14503 ! Calculate the SC local energy.
14504 !
14505       call vec_and_deriv
14506       call esc(escloc)
14507 !
14508 ! Calculate the virtual-bond torsional energy.
14509 !
14510       call etor(etors,edihcnstr)
14511 !
14512 ! 6/23/01 Calculate double-torsional energy
14513 !
14514       call etor_d(etors_d)
14515 !
14516 ! 21/5/07 Calculate local sicdechain correlation energy
14517 !
14518       if (wsccor.gt.0.0d0) then
14519         call eback_sc_corr(esccor)
14520       else
14521         esccor=0.0d0
14522       endif
14523 !
14524 ! Put energy components into an array
14525 !
14526       do i=1,n_ene
14527         energia(i)=0.0d0
14528       enddo
14529       energia(1)=evdw
14530 #ifdef SCP14
14531       energia(2)=evdw2-evdw2_14
14532       energia(18)=evdw2_14
14533 #else
14534       energia(2)=evdw2
14535       energia(18)=0.0d0
14536 #endif
14537 #ifdef SPLITELE
14538       energia(16)=evdw1
14539 #else
14540       energia(3)=evdw1
14541 #endif
14542       energia(11)=ebe
14543       energia(12)=escloc
14544       energia(13)=etors
14545       energia(14)=etors_d
14546       energia(15)=ehpb
14547       energia(17)=estr
14548       energia(19)=edihcnstr
14549       energia(21)=esccor
14550 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14551       call flush(iout)
14552       call sum_energy(energia,.true.)
14553 !      write (iout,*) "Exit ETOTAL_SHORT"
14554       call flush(iout)
14555       return
14556       end subroutine etotal_short
14557 !-----------------------------------------------------------------------------
14558 ! gnmr1.f
14559 !-----------------------------------------------------------------------------
14560       real(kind=8) function gnmr1(y,ymin,ymax)
14561 !      implicit none
14562       real(kind=8) :: y,ymin,ymax
14563       real(kind=8) :: wykl=4.0d0
14564       if (y.lt.ymin) then
14565         gnmr1=(ymin-y)**wykl/wykl
14566       else if (y.gt.ymax) then
14567         gnmr1=(y-ymax)**wykl/wykl
14568       else
14569         gnmr1=0.0d0
14570       endif
14571       return
14572       end function gnmr1
14573 !-----------------------------------------------------------------------------
14574       real(kind=8) function gnmr1prim(y,ymin,ymax)
14575 !      implicit none
14576       real(kind=8) :: y,ymin,ymax
14577       real(kind=8) :: wykl=4.0d0
14578       if (y.lt.ymin) then
14579         gnmr1prim=-(ymin-y)**(wykl-1)
14580       else if (y.gt.ymax) then
14581         gnmr1prim=(y-ymax)**(wykl-1)
14582       else
14583         gnmr1prim=0.0d0
14584       endif
14585       return
14586       end function gnmr1prim
14587 !-----------------------------------------------------------------------------
14588       real(kind=8) function harmonic(y,ymax)
14589 !      implicit none
14590       real(kind=8) :: y,ymax
14591       real(kind=8) :: wykl=2.0d0
14592       harmonic=(y-ymax)**wykl
14593       return
14594       end function harmonic
14595 !-----------------------------------------------------------------------------
14596       real(kind=8) function harmonicprim(y,ymax)
14597       real(kind=8) :: y,ymin,ymax
14598       real(kind=8) :: wykl=2.0d0
14599       harmonicprim=(y-ymax)*wykl
14600       return
14601       end function harmonicprim
14602 !-----------------------------------------------------------------------------
14603 ! gradient_p.F
14604 !-----------------------------------------------------------------------------
14605       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14606
14607       use io_base, only:intout,briefout
14608 !      implicit real*8 (a-h,o-z)
14609 !      include 'DIMENSIONS'
14610 !      include 'COMMON.CHAIN'
14611 !      include 'COMMON.DERIV'
14612 !      include 'COMMON.VAR'
14613 !      include 'COMMON.INTERACT'
14614 !      include 'COMMON.FFIELD'
14615 !      include 'COMMON.MD'
14616 !      include 'COMMON.IOUNITS'
14617       real(kind=8),external :: ufparm
14618       integer :: uiparm(1)
14619       real(kind=8) :: urparm(1)
14620       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14621       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14622       integer :: n,nf,ind,ind1,i,k,j
14623 !
14624 ! This subroutine calculates total internal coordinate gradient.
14625 ! Depending on the number of function evaluations, either whole energy
14626 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14627 ! internal coordinates are reevaluated or only the cartesian-in-internal
14628 ! coordinate derivatives are evaluated. The subroutine was designed to work
14629 ! with SUMSL.
14630 !
14631 !
14632       icg=mod(nf,2)+1
14633
14634 !d      print *,'grad',nf,icg
14635       if (nf-nfl+1) 20,30,40
14636    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14637 !    write (iout,*) 'grad 20'
14638       if (nf.eq.0) return
14639       goto 40
14640    30 call var_to_geom(n,x)
14641       call chainbuild
14642 !    write (iout,*) 'grad 30'
14643 !
14644 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14645 !
14646    40 call cartder
14647 !     write (iout,*) 'grad 40'
14648 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14649 !
14650 ! Convert the Cartesian gradient into internal-coordinate gradient.
14651 !
14652       ind=0
14653       ind1=0
14654       do i=1,nres-2
14655         gthetai=0.0D0
14656         gphii=0.0D0
14657         do j=i+1,nres-1
14658           ind=ind+1
14659 !         ind=indmat(i,j)
14660 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14661           do k=1,3
14662             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14663           enddo
14664           do k=1,3
14665             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14666           enddo
14667         enddo
14668         do j=i+1,nres-1
14669           ind1=ind1+1
14670 !         ind1=indmat(i,j)
14671 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14672           do k=1,3
14673             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14674             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14675           enddo
14676         enddo
14677         if (i.gt.1) g(i-1)=gphii
14678         if (n.gt.nphi) g(nphi+i)=gthetai
14679       enddo
14680       if (n.le.nphi+ntheta) goto 10
14681       do i=2,nres-1
14682         if (itype(i).ne.10) then
14683           galphai=0.0D0
14684           gomegai=0.0D0
14685           do k=1,3
14686             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14687           enddo
14688           do k=1,3
14689             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14690           enddo
14691           g(ialph(i,1))=galphai
14692           g(ialph(i,1)+nside)=gomegai
14693         endif
14694       enddo
14695 !
14696 ! Add the components corresponding to local energy terms.
14697 !
14698    10 continue
14699       do i=1,nvar
14700 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14701         g(i)=g(i)+gloc(i,icg)
14702       enddo
14703 ! Uncomment following three lines for diagnostics.
14704 !d    call intout
14705 !elwrite(iout,*) "in gradient after calling intout"
14706 !d    call briefout(0,0.0d0)
14707 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14708       return
14709       end subroutine gradient
14710 !-----------------------------------------------------------------------------
14711       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14712
14713       use comm_chu
14714 !      implicit real*8 (a-h,o-z)
14715 !      include 'DIMENSIONS'
14716 !      include 'COMMON.DERIV'
14717 !      include 'COMMON.IOUNITS'
14718 !      include 'COMMON.GEO'
14719       integer :: n,nf
14720 !el      integer :: jjj
14721 !el      common /chuju/ jjj
14722       real(kind=8) :: energia(0:n_ene)
14723       integer :: uiparm(1)
14724       real(kind=8) :: urparm(1)
14725       real(kind=8) :: f
14726       real(kind=8),external :: ufparm
14727       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14728 !     if (jjj.gt.0) then
14729 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14730 !     endif
14731       nfl=nf
14732       icg=mod(nf,2)+1
14733 !d      print *,'func',nf,nfl,icg
14734       call var_to_geom(n,x)
14735       call zerograd
14736       call chainbuild
14737 !d    write (iout,*) 'ETOTAL called from FUNC'
14738       call etotal(energia)
14739       call sum_gradient
14740       f=energia(0)
14741 !     if (jjj.gt.0) then
14742 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14743 !       write (iout,*) 'f=',etot
14744 !       jjj=0
14745 !     endif
14746       return
14747       end subroutine func
14748 !-----------------------------------------------------------------------------
14749       subroutine cartgrad
14750 !      implicit real*8 (a-h,o-z)
14751 !      include 'DIMENSIONS'
14752       use energy_data
14753       use MD_data, only: totT,usampl,eq_time
14754 #ifdef MPI
14755       include 'mpif.h'
14756 #endif
14757 !      include 'COMMON.CHAIN'
14758 !      include 'COMMON.DERIV'
14759 !      include 'COMMON.VAR'
14760 !      include 'COMMON.INTERACT'
14761 !      include 'COMMON.FFIELD'
14762 !      include 'COMMON.MD'
14763 !      include 'COMMON.IOUNITS'
14764 !      include 'COMMON.TIME1'
14765 !
14766       integer :: i,j
14767
14768 ! This subrouting calculates total Cartesian coordinate gradient.
14769 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14770 !
14771 !el#define DEBUG
14772 #ifdef TIMING
14773       time00=MPI_Wtime()
14774 #endif
14775       icg=1
14776       call sum_gradient
14777 #ifdef TIMING
14778 #endif
14779 !el      write (iout,*) "After sum_gradient"
14780 #ifdef DEBUG
14781 !el      write (iout,*) "After sum_gradient"
14782       do i=1,nres-1
14783         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14784         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14785       enddo
14786 #endif
14787 ! If performing constraint dynamics, add the gradients of the constraint energy
14788       if(usampl.and.totT.gt.eq_time) then
14789          do i=1,nct
14790            do j=1,3
14791              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14792              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14793            enddo
14794          enddo
14795          do i=1,nres-3
14796            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14797          enddo
14798          do i=1,nres-2
14799            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14800          enddo
14801       endif
14802 !elwrite (iout,*) "After sum_gradient"
14803 #ifdef TIMING
14804       time01=MPI_Wtime()
14805 #endif
14806       call intcartderiv
14807 !elwrite (iout,*) "After sum_gradient"
14808 #ifdef TIMING
14809       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14810 #endif
14811 !     call checkintcartgrad
14812 !     write(iout,*) 'calling int_to_cart'
14813 #ifdef DEBUG
14814       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14815 #endif
14816       do i=1,nct
14817         do j=1,3
14818           gcart(j,i)=gradc(j,i,icg)
14819           gxcart(j,i)=gradx(j,i,icg)
14820         enddo
14821 #ifdef DEBUG
14822         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14823           (gxcart(j,i),j=1,3),gloc(i,icg)
14824 #endif
14825       enddo
14826 #ifdef TIMING
14827       time01=MPI_Wtime()
14828 #endif
14829       call int_to_cart
14830 #ifdef TIMING
14831       time_inttocart=time_inttocart+MPI_Wtime()-time01
14832 #endif
14833 #ifdef DEBUG
14834       write (iout,*) "gcart and gxcart after int_to_cart"
14835       do i=0,nres-1
14836         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14837             (gxcart(j,i),j=1,3)
14838       enddo
14839 #endif
14840 #ifdef CARGRAD
14841 #ifdef DEBUG
14842       write (iout,*) "CARGRAD"
14843 #endif
14844       do i=nres,1,-1
14845         do j=1,3
14846           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14847 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14848         enddo
14849 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14850 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14851       enddo
14852 ! Correction: dummy residues
14853         if (nnt.gt.1) then
14854           do j=1,3
14855 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14856             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14857           enddo
14858         endif
14859         if (nct.lt.nres) then
14860           do j=1,3
14861 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14862             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14863           enddo
14864         endif
14865 #endif
14866 #ifdef TIMING
14867       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14868 #endif
14869 !el#undef DEBUG
14870       return
14871       end subroutine cartgrad
14872 !-----------------------------------------------------------------------------
14873       subroutine zerograd
14874 !      implicit real*8 (a-h,o-z)
14875 !      include 'DIMENSIONS'
14876 !      include 'COMMON.DERIV'
14877 !      include 'COMMON.CHAIN'
14878 !      include 'COMMON.VAR'
14879 !      include 'COMMON.MD'
14880 !      include 'COMMON.SCCOR'
14881 !
14882 !el local variables
14883       integer :: i,j,intertyp
14884 ! Initialize Cartesian-coordinate gradient
14885 !
14886 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14887 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14888
14889 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14890 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14891 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14892 !      allocate(gradcorr_long(3,nres))
14893 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14894 !      allocate(gcorr6_turn_long(3,nres))
14895 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14896
14897 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14898
14899 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14900 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14901
14902 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14903 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14904
14905 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14906 !      allocate(gscloc(3,nres)) !(3,maxres)
14907 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14908
14909
14910
14911 !      common /deriv_scloc/
14912 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14913 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14914 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14915 !      common /mpgrad/
14916 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14917
14918
14919
14920 !          gradc(j,i,icg)=0.0d0
14921 !          gradx(j,i,icg)=0.0d0
14922
14923 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14924 !elwrite(iout,*) "icg",icg
14925       do i=1,nres
14926         do j=1,3
14927           gvdwx(j,i)=0.0D0
14928           gradx_scp(j,i)=0.0D0
14929           gvdwc(j,i)=0.0D0
14930           gvdwc_scp(j,i)=0.0D0
14931           gvdwc_scpp(j,i)=0.0d0
14932           gelc(j,i)=0.0D0
14933           gelc_long(j,i)=0.0D0
14934           gradb(j,i)=0.0d0
14935           gradbx(j,i)=0.0d0
14936           gvdwpp(j,i)=0.0d0
14937           gel_loc(j,i)=0.0d0
14938           gel_loc_long(j,i)=0.0d0
14939           ghpbc(j,i)=0.0D0
14940           ghpbx(j,i)=0.0D0
14941           gcorr3_turn(j,i)=0.0d0
14942           gcorr4_turn(j,i)=0.0d0
14943           gradcorr(j,i)=0.0d0
14944           gradcorr_long(j,i)=0.0d0
14945           gradcorr5_long(j,i)=0.0d0
14946           gradcorr6_long(j,i)=0.0d0
14947           gcorr6_turn_long(j,i)=0.0d0
14948           gradcorr5(j,i)=0.0d0
14949           gradcorr6(j,i)=0.0d0
14950           gcorr6_turn(j,i)=0.0d0
14951           gsccorc(j,i)=0.0d0
14952           gsccorx(j,i)=0.0d0
14953           gradc(j,i,icg)=0.0d0
14954           gradx(j,i,icg)=0.0d0
14955           gscloc(j,i)=0.0d0
14956           gsclocx(j,i)=0.0d0
14957           do intertyp=1,3
14958            gloc_sc(intertyp,i,icg)=0.0d0
14959           enddo
14960         enddo
14961       enddo
14962 !
14963 ! Initialize the gradient of local energy terms.
14964 !
14965 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14966 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14967 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14968 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14969 !      allocate(gel_loc_turn3(nres))
14970 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14971 !      allocate(gsccor_loc(nres))       !(maxres)
14972
14973       do i=1,4*nres
14974         gloc(i,icg)=0.0D0
14975       enddo
14976       do i=1,nres
14977         gel_loc_loc(i)=0.0d0
14978         gcorr_loc(i)=0.0d0
14979         g_corr5_loc(i)=0.0d0
14980         g_corr6_loc(i)=0.0d0
14981         gel_loc_turn3(i)=0.0d0
14982         gel_loc_turn4(i)=0.0d0
14983         gel_loc_turn6(i)=0.0d0
14984         gsccor_loc(i)=0.0d0
14985       enddo
14986 ! initialize gcart and gxcart
14987 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14988       do i=0,nres
14989         do j=1,3
14990           gcart(j,i)=0.0d0
14991           gxcart(j,i)=0.0d0
14992         enddo
14993       enddo
14994       return
14995       end subroutine zerograd
14996 !-----------------------------------------------------------------------------
14997       real(kind=8) function fdum()
14998       fdum=0.0D0
14999       return
15000       end function fdum
15001 !-----------------------------------------------------------------------------
15002 ! intcartderiv.F
15003 !-----------------------------------------------------------------------------
15004       subroutine intcartderiv
15005 !      implicit real*8 (a-h,o-z)
15006 !      include 'DIMENSIONS'
15007 #ifdef MPI
15008       include 'mpif.h'
15009 #endif
15010 !      include 'COMMON.SETUP'
15011 !      include 'COMMON.CHAIN'
15012 !      include 'COMMON.VAR'
15013 !      include 'COMMON.GEO'
15014 !      include 'COMMON.INTERACT'
15015 !      include 'COMMON.DERIV'
15016 !      include 'COMMON.IOUNITS'
15017 !      include 'COMMON.LOCAL'
15018 !      include 'COMMON.SCCOR'
15019       real(kind=8) :: pi4,pi34
15020       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
15021       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
15022                     dcosomega,dsinomega !(3,3,maxres)
15023       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
15024
15025       integer :: i,j,k
15026       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
15027                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
15028                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
15029                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
15030       integer :: nres2
15031       nres2=2*nres
15032
15033 !el from module energy-------------
15034 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
15035 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
15036 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
15037
15038 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
15039 !el      allocate(dsintau(3,3,3,0:nres2))
15040 !el      allocate(dtauangle(3,3,3,0:nres2))
15041 !el      allocate(domicron(3,2,2,0:nres2))
15042 !el      allocate(dcosomicron(3,2,2,0:nres2))
15043
15044
15045
15046 #if defined(MPI) && defined(PARINTDER)
15047       if (nfgtasks.gt.1 .and. me.eq.king) &
15048         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
15049 #endif
15050       pi4 = 0.5d0*pipol
15051       pi34 = 3*pi4
15052
15053 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
15054 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
15055
15056 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
15057       do i=1,nres
15058         do j=1,3
15059           dtheta(j,1,i)=0.0d0
15060           dtheta(j,2,i)=0.0d0
15061           dphi(j,1,i)=0.0d0
15062           dphi(j,2,i)=0.0d0
15063           dphi(j,3,i)=0.0d0
15064         enddo
15065       enddo
15066 ! Derivatives of theta's
15067 #if defined(MPI) && defined(PARINTDER)
15068 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
15069       do i=max0(ithet_start-1,3),ithet_end
15070 #else
15071       do i=3,nres
15072 #endif
15073         cost=dcos(theta(i))
15074         sint=sqrt(1-cost*cost)
15075         do j=1,3
15076           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
15077           vbld(i-1)
15078           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
15079           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
15080           vbld(i)
15081           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
15082         enddo
15083       enddo
15084 #if defined(MPI) && defined(PARINTDER)
15085 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
15086       do i=max0(ithet_start-1,3),ithet_end
15087 #else
15088       do i=3,nres
15089 #endif
15090       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
15091         cost1=dcos(omicron(1,i))
15092         sint1=sqrt(1-cost1*cost1)
15093         cost2=dcos(omicron(2,i))
15094         sint2=sqrt(1-cost2*cost2)
15095        do j=1,3
15096 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
15097           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
15098           cost1*dc_norm(j,i-2))/ &
15099           vbld(i-1)
15100           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
15101           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
15102           +cost1*(dc_norm(j,i-1+nres)))/ &
15103           vbld(i-1+nres)
15104           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
15105 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
15106 !C Looks messy but better than if in loop
15107           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
15108           +cost2*dc_norm(j,i-1))/ &
15109           vbld(i)
15110           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
15111           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
15112            +cost2*(-dc_norm(j,i-1+nres)))/ &
15113           vbld(i-1+nres)
15114 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
15115           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
15116         enddo
15117        endif
15118       enddo
15119 !elwrite(iout,*) "after vbld write"
15120 ! Derivatives of phi:
15121 ! If phi is 0 or 180 degrees, then the formulas
15122 ! have to be derived by power series expansion of the
15123 ! conventional formulas around 0 and 180.
15124 #ifdef PARINTDER
15125       do i=iphi1_start,iphi1_end
15126 #else
15127       do i=4,nres
15128 #endif
15129 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
15130 ! the conventional case
15131         sint=dsin(theta(i))
15132         sint1=dsin(theta(i-1))
15133         sing=dsin(phi(i))
15134         cost=dcos(theta(i))
15135         cost1=dcos(theta(i-1))
15136         cosg=dcos(phi(i))
15137         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
15138         fac0=1.0d0/(sint1*sint)
15139         fac1=cost*fac0
15140         fac2=cost1*fac0
15141         fac3=cosg*cost1/(sint1*sint1)
15142         fac4=cosg*cost/(sint*sint)
15143 !    Obtaining the gamma derivatives from sine derivative
15144        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
15145            phi(i).gt.pi34.and.phi(i).le.pi.or. &
15146            phi(i).ge.-pi.and.phi(i).le.-pi34) then
15147          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
15148          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
15149          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
15150          do j=1,3
15151             ctgt=cost/sint
15152             ctgt1=cost1/sint1
15153             cosg_inv=1.0d0/cosg
15154             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
15155             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
15156               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
15157             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
15158             dsinphi(j,2,i)= &
15159               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
15160               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15161             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
15162             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
15163               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
15164 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15165             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
15166             endif
15167 ! Bug fixed 3/24/05 (AL)
15168          enddo
15169 !   Obtaining the gamma derivatives from cosine derivative
15170         else
15171            do j=1,3
15172            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
15173            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
15174            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
15175            dc_norm(j,i-3))/vbld(i-2)
15176            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
15177            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
15178            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
15179            dcostheta(j,1,i)
15180            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
15181            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
15182            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
15183            dc_norm(j,i-1))/vbld(i)
15184            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
15185            endif
15186          enddo
15187         endif
15188       enddo
15189 !alculate derivative of Tauangle
15190 #ifdef PARINTDER
15191       do i=itau_start,itau_end
15192 #else
15193       do i=3,nres
15194 !elwrite(iout,*) " vecpr",i,nres
15195 #endif
15196        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
15197 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
15198 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
15199 !c dtauangle(j,intertyp,dervityp,residue number)
15200 !c INTERTYP=1 SC...Ca...Ca..Ca
15201 ! the conventional case
15202         sint=dsin(theta(i))
15203         sint1=dsin(omicron(2,i-1))
15204         sing=dsin(tauangle(1,i))
15205         cost=dcos(theta(i))
15206         cost1=dcos(omicron(2,i-1))
15207         cosg=dcos(tauangle(1,i))
15208 !elwrite(iout,*) " vecpr5",i,nres
15209         do j=1,3
15210 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
15211 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
15212         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
15213 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
15214         enddo
15215         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
15216         fac0=1.0d0/(sint1*sint)
15217         fac1=cost*fac0
15218         fac2=cost1*fac0
15219         fac3=cosg*cost1/(sint1*sint1)
15220         fac4=cosg*cost/(sint*sint)
15221 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
15222 !    Obtaining the gamma derivatives from sine derivative
15223        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
15224            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
15225            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
15226          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
15227          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
15228          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
15229         do j=1,3
15230             ctgt=cost/sint
15231             ctgt1=cost1/sint1
15232             cosg_inv=1.0d0/cosg
15233             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
15234        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
15235        *vbld_inv(i-2+nres)
15236             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
15237             dsintau(j,1,2,i)= &
15238               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
15239               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15240 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
15241             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
15242 ! Bug fixed 3/24/05 (AL)
15243             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
15244               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
15245 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15246             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
15247          enddo
15248 !   Obtaining the gamma derivatives from cosine derivative
15249         else
15250            do j=1,3
15251            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
15252            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
15253            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
15254            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
15255            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
15256            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
15257            dcostheta(j,1,i)
15258            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
15259            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
15260            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
15261            dc_norm(j,i-1))/vbld(i)
15262            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
15263 !         write (iout,*) "else",i
15264          enddo
15265         endif
15266 !        do k=1,3
15267 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
15268 !        enddo
15269       enddo
15270 !C Second case Ca...Ca...Ca...SC
15271 #ifdef PARINTDER
15272       do i=itau_start,itau_end
15273 #else
15274       do i=4,nres
15275 #endif
15276        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
15277           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
15278 ! the conventional case
15279         sint=dsin(omicron(1,i))
15280         sint1=dsin(theta(i-1))
15281         sing=dsin(tauangle(2,i))
15282         cost=dcos(omicron(1,i))
15283         cost1=dcos(theta(i-1))
15284         cosg=dcos(tauangle(2,i))
15285 !        do j=1,3
15286 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
15287 !        enddo
15288         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
15289         fac0=1.0d0/(sint1*sint)
15290         fac1=cost*fac0
15291         fac2=cost1*fac0
15292         fac3=cosg*cost1/(sint1*sint1)
15293         fac4=cosg*cost/(sint*sint)
15294 !    Obtaining the gamma derivatives from sine derivative
15295        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
15296            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
15297            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
15298          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
15299          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
15300          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
15301         do j=1,3
15302             ctgt=cost/sint
15303             ctgt1=cost1/sint1
15304             cosg_inv=1.0d0/cosg
15305             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
15306               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
15307 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
15308 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
15309             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
15310             dsintau(j,2,2,i)= &
15311               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
15312               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15313 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
15314 !     & sing*ctgt*domicron(j,1,2,i),
15315 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15316             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
15317 ! Bug fixed 3/24/05 (AL)
15318             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
15319              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
15320 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15321             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
15322          enddo
15323 !   Obtaining the gamma derivatives from cosine derivative
15324         else
15325            do j=1,3
15326            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
15327            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
15328            dc_norm(j,i-3))/vbld(i-2)
15329            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
15330            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
15331            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
15332            dcosomicron(j,1,1,i)
15333            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
15334            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
15335            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
15336            dc_norm(j,i-1+nres))/vbld(i-1+nres)
15337            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
15338 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
15339          enddo
15340         endif
15341       enddo
15342
15343 !CC third case SC...Ca...Ca...SC
15344 #ifdef PARINTDER
15345
15346       do i=itau_start,itau_end
15347 #else
15348       do i=3,nres
15349 #endif
15350 ! the conventional case
15351       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
15352       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
15353         sint=dsin(omicron(1,i))
15354         sint1=dsin(omicron(2,i-1))
15355         sing=dsin(tauangle(3,i))
15356         cost=dcos(omicron(1,i))
15357         cost1=dcos(omicron(2,i-1))
15358         cosg=dcos(tauangle(3,i))
15359         do j=1,3
15360         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
15361 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
15362         enddo
15363         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
15364         fac0=1.0d0/(sint1*sint)
15365         fac1=cost*fac0
15366         fac2=cost1*fac0
15367         fac3=cosg*cost1/(sint1*sint1)
15368         fac4=cosg*cost/(sint*sint)
15369 !    Obtaining the gamma derivatives from sine derivative
15370        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
15371            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
15372            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
15373          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
15374          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
15375          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
15376         do j=1,3
15377             ctgt=cost/sint
15378             ctgt1=cost1/sint1
15379             cosg_inv=1.0d0/cosg
15380             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
15381               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
15382               *vbld_inv(i-2+nres)
15383             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
15384             dsintau(j,3,2,i)= &
15385               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
15386               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15387             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
15388 ! Bug fixed 3/24/05 (AL)
15389             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
15390               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
15391               *vbld_inv(i-1+nres)
15392 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15393             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
15394          enddo
15395 !   Obtaining the gamma derivatives from cosine derivative
15396         else
15397            do j=1,3
15398            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
15399            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
15400            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
15401            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
15402            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
15403            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
15404            dcosomicron(j,1,1,i)
15405            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
15406            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
15407            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
15408            dc_norm(j,i-1+nres))/vbld(i-1+nres)
15409            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
15410 !          write(iout,*) "else",i
15411          enddo
15412         endif
15413       enddo
15414
15415 #ifdef CRYST_SC
15416 !   Derivatives of side-chain angles alpha and omega
15417 #if defined(MPI) && defined(PARINTDER)
15418         do i=ibond_start,ibond_end
15419 #else
15420         do i=2,nres-1
15421 #endif
15422           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
15423              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
15424              fac6=fac5/vbld(i)
15425              fac7=fac5*fac5
15426              fac8=fac5/vbld(i+1)
15427              fac9=fac5/vbld(i+nres)
15428              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
15429              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
15430              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
15431              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
15432              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
15433              sina=sqrt(1-cosa*cosa)
15434              sino=dsin(omeg(i))
15435 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
15436              do j=1,3
15437                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
15438                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
15439                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
15440                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
15441                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
15442                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
15443                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
15444                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
15445                 vbld(i+nres))
15446                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
15447             enddo
15448 ! obtaining the derivatives of omega from sines
15449             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
15450                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
15451                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
15452                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
15453                dsin(theta(i+1)))
15454                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
15455                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
15456                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
15457                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
15458                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
15459                coso_inv=1.0d0/dcos(omeg(i))
15460                do j=1,3
15461                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
15462                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
15463                  (sino*dc_norm(j,i-1))/vbld(i)
15464                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
15465                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
15466                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
15467                  -sino*dc_norm(j,i)/vbld(i+1)
15468                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
15469                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
15470                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
15471                  vbld(i+nres)
15472                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
15473               enddo
15474            else
15475 !   obtaining the derivatives of omega from cosines
15476              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
15477              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
15478              fac12=fac10*sina
15479              fac13=fac12*fac12
15480              fac14=sina*sina
15481              do j=1,3
15482                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
15483                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
15484                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
15485                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
15486                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
15487                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
15488                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
15489                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
15490                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
15491                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
15492                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
15493                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
15494                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
15495                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
15496                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
15497             enddo
15498           endif
15499          else
15500            do j=1,3
15501              do k=1,3
15502                dalpha(k,j,i)=0.0d0
15503                domega(k,j,i)=0.0d0
15504              enddo
15505            enddo
15506          endif
15507        enddo
15508 #endif
15509 #if defined(MPI) && defined(PARINTDER)
15510       if (nfgtasks.gt.1) then
15511 #ifdef DEBUG
15512 !d      write (iout,*) "Gather dtheta"
15513 !d      call flush(iout)
15514       write (iout,*) "dtheta before gather"
15515       do i=1,nres
15516         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15517       enddo
15518 #endif
15519       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15520         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15521         king,FG_COMM,IERROR)
15522 #ifdef DEBUG
15523 !d      write (iout,*) "Gather dphi"
15524 !d      call flush(iout)
15525       write (iout,*) "dphi before gather"
15526       do i=1,nres
15527         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15528       enddo
15529 #endif
15530       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15531         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15532         king,FG_COMM,IERROR)
15533 !d      write (iout,*) "Gather dalpha"
15534 !d      call flush(iout)
15535 #ifdef CRYST_SC
15536       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15537         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15538         king,FG_COMM,IERROR)
15539 !d      write (iout,*) "Gather domega"
15540 !d      call flush(iout)
15541       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15542         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15543         king,FG_COMM,IERROR)
15544 #endif
15545       endif
15546 #endif
15547 #ifdef DEBUG
15548       write (iout,*) "dtheta after gather"
15549       do i=1,nres
15550         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15551       enddo
15552       write (iout,*) "dphi after gather"
15553       do i=1,nres
15554         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15555       enddo
15556       write (iout,*) "dalpha after gather"
15557       do i=1,nres
15558         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15559       enddo
15560       write (iout,*) "domega after gather"
15561       do i=1,nres
15562         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15563       enddo
15564 #endif
15565       return
15566       end subroutine intcartderiv
15567 !-----------------------------------------------------------------------------
15568       subroutine checkintcartgrad
15569 !      implicit real*8 (a-h,o-z)
15570 !      include 'DIMENSIONS'
15571 #ifdef MPI
15572       include 'mpif.h'
15573 #endif
15574 !      include 'COMMON.CHAIN'
15575 !      include 'COMMON.VAR'
15576 !      include 'COMMON.GEO'
15577 !      include 'COMMON.INTERACT'
15578 !      include 'COMMON.DERIV'
15579 !      include 'COMMON.IOUNITS'
15580 !      include 'COMMON.SETUP'
15581       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15582       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15583       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15584       real(kind=8),dimension(3) :: dc_norm_s
15585       real(kind=8) :: aincr=1.0d-5
15586       integer :: i,j
15587       real(kind=8) :: dcji
15588       do i=1,nres
15589         phi_s(i)=phi(i)
15590         theta_s(i)=theta(i)
15591         alph_s(i)=alph(i)
15592         omeg_s(i)=omeg(i)
15593       enddo
15594 ! Check theta gradient
15595       write (iout,*) &
15596        "Analytical (upper) and numerical (lower) gradient of theta"
15597       write (iout,*)
15598       do i=3,nres
15599         do j=1,3
15600           dcji=dc(j,i-2)
15601           dc(j,i-2)=dcji+aincr
15602           call chainbuild_cart
15603           call int_from_cart1(.false.)
15604           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15605           dc(j,i-2)=dcji
15606           dcji=dc(j,i-1)
15607           dc(j,i-1)=dc(j,i-1)+aincr
15608           call chainbuild_cart
15609           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15610           dc(j,i-1)=dcji
15611         enddo
15612 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15613 !el          (dtheta(j,2,i),j=1,3)
15614 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15615 !el          (dthetanum(j,2,i),j=1,3)
15616 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15617 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15618 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15619 !el        write (iout,*)
15620       enddo
15621 ! Check gamma gradient
15622       write (iout,*) &
15623        "Analytical (upper) and numerical (lower) gradient of gamma"
15624       do i=4,nres
15625         do j=1,3
15626           dcji=dc(j,i-3)
15627           dc(j,i-3)=dcji+aincr
15628           call chainbuild_cart
15629           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15630           dc(j,i-3)=dcji
15631           dcji=dc(j,i-2)
15632           dc(j,i-2)=dcji+aincr
15633           call chainbuild_cart
15634           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15635           dc(j,i-2)=dcji
15636           dcji=dc(j,i-1)
15637           dc(j,i-1)=dc(j,i-1)+aincr
15638           call chainbuild_cart
15639           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15640           dc(j,i-1)=dcji
15641         enddo
15642 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15643 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15644 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15645 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15646 !el        write (iout,'(5x,3(3f10.5,5x))') &
15647 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15648 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15649 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15650 !el        write (iout,*)
15651       enddo
15652 ! Check alpha gradient
15653       write (iout,*) &
15654        "Analytical (upper) and numerical (lower) gradient of alpha"
15655       do i=2,nres-1
15656        if(itype(i).ne.10) then
15657             do j=1,3
15658               dcji=dc(j,i-1)
15659               dc(j,i-1)=dcji+aincr
15660               call chainbuild_cart
15661               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15662               /aincr
15663               dc(j,i-1)=dcji
15664               dcji=dc(j,i)
15665               dc(j,i)=dcji+aincr
15666               call chainbuild_cart
15667               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15668               /aincr
15669               dc(j,i)=dcji
15670               dcji=dc(j,i+nres)
15671               dc(j,i+nres)=dc(j,i+nres)+aincr
15672               call chainbuild_cart
15673               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15674               /aincr
15675              dc(j,i+nres)=dcji
15676             enddo
15677           endif
15678 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15679 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15680 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15681 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15682 !el        write (iout,'(5x,3(3f10.5,5x))') &
15683 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15684 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15685 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15686 !el        write (iout,*)
15687       enddo
15688 !     Check omega gradient
15689       write (iout,*) &
15690        "Analytical (upper) and numerical (lower) gradient of omega"
15691       do i=2,nres-1
15692        if(itype(i).ne.10) then
15693             do j=1,3
15694               dcji=dc(j,i-1)
15695               dc(j,i-1)=dcji+aincr
15696               call chainbuild_cart
15697               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15698               /aincr
15699               dc(j,i-1)=dcji
15700               dcji=dc(j,i)
15701               dc(j,i)=dcji+aincr
15702               call chainbuild_cart
15703               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15704               /aincr
15705               dc(j,i)=dcji
15706               dcji=dc(j,i+nres)
15707               dc(j,i+nres)=dc(j,i+nres)+aincr
15708               call chainbuild_cart
15709               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15710               /aincr
15711              dc(j,i+nres)=dcji
15712             enddo
15713           endif
15714 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15715 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15716 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15717 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15718 !el        write (iout,'(5x,3(3f10.5,5x))') &
15719 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15720 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15721 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15722 !el        write (iout,*)
15723       enddo
15724       return
15725       end subroutine checkintcartgrad
15726 !-----------------------------------------------------------------------------
15727 ! q_measure.F
15728 !-----------------------------------------------------------------------------
15729       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15730 !      implicit real*8 (a-h,o-z)
15731 !      include 'DIMENSIONS'
15732 !      include 'COMMON.IOUNITS'
15733 !      include 'COMMON.CHAIN'
15734 !      include 'COMMON.INTERACT'
15735 !      include 'COMMON.VAR'
15736       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15737       integer :: kkk,nsep=3
15738       real(kind=8) :: qm        !dist,
15739       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15740       logical :: lprn=.false.
15741       logical :: flag
15742 !      real(kind=8) :: sigm,x
15743
15744 !el      sigm(x)=0.25d0*x     ! local function
15745       qqmax=1.0d10
15746       do kkk=1,nperm
15747       qq = 0.0d0
15748       nl=0
15749        if(flag) then
15750         do il=seg1+nsep,seg2
15751           do jl=seg1,il-nsep
15752             nl=nl+1
15753             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15754                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15755                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15756             dij=dist(il,jl)
15757             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15758             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15759               nl=nl+1
15760               d0ijCM=dsqrt( &
15761                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15762                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15763                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15764               dijCM=dist(il+nres,jl+nres)
15765               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15766             endif
15767             qq = qq+qqij+qqijCM
15768           enddo
15769         enddo
15770         qq = qq/nl
15771       else
15772       do il=seg1,seg2
15773         if((seg3-il).lt.3) then
15774              secseg=il+3
15775         else
15776              secseg=seg3
15777         endif
15778           do jl=secseg,seg4
15779             nl=nl+1
15780             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15781                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15782                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15783             dij=dist(il,jl)
15784             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15785             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15786               nl=nl+1
15787               d0ijCM=dsqrt( &
15788                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15789                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15790                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15791               dijCM=dist(il+nres,jl+nres)
15792               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15793             endif
15794             qq = qq+qqij+qqijCM
15795           enddo
15796         enddo
15797       qq = qq/nl
15798       endif
15799       if (qqmax.le.qq) qqmax=qq
15800       enddo
15801       qwolynes=1.0d0-qqmax
15802       return
15803       end function qwolynes
15804 !-----------------------------------------------------------------------------
15805       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15806 !      implicit real*8 (a-h,o-z)
15807 !      include 'DIMENSIONS'
15808 !      include 'COMMON.IOUNITS'
15809 !      include 'COMMON.CHAIN'
15810 !      include 'COMMON.INTERACT'
15811 !      include 'COMMON.VAR'
15812 !      include 'COMMON.MD'
15813       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15814       integer :: nsep=3, kkk
15815 !el      real(kind=8) :: dist
15816       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15817       logical :: lprn=.false.
15818       logical :: flag
15819       real(kind=8) :: sim,dd0,fac,ddqij
15820 !el      sigm(x)=0.25d0*x            ! local function
15821       do kkk=1,nperm
15822       do i=0,nres
15823         do j=1,3
15824           dqwol(j,i)=0.0d0
15825           dxqwol(j,i)=0.0d0
15826         enddo
15827       enddo
15828       nl=0
15829        if(flag) then
15830         do il=seg1+nsep,seg2
15831           do jl=seg1,il-nsep
15832             nl=nl+1
15833             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15834                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15835                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15836             dij=dist(il,jl)
15837             sim = 1.0d0/sigm(d0ij)
15838             sim = sim*sim
15839             dd0 = dij-d0ij
15840             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15841             do k=1,3
15842               ddqij = (c(k,il)-c(k,jl))*fac
15843               dqwol(k,il)=dqwol(k,il)+ddqij
15844               dqwol(k,jl)=dqwol(k,jl)-ddqij
15845             enddo
15846
15847             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15848               nl=nl+1
15849               d0ijCM=dsqrt( &
15850                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15851                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15852                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15853               dijCM=dist(il+nres,jl+nres)
15854               sim = 1.0d0/sigm(d0ijCM)
15855               sim = sim*sim
15856               dd0=dijCM-d0ijCM
15857               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15858               do k=1,3
15859                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15860                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15861                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15862               enddo
15863             endif
15864           enddo
15865         enddo
15866        else
15867         do il=seg1,seg2
15868         if((seg3-il).lt.3) then
15869              secseg=il+3
15870         else
15871              secseg=seg3
15872         endif
15873           do jl=secseg,seg4
15874             nl=nl+1
15875             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15876                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15877                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15878             dij=dist(il,jl)
15879             sim = 1.0d0/sigm(d0ij)
15880             sim = sim*sim
15881             dd0 = dij-d0ij
15882             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15883             do k=1,3
15884               ddqij = (c(k,il)-c(k,jl))*fac
15885               dqwol(k,il)=dqwol(k,il)+ddqij
15886               dqwol(k,jl)=dqwol(k,jl)-ddqij
15887             enddo
15888             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15889               nl=nl+1
15890               d0ijCM=dsqrt( &
15891                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15892                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15893                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15894               dijCM=dist(il+nres,jl+nres)
15895               sim = 1.0d0/sigm(d0ijCM)
15896               sim=sim*sim
15897               dd0 = dijCM-d0ijCM
15898               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15899               do k=1,3
15900                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15901                dxqwol(k,il)=dxqwol(k,il)+ddqij
15902                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15903               enddo
15904             endif
15905           enddo
15906         enddo
15907       endif
15908       enddo
15909        do i=0,nres
15910          do j=1,3
15911            dqwol(j,i)=dqwol(j,i)/nl
15912            dxqwol(j,i)=dxqwol(j,i)/nl
15913          enddo
15914        enddo
15915       return
15916       end subroutine qwolynes_prim
15917 !-----------------------------------------------------------------------------
15918       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15919 !      implicit real*8 (a-h,o-z)
15920 !      include 'DIMENSIONS'
15921 !      include 'COMMON.IOUNITS'
15922 !      include 'COMMON.CHAIN'
15923 !      include 'COMMON.INTERACT'
15924 !      include 'COMMON.VAR'
15925       integer :: seg1,seg2,seg3,seg4
15926       logical :: flag
15927       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15928       real(kind=8),dimension(3,0:2*nres) :: cdummy
15929       real(kind=8) :: q1,q2
15930       real(kind=8) :: delta=1.0d-10
15931       integer :: i,j
15932
15933       do i=0,nres
15934         do j=1,3
15935           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15936           cdummy(j,i)=c(j,i)
15937           c(j,i)=c(j,i)+delta
15938           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15939           qwolan(j,i)=(q2-q1)/delta
15940           c(j,i)=cdummy(j,i)
15941         enddo
15942       enddo
15943       do i=0,nres
15944         do j=1,3
15945           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15946           cdummy(j,i+nres)=c(j,i+nres)
15947           c(j,i+nres)=c(j,i+nres)+delta
15948           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15949           qwolxan(j,i)=(q2-q1)/delta
15950           c(j,i+nres)=cdummy(j,i+nres)
15951         enddo
15952       enddo
15953 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15954 !      do i=0,nct
15955 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15956 !      enddo
15957 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15958 !      do i=0,nct
15959 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15960 !      enddo
15961       return
15962       end subroutine qwol_num
15963 !-----------------------------------------------------------------------------
15964       subroutine EconstrQ
15965 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15966 !      implicit real*8 (a-h,o-z)
15967 !      include 'DIMENSIONS'
15968 !      include 'COMMON.CONTROL'
15969 !      include 'COMMON.VAR'
15970 !      include 'COMMON.MD'
15971       use MD_data
15972 !#ifndef LANG0
15973 !      include 'COMMON.LANGEVIN'
15974 !#else
15975 !      include 'COMMON.LANGEVIN.lang0'
15976 !#endif
15977 !      include 'COMMON.CHAIN'
15978 !      include 'COMMON.DERIV'
15979 !      include 'COMMON.GEO'
15980 !      include 'COMMON.LOCAL'
15981 !      include 'COMMON.INTERACT'
15982 !      include 'COMMON.IOUNITS'
15983 !      include 'COMMON.NAMES'
15984 !      include 'COMMON.TIME1'
15985       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15986       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15987                    duconst,duxconst
15988       integer :: kstart,kend,lstart,lend,idummy
15989       real(kind=8) :: delta=1.0d-7
15990       integer :: i,j,k,ii
15991       do i=0,nres
15992          do j=1,3
15993             duconst(j,i)=0.0d0
15994             dudconst(j,i)=0.0d0
15995             duxconst(j,i)=0.0d0
15996             dudxconst(j,i)=0.0d0
15997          enddo
15998       enddo
15999       Uconst=0.0d0
16000       do i=1,nfrag
16001          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16002            idummy,idummy)
16003          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
16004 ! Calculating the derivatives of Constraint energy with respect to Q
16005          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
16006            qinfrag(i,iset))
16007 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
16008 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
16009 !         hmnum=(hm2-hm1)/delta
16010 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
16011 !     &   qinfrag(i,iset))
16012 !         write(iout,*) "harmonicnum frag", hmnum
16013 ! Calculating the derivatives of Q with respect to cartesian coordinates
16014          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16015           idummy,idummy)
16016 !         write(iout,*) "dqwol "
16017 !         do ii=1,nres
16018 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16019 !         enddo
16020 !         write(iout,*) "dxqwol "
16021 !         do ii=1,nres
16022 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16023 !         enddo
16024 ! Calculating numerical gradients of dU/dQi and dQi/dxi
16025 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
16026 !     &  ,idummy,idummy)
16027 !  The gradients of Uconst in Cs
16028          do ii=0,nres
16029             do j=1,3
16030                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
16031                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
16032             enddo
16033          enddo
16034       enddo
16035       do i=1,npair
16036          kstart=ifrag(1,ipair(1,i,iset),iset)
16037          kend=ifrag(2,ipair(1,i,iset),iset)
16038          lstart=ifrag(1,ipair(2,i,iset),iset)
16039          lend=ifrag(2,ipair(2,i,iset),iset)
16040          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
16041          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
16042 !  Calculating dU/dQ
16043          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
16044 !         hm1=harmonic(qpair(i),qinpair(i,iset))
16045 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
16046 !         hmnum=(hm2-hm1)/delta
16047 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
16048 !     &   qinpair(i,iset))
16049 !         write(iout,*) "harmonicnum pair ", hmnum
16050 ! Calculating dQ/dXi
16051          call qwolynes_prim(kstart,kend,.false.,&
16052           lstart,lend)
16053 !         write(iout,*) "dqwol "
16054 !         do ii=1,nres
16055 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16056 !         enddo
16057 !         write(iout,*) "dxqwol "
16058 !         do ii=1,nres
16059 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16060 !        enddo
16061 ! Calculating numerical gradients
16062 !        call qwol_num(kstart,kend,.false.
16063 !     &  ,lstart,lend)
16064 ! The gradients of Uconst in Cs
16065          do ii=0,nres
16066             do j=1,3
16067                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
16068                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
16069             enddo
16070          enddo
16071       enddo
16072 !      write(iout,*) "Uconst inside subroutine ", Uconst
16073 ! Transforming the gradients from Cs to dCs for the backbone
16074       do i=0,nres
16075          do j=i+1,nres
16076            do k=1,3
16077              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
16078            enddo
16079          enddo
16080       enddo
16081 !  Transforming the gradients from Cs to dCs for the side chains
16082       do i=1,nres
16083          do j=1,3
16084            dudxconst(j,i)=duxconst(j,i)
16085          enddo
16086       enddo
16087 !      write(iout,*) "dU/ddc backbone "
16088 !       do ii=0,nres
16089 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
16090 !      enddo
16091 !      write(iout,*) "dU/ddX side chain "
16092 !      do ii=1,nres
16093 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
16094 !      enddo
16095 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
16096 !      call dEconstrQ_num
16097       return
16098       end subroutine EconstrQ
16099 !-----------------------------------------------------------------------------
16100       subroutine dEconstrQ_num
16101 ! Calculating numerical dUconst/ddc and dUconst/ddx
16102 !      implicit real*8 (a-h,o-z)
16103 !      include 'DIMENSIONS'
16104 !      include 'COMMON.CONTROL'
16105 !      include 'COMMON.VAR'
16106 !      include 'COMMON.MD'
16107       use MD_data
16108 !#ifndef LANG0
16109 !      include 'COMMON.LANGEVIN'
16110 !#else
16111 !      include 'COMMON.LANGEVIN.lang0'
16112 !#endif
16113 !      include 'COMMON.CHAIN'
16114 !      include 'COMMON.DERIV'
16115 !      include 'COMMON.GEO'
16116 !      include 'COMMON.LOCAL'
16117 !      include 'COMMON.INTERACT'
16118 !      include 'COMMON.IOUNITS'
16119 !      include 'COMMON.NAMES'
16120 !      include 'COMMON.TIME1'
16121       real(kind=8) :: uzap1,uzap2
16122       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
16123       integer :: kstart,kend,lstart,lend,idummy
16124       real(kind=8) :: delta=1.0d-7
16125 !el local variables
16126       integer :: i,ii,j
16127 !     real(kind=8) ::
16128 !     For the backbone
16129       do i=0,nres-1
16130          do j=1,3
16131             dUcartan(j,i)=0.0d0
16132             cdummy(j,i)=dc(j,i)
16133             dc(j,i)=dc(j,i)+delta
16134             call chainbuild_cart
16135             uzap2=0.0d0
16136             do ii=1,nfrag
16137              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
16138                 idummy,idummy)
16139                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
16140                 qinfrag(ii,iset))
16141             enddo
16142             do ii=1,npair
16143                kstart=ifrag(1,ipair(1,ii,iset),iset)
16144                kend=ifrag(2,ipair(1,ii,iset),iset)
16145                lstart=ifrag(1,ipair(2,ii,iset),iset)
16146                lend=ifrag(2,ipair(2,ii,iset),iset)
16147                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
16148                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
16149                  qinpair(ii,iset))
16150             enddo
16151             dc(j,i)=cdummy(j,i)
16152             call chainbuild_cart
16153             uzap1=0.0d0
16154              do ii=1,nfrag
16155              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
16156                 idummy,idummy)
16157                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
16158                 qinfrag(ii,iset))
16159             enddo
16160             do ii=1,npair
16161                kstart=ifrag(1,ipair(1,ii,iset),iset)
16162                kend=ifrag(2,ipair(1,ii,iset),iset)
16163                lstart=ifrag(1,ipair(2,ii,iset),iset)
16164                lend=ifrag(2,ipair(2,ii,iset),iset)
16165                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
16166                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
16167                 qinpair(ii,iset))
16168             enddo
16169             ducartan(j,i)=(uzap2-uzap1)/(delta)
16170          enddo
16171       enddo
16172 ! Calculating numerical gradients for dU/ddx
16173       do i=0,nres-1
16174          duxcartan(j,i)=0.0d0
16175          do j=1,3
16176             cdummy(j,i)=dc(j,i+nres)
16177             dc(j,i+nres)=dc(j,i+nres)+delta
16178             call chainbuild_cart
16179             uzap2=0.0d0
16180             do ii=1,nfrag
16181              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
16182                 idummy,idummy)
16183                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
16184                 qinfrag(ii,iset))
16185             enddo
16186             do ii=1,npair
16187                kstart=ifrag(1,ipair(1,ii,iset),iset)
16188                kend=ifrag(2,ipair(1,ii,iset),iset)
16189                lstart=ifrag(1,ipair(2,ii,iset),iset)
16190                lend=ifrag(2,ipair(2,ii,iset),iset)
16191                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
16192                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
16193                 qinpair(ii,iset))
16194             enddo
16195             dc(j,i+nres)=cdummy(j,i)
16196             call chainbuild_cart
16197             uzap1=0.0d0
16198              do ii=1,nfrag
16199                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
16200                 ifrag(2,ii,iset),.true.,idummy,idummy)
16201                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
16202                 qinfrag(ii,iset))
16203             enddo
16204             do ii=1,npair
16205                kstart=ifrag(1,ipair(1,ii,iset),iset)
16206                kend=ifrag(2,ipair(1,ii,iset),iset)
16207                lstart=ifrag(1,ipair(2,ii,iset),iset)
16208                lend=ifrag(2,ipair(2,ii,iset),iset)
16209                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
16210                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
16211                 qinpair(ii,iset))
16212             enddo
16213             duxcartan(j,i)=(uzap2-uzap1)/(delta)
16214          enddo
16215       enddo
16216       write(iout,*) "Numerical dUconst/ddc backbone "
16217       do ii=0,nres
16218         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
16219       enddo
16220 !      write(iout,*) "Numerical dUconst/ddx side-chain "
16221 !      do ii=1,nres
16222 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
16223 !      enddo
16224       return
16225       end subroutine dEconstrQ_num
16226 !-----------------------------------------------------------------------------
16227 ! ssMD.F
16228 !-----------------------------------------------------------------------------
16229       subroutine check_energies
16230
16231 !      use random, only: ran_number
16232
16233 !      implicit none
16234 !     Includes
16235 !      include 'DIMENSIONS'
16236 !      include 'COMMON.CHAIN'
16237 !      include 'COMMON.VAR'
16238 !      include 'COMMON.IOUNITS'
16239 !      include 'COMMON.SBRIDGE'
16240 !      include 'COMMON.LOCAL'
16241 !      include 'COMMON.GEO'
16242
16243 !     External functions
16244 !EL      double precision ran_number
16245 !EL      external ran_number
16246
16247 !     Local variables
16248       integer :: i,j,k,l,lmax,p,pmax
16249       real(kind=8) :: rmin,rmax
16250       real(kind=8) :: eij
16251
16252       real(kind=8) :: d
16253       real(kind=8) :: wi,rij,tj,pj
16254 !      return
16255
16256       i=5
16257       j=14
16258
16259       d=dsc(1)
16260       rmin=2.0D0
16261       rmax=12.0D0
16262
16263       lmax=10000
16264       pmax=1
16265
16266       do k=1,3
16267         c(k,i)=0.0D0
16268         c(k,j)=0.0D0
16269         c(k,nres+i)=0.0D0
16270         c(k,nres+j)=0.0D0
16271       enddo
16272
16273       do l=1,lmax
16274
16275 !t        wi=ran_number(0.0D0,pi)
16276 !        wi=ran_number(0.0D0,pi/6.0D0)
16277 !        wi=0.0D0
16278 !t        tj=ran_number(0.0D0,pi)
16279 !t        pj=ran_number(0.0D0,pi)
16280 !        pj=ran_number(0.0D0,pi/6.0D0)
16281 !        pj=0.0D0
16282
16283         do p=1,pmax
16284 !t           rij=ran_number(rmin,rmax)
16285
16286            c(1,j)=d*sin(pj)*cos(tj)
16287            c(2,j)=d*sin(pj)*sin(tj)
16288            c(3,j)=d*cos(pj)
16289
16290            c(3,nres+i)=-rij
16291
16292            c(1,i)=d*sin(wi)
16293            c(3,i)=-rij-d*cos(wi)
16294
16295            do k=1,3
16296               dc(k,nres+i)=c(k,nres+i)-c(k,i)
16297               dc_norm(k,nres+i)=dc(k,nres+i)/d
16298               dc(k,nres+j)=c(k,nres+j)-c(k,j)
16299               dc_norm(k,nres+j)=dc(k,nres+j)/d
16300            enddo
16301
16302            call dyn_ssbond_ene(i,j,eij)
16303         enddo
16304       enddo
16305       call exit(1)
16306       return
16307       end subroutine check_energies
16308 !-----------------------------------------------------------------------------
16309       subroutine dyn_ssbond_ene(resi,resj,eij)
16310 !      implicit none
16311 !      Includes
16312       use calc_data
16313       use comm_sschecks
16314 !      include 'DIMENSIONS'
16315 !      include 'COMMON.SBRIDGE'
16316 !      include 'COMMON.CHAIN'
16317 !      include 'COMMON.DERIV'
16318 !      include 'COMMON.LOCAL'
16319 !      include 'COMMON.INTERACT'
16320 !      include 'COMMON.VAR'
16321 !      include 'COMMON.IOUNITS'
16322 !      include 'COMMON.CALC'
16323 #ifndef CLUST
16324 #ifndef WHAM
16325        use MD_data
16326 !      include 'COMMON.MD'
16327 !      use MD, only: totT,t_bath
16328 #endif
16329 #endif
16330 !     External functions
16331 !EL      double precision h_base
16332 !EL      external h_base
16333
16334 !     Input arguments
16335       integer :: resi,resj
16336
16337 !     Output arguments
16338       real(kind=8) :: eij
16339
16340 !     Local variables
16341       logical :: havebond
16342       integer itypi,itypj
16343       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
16344       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
16345       real(kind=8),dimension(3) :: dcosom1,dcosom2
16346       real(kind=8) :: ed
16347       real(kind=8) :: pom1,pom2
16348       real(kind=8) :: ljA,ljB,ljXs
16349       real(kind=8),dimension(1:3) :: d_ljB
16350       real(kind=8) :: ssA,ssB,ssC,ssXs
16351       real(kind=8) :: ssxm,ljxm,ssm,ljm
16352       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
16353       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
16354       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
16355 !-------FIRST METHOD
16356       real(kind=8) :: xm
16357       real(kind=8),dimension(1:3) :: d_xm
16358 !-------END FIRST METHOD
16359 !-------SECOND METHOD
16360 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
16361 !-------END SECOND METHOD
16362
16363 !-------TESTING CODE
16364 !el      logical :: checkstop,transgrad
16365 !el      common /sschecks/ checkstop,transgrad
16366
16367       integer :: icheck,nicheck,jcheck,njcheck
16368       real(kind=8),dimension(-1:1) :: echeck
16369       real(kind=8) :: deps,ssx0,ljx0
16370 !-------END TESTING CODE
16371
16372       eij=0.0d0
16373       i=resi
16374       j=resj
16375
16376 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
16377 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
16378
16379       itypi=itype(i)
16380       dxi=dc_norm(1,nres+i)
16381       dyi=dc_norm(2,nres+i)
16382       dzi=dc_norm(3,nres+i)
16383       dsci_inv=vbld_inv(i+nres)
16384
16385       itypj=itype(j)
16386       xj=c(1,nres+j)-c(1,nres+i)
16387       yj=c(2,nres+j)-c(2,nres+i)
16388       zj=c(3,nres+j)-c(3,nres+i)
16389       dxj=dc_norm(1,nres+j)
16390       dyj=dc_norm(2,nres+j)
16391       dzj=dc_norm(3,nres+j)
16392       dscj_inv=vbld_inv(j+nres)
16393
16394       chi1=chi(itypi,itypj)
16395       chi2=chi(itypj,itypi)
16396       chi12=chi1*chi2
16397       chip1=chip(itypi)
16398       chip2=chip(itypj)
16399       chip12=chip1*chip2
16400       alf1=alp(itypi)
16401       alf2=alp(itypj)
16402       alf12=0.5D0*(alf1+alf2)
16403
16404       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16405       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
16406 !     The following are set in sc_angular
16407 !      erij(1)=xj*rij
16408 !      erij(2)=yj*rij
16409 !      erij(3)=zj*rij
16410 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
16411 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
16412 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
16413       call sc_angular
16414       rij=1.0D0/rij  ! Reset this so it makes sense
16415
16416       sig0ij=sigma(itypi,itypj)
16417       sig=sig0ij*dsqrt(1.0D0/sigsq)
16418
16419       ljXs=sig-sig0ij
16420       ljA=eps1*eps2rt**2*eps3rt**2
16421       ljB=ljA*bb(itypi,itypj)
16422       ljA=ljA*aa(itypi,itypj)
16423       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16424
16425       ssXs=d0cm
16426       deltat1=1.0d0-om1
16427       deltat2=1.0d0+om2
16428       deltat12=om2-om1+2.0d0
16429       cosphi=om12-om1*om2
16430       ssA=akcm
16431       ssB=akct*deltat12
16432       ssC=ss_depth &
16433            +akth*(deltat1*deltat1+deltat2*deltat2) &
16434            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
16435       ssxm=ssXs-0.5D0*ssB/ssA
16436
16437 !-------TESTING CODE
16438 !$$$c     Some extra output
16439 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
16440 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16441 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
16442 !$$$      if (ssx0.gt.0.0d0) then
16443 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
16444 !$$$      else
16445 !$$$        ssx0=ssxm
16446 !$$$      endif
16447 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16448 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
16449 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
16450 !$$$      return
16451 !-------END TESTING CODE
16452
16453 !-------TESTING CODE
16454 !     Stop and plot energy and derivative as a function of distance
16455       if (checkstop) then
16456         ssm=ssC-0.25D0*ssB*ssB/ssA
16457         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16458         if (ssm.lt.ljm .and. &
16459              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
16460           nicheck=1000
16461           njcheck=1
16462           deps=0.5d-7
16463         else
16464           checkstop=.false.
16465         endif
16466       endif
16467       if (.not.checkstop) then
16468         nicheck=0
16469         njcheck=-1
16470       endif
16471
16472       do icheck=0,nicheck
16473       do jcheck=-1,njcheck
16474       if (checkstop) rij=(ssxm-1.0d0)+ &
16475              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
16476 !-------END TESTING CODE
16477
16478       if (rij.gt.ljxm) then
16479         havebond=.false.
16480         ljd=rij-ljXs
16481         fac=(1.0D0/ljd)**expon
16482         e1=fac*fac*aa(itypi,itypj)
16483         e2=fac*bb(itypi,itypj)
16484         eij=eps1*eps2rt*eps3rt*(e1+e2)
16485         eps2der=eij*eps3rt
16486         eps3der=eij*eps2rt
16487         eij=eij*eps2rt*eps3rt
16488
16489         sigder=-sig/sigsq
16490         e1=e1*eps1*eps2rt**2*eps3rt**2
16491         ed=-expon*(e1+eij)/ljd
16492         sigder=ed*sigder
16493         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16494         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16495         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
16496              -2.0D0*alf12*eps3der+sigder*sigsq_om12
16497       else if (rij.lt.ssxm) then
16498         havebond=.true.
16499         ssd=rij-ssXs
16500         eij=ssA*ssd*ssd+ssB*ssd+ssC
16501
16502         ed=2*akcm*ssd+akct*deltat12
16503         pom1=akct*ssd
16504         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
16505         eom1=-2*akth*deltat1-pom1-om2*pom2
16506         eom2= 2*akth*deltat2+pom1-om1*pom2
16507         eom12=pom2
16508       else
16509         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16510
16511         d_ssxm(1)=0.5D0*akct/ssA
16512         d_ssxm(2)=-d_ssxm(1)
16513         d_ssxm(3)=0.0D0
16514
16515         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16516         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16517         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16518         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16519
16520 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16521         xm=0.5d0*(ssxm+ljxm)
16522         do k=1,3
16523           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16524         enddo
16525         if (rij.lt.xm) then
16526           havebond=.true.
16527           ssm=ssC-0.25D0*ssB*ssB/ssA
16528           d_ssm(1)=0.5D0*akct*ssB/ssA
16529           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16530           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16531           d_ssm(3)=omega
16532           f1=(rij-xm)/(ssxm-xm)
16533           f2=(rij-ssxm)/(xm-ssxm)
16534           h1=h_base(f1,hd1)
16535           h2=h_base(f2,hd2)
16536           eij=ssm*h1+Ht*h2
16537           delta_inv=1.0d0/(xm-ssxm)
16538           deltasq_inv=delta_inv*delta_inv
16539           fac=ssm*hd1-Ht*hd2
16540           fac1=deltasq_inv*fac*(xm-rij)
16541           fac2=deltasq_inv*fac*(rij-ssxm)
16542           ed=delta_inv*(Ht*hd2-ssm*hd1)
16543           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16544           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16545           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16546         else
16547           havebond=.false.
16548           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16549           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16550           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16551           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16552                alf12/eps3rt)
16553           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16554           f1=(rij-ljxm)/(xm-ljxm)
16555           f2=(rij-xm)/(ljxm-xm)
16556           h1=h_base(f1,hd1)
16557           h2=h_base(f2,hd2)
16558           eij=Ht*h1+ljm*h2
16559           delta_inv=1.0d0/(ljxm-xm)
16560           deltasq_inv=delta_inv*delta_inv
16561           fac=Ht*hd1-ljm*hd2
16562           fac1=deltasq_inv*fac*(ljxm-rij)
16563           fac2=deltasq_inv*fac*(rij-xm)
16564           ed=delta_inv*(ljm*hd2-Ht*hd1)
16565           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16566           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16567           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16568         endif
16569 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16570
16571 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16572 !$$$        ssd=rij-ssXs
16573 !$$$        ljd=rij-ljXs
16574 !$$$        fac1=rij-ljxm
16575 !$$$        fac2=rij-ssxm
16576 !$$$
16577 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16578 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16579 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16580 !$$$
16581 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16582 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16583 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16584 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16585 !$$$        d_ssm(3)=omega
16586 !$$$
16587 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16588 !$$$        do k=1,3
16589 !$$$          d_ljm(k)=ljm*d_ljB(k)
16590 !$$$        enddo
16591 !$$$        ljm=ljm*ljB
16592 !$$$
16593 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16594 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16595 !$$$        d_ss(2)=akct*ssd
16596 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16597 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16598 !$$$        d_ss(3)=omega
16599 !$$$
16600 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16601 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16602 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16603 !$$$        do k=1,3
16604 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16605 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16606 !$$$        enddo
16607 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16608 !$$$
16609 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16610 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16611 !$$$        h1=h_base(f1,hd1)
16612 !$$$        h2=h_base(f2,hd2)
16613 !$$$        eij=ss*h1+ljf*h2
16614 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16615 !$$$        deltasq_inv=delta_inv*delta_inv
16616 !$$$        fac=ljf*hd2-ss*hd1
16617 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16618 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16619 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16620 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16621 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16622 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16623 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16624 !$$$
16625 !$$$        havebond=.false.
16626 !$$$        if (ed.gt.0.0d0) havebond=.true.
16627 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16628
16629       endif
16630
16631       if (havebond) then
16632 !#ifndef CLUST
16633 !#ifndef WHAM
16634 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16635 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16636 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16637 !        endif
16638 !#endif
16639 !#endif
16640         dyn_ssbond_ij(i,j)=eij
16641       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16642         dyn_ssbond_ij(i,j)=1.0d300
16643 !#ifndef CLUST
16644 !#ifndef WHAM
16645 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16646 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16647 !#endif
16648 !#endif
16649       endif
16650
16651 !-------TESTING CODE
16652 !el      if (checkstop) then
16653         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16654              "CHECKSTOP",rij,eij,ed
16655         echeck(jcheck)=eij
16656 !el      endif
16657       enddo
16658       if (checkstop) then
16659         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16660       endif
16661       enddo
16662       if (checkstop) then
16663         transgrad=.true.
16664         checkstop=.false.
16665       endif
16666 !-------END TESTING CODE
16667
16668       do k=1,3
16669         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16670         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16671       enddo
16672       do k=1,3
16673         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16674       enddo
16675       do k=1,3
16676         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16677              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16678              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16679         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16680              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16681              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16682       enddo
16683 !grad      do k=i,j-1
16684 !grad        do l=1,3
16685 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16686 !grad        enddo
16687 !grad      enddo
16688
16689       do l=1,3
16690         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16691         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16692       enddo
16693
16694       return
16695       end subroutine dyn_ssbond_ene
16696 !-----------------------------------------------------------------------------
16697       real(kind=8) function h_base(x,deriv)
16698 !     A smooth function going 0->1 in range [0,1]
16699 !     It should NOT be called outside range [0,1], it will not work there.
16700       implicit none
16701
16702 !     Input arguments
16703       real(kind=8) :: x
16704
16705 !     Output arguments
16706       real(kind=8) :: deriv
16707
16708 !     Local variables
16709       real(kind=8) :: xsq
16710
16711
16712 !     Two parabolas put together.  First derivative zero at extrema
16713 !$$$      if (x.lt.0.5D0) then
16714 !$$$        h_base=2.0D0*x*x
16715 !$$$        deriv=4.0D0*x
16716 !$$$      else
16717 !$$$        deriv=1.0D0-x
16718 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16719 !$$$        deriv=4.0D0*deriv
16720 !$$$      endif
16721
16722 !     Third degree polynomial.  First derivative zero at extrema
16723       h_base=x*x*(3.0d0-2.0d0*x)
16724       deriv=6.0d0*x*(1.0d0-x)
16725
16726 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16727 !$$$      xsq=x*x
16728 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16729 !$$$      deriv=x-1.0d0
16730 !$$$      deriv=deriv*deriv
16731 !$$$      deriv=30.0d0*xsq*deriv
16732
16733       return
16734       end function h_base
16735 !-----------------------------------------------------------------------------
16736       subroutine dyn_set_nss
16737 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16738 !      implicit none
16739       use MD_data, only: totT,t_bath
16740 !     Includes
16741 !      include 'DIMENSIONS'
16742 #ifdef MPI
16743       include "mpif.h"
16744 #endif
16745 !      include 'COMMON.SBRIDGE'
16746 !      include 'COMMON.CHAIN'
16747 !      include 'COMMON.IOUNITS'
16748 !      include 'COMMON.SETUP'
16749 !      include 'COMMON.MD'
16750 !     Local variables
16751       real(kind=8) :: emin
16752       integer :: i,j,imin,ierr
16753       integer :: diff,allnss,newnss
16754       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16755                 newihpb,newjhpb
16756       logical :: found
16757       integer,dimension(0:nfgtasks) :: i_newnss
16758       integer,dimension(0:nfgtasks) :: displ
16759       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16760       integer :: g_newnss
16761
16762       allnss=0
16763       do i=1,nres-1
16764         do j=i+1,nres
16765           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16766             allnss=allnss+1
16767             allflag(allnss)=0
16768             allihpb(allnss)=i
16769             alljhpb(allnss)=j
16770           endif
16771         enddo
16772       enddo
16773
16774 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16775
16776  1    emin=1.0d300
16777       do i=1,allnss
16778         if (allflag(i).eq.0 .and. &
16779              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16780           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16781           imin=i
16782         endif
16783       enddo
16784       if (emin.lt.1.0d300) then
16785         allflag(imin)=1
16786         do i=1,allnss
16787           if (allflag(i).eq.0 .and. &
16788                (allihpb(i).eq.allihpb(imin) .or. &
16789                alljhpb(i).eq.allihpb(imin) .or. &
16790                allihpb(i).eq.alljhpb(imin) .or. &
16791                alljhpb(i).eq.alljhpb(imin))) then
16792             allflag(i)=-1
16793           endif
16794         enddo
16795         goto 1
16796       endif
16797
16798 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16799
16800       newnss=0
16801       do i=1,allnss
16802         if (allflag(i).eq.1) then
16803           newnss=newnss+1
16804           newihpb(newnss)=allihpb(i)
16805           newjhpb(newnss)=alljhpb(i)
16806         endif
16807       enddo
16808
16809 #ifdef MPI
16810       if (nfgtasks.gt.1)then
16811
16812         call MPI_Reduce(newnss,g_newnss,1,&
16813           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16814         call MPI_Gather(newnss,1,MPI_INTEGER,&
16815                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16816         displ(0)=0
16817         do i=1,nfgtasks-1,1
16818           displ(i)=i_newnss(i-1)+displ(i-1)
16819         enddo
16820         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16821                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16822                          king,FG_COMM,IERR)
16823         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16824                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16825                          king,FG_COMM,IERR)
16826         if(fg_rank.eq.0) then
16827 !         print *,'g_newnss',g_newnss
16828 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16829 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16830          newnss=g_newnss
16831          do i=1,newnss
16832           newihpb(i)=g_newihpb(i)
16833           newjhpb(i)=g_newjhpb(i)
16834          enddo
16835         endif
16836       endif
16837 #endif
16838
16839       diff=newnss-nss
16840
16841 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16842
16843       do i=1,nss
16844         found=.false.
16845         do j=1,newnss
16846           if (idssb(i).eq.newihpb(j) .and. &
16847                jdssb(i).eq.newjhpb(j)) found=.true.
16848         enddo
16849 #ifndef CLUST
16850 #ifndef WHAM
16851         if (.not.found.and.fg_rank.eq.0) &
16852             write(iout,'(a15,f12.2,f8.1,2i5)') &
16853              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16854 #endif
16855 #endif
16856       enddo
16857
16858       do i=1,newnss
16859         found=.false.
16860         do j=1,nss
16861           if (newihpb(i).eq.idssb(j) .and. &
16862                newjhpb(i).eq.jdssb(j)) found=.true.
16863         enddo
16864 #ifndef CLUST
16865 #ifndef WHAM
16866         if (.not.found.and.fg_rank.eq.0) &
16867             write(iout,'(a15,f12.2,f8.1,2i5)') &
16868              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16869 #endif
16870 #endif
16871       enddo
16872
16873       nss=newnss
16874       do i=1,nss
16875         idssb(i)=newihpb(i)
16876         jdssb(i)=newjhpb(i)
16877       enddo
16878
16879       return
16880       end subroutine dyn_set_nss
16881 !-----------------------------------------------------------------------------
16882 #ifdef WHAM
16883       subroutine read_ssHist
16884 !      implicit none
16885 !      Includes
16886 !      include 'DIMENSIONS'
16887 !      include "DIMENSIONS.FREE"
16888 !      include 'COMMON.FREE'
16889 !     Local variables
16890       integer :: i,j
16891       character(len=80) :: controlcard
16892
16893       do i=1,dyn_nssHist
16894         call card_concat(controlcard,.true.)
16895         read(controlcard,*) &
16896              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16897       enddo
16898
16899       return
16900       end subroutine read_ssHist
16901 #endif
16902 !-----------------------------------------------------------------------------
16903       integer function indmat(i,j)
16904 !el
16905 ! get the position of the jth ijth fragment of the chain coordinate system
16906 ! in the fromto array.
16907         integer :: i,j
16908
16909         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16910       return
16911       end function indmat
16912 !-----------------------------------------------------------------------------
16913       real(kind=8) function sigm(x)
16914 !el
16915        real(kind=8) :: x
16916         sigm=0.25d0*x
16917       return
16918       end function sigm
16919 !-----------------------------------------------------------------------------
16920 !-----------------------------------------------------------------------------
16921       subroutine alloc_ener_arrays
16922 !EL Allocation of arrays used by module energy
16923       use MD_data, only: mset
16924 !el local variables
16925       integer :: i,j
16926
16927       if(nres.lt.100) then
16928         maxconts=nres
16929       elseif(nres.lt.200) then
16930         maxconts=0.8*nres       ! Max. number of contacts per residue
16931       else
16932         maxconts=0.6*nres ! (maxconts=maxres/4)
16933       endif
16934       maxcont=12*nres   ! Max. number of SC contacts
16935       maxvar=6*nres     ! Max. number of variables
16936 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16937       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16938 !----------------------
16939 ! arrays in subroutine init_int_table
16940 !el#ifdef MPI
16941 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16942 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16943 !el#endif
16944       allocate(nint_gr(nres))
16945       allocate(nscp_gr(nres))
16946       allocate(ielstart(nres))
16947       allocate(ielend(nres))
16948 !(maxres)
16949       allocate(istart(nres,maxint_gr))
16950       allocate(iend(nres,maxint_gr))
16951 !(maxres,maxint_gr)
16952       allocate(iscpstart(nres,maxint_gr))
16953       allocate(iscpend(nres,maxint_gr))
16954 !(maxres,maxint_gr)
16955       allocate(ielstart_vdw(nres))
16956       allocate(ielend_vdw(nres))
16957 !(maxres)
16958
16959       allocate(lentyp(0:nfgtasks-1))
16960 !(0:maxprocs-1)
16961 !----------------------
16962 ! commom.contacts
16963 !      common /contacts/
16964       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16965       allocate(icont(2,maxcont))
16966 !(2,maxcont)
16967 !      common /contacts1/
16968       allocate(num_cont(0:nres+4))
16969 !(maxres)
16970       allocate(jcont(maxconts,nres))
16971 !(maxconts,maxres)
16972       allocate(facont(maxconts,nres))
16973 !(maxconts,maxres)
16974       allocate(gacont(3,maxconts,nres))
16975 !(3,maxconts,maxres)
16976 !      common /contacts_hb/
16977       allocate(gacontp_hb1(3,maxconts,nres))
16978       allocate(gacontp_hb2(3,maxconts,nres))
16979       allocate(gacontp_hb3(3,maxconts,nres))
16980       allocate(gacontm_hb1(3,maxconts,nres))
16981       allocate(gacontm_hb2(3,maxconts,nres))
16982       allocate(gacontm_hb3(3,maxconts,nres))
16983       allocate(gacont_hbr(3,maxconts,nres))
16984       allocate(grij_hb_cont(3,maxconts,nres))
16985 !(3,maxconts,maxres)
16986       allocate(facont_hb(maxconts,nres))
16987       allocate(ees0p(maxconts,nres))
16988       allocate(ees0m(maxconts,nres))
16989       allocate(d_cont(maxconts,nres))
16990 !(maxconts,maxres)
16991       allocate(num_cont_hb(nres))
16992 !(maxres)
16993       allocate(jcont_hb(maxconts,nres))
16994 !(maxconts,maxres)
16995 !      common /rotat/
16996       allocate(Ug(2,2,nres))
16997       allocate(Ugder(2,2,nres))
16998       allocate(Ug2(2,2,nres))
16999       allocate(Ug2der(2,2,nres))
17000 !(2,2,maxres)
17001       allocate(obrot(2,nres))
17002       allocate(obrot2(2,nres))
17003       allocate(obrot_der(2,nres))
17004       allocate(obrot2_der(2,nres))
17005 !(2,maxres)
17006 !      common /precomp1/
17007       allocate(mu(2,nres))
17008       allocate(muder(2,nres))
17009       allocate(Ub2(2,nres))
17010       Ub2(1,:)=0.0d0
17011       Ub2(2,:)=0.0d0
17012       allocate(Ub2der(2,nres))
17013       allocate(Ctobr(2,nres))
17014       allocate(Ctobrder(2,nres))
17015       allocate(Dtobr2(2,nres))
17016       allocate(Dtobr2der(2,nres))
17017 !(2,maxres)
17018       allocate(EUg(2,2,nres))
17019       allocate(EUgder(2,2,nres))
17020       allocate(CUg(2,2,nres))
17021       allocate(CUgder(2,2,nres))
17022       allocate(DUg(2,2,nres))
17023       allocate(Dugder(2,2,nres))
17024       allocate(DtUg2(2,2,nres))
17025       allocate(DtUg2der(2,2,nres))
17026 !(2,2,maxres)
17027 !      common /precomp2/
17028       allocate(Ug2Db1t(2,nres))
17029       allocate(Ug2Db1tder(2,nres))
17030       allocate(CUgb2(2,nres))
17031       allocate(CUgb2der(2,nres))
17032 !(2,maxres)
17033       allocate(EUgC(2,2,nres))
17034       allocate(EUgCder(2,2,nres))
17035       allocate(EUgD(2,2,nres))
17036       allocate(EUgDder(2,2,nres))
17037       allocate(DtUg2EUg(2,2,nres))
17038       allocate(Ug2DtEUg(2,2,nres))
17039 !(2,2,maxres)
17040       allocate(Ug2DtEUgder(2,2,2,nres))
17041       allocate(DtUg2EUgder(2,2,2,nres))
17042 !(2,2,2,maxres)
17043 !      common /rotat_old/
17044       allocate(costab(nres))
17045       allocate(sintab(nres))
17046       allocate(costab2(nres))
17047       allocate(sintab2(nres))
17048 !(maxres)
17049 !      common /dipmat/
17050       allocate(a_chuj(2,2,maxconts,nres))
17051 !(2,2,maxconts,maxres)(maxconts=maxres/4)
17052       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
17053 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
17054 !      common /contdistrib/
17055       allocate(ncont_sent(nres))
17056       allocate(ncont_recv(nres))
17057
17058       allocate(iat_sent(nres))
17059 !(maxres)
17060       allocate(iint_sent(4,nres,nres))
17061       allocate(iint_sent_local(4,nres,nres))
17062 !(4,maxres,maxres)
17063       allocate(iturn3_sent(4,0:nres+4))
17064       allocate(iturn4_sent(4,0:nres+4))
17065       allocate(iturn3_sent_local(4,nres))
17066       allocate(iturn4_sent_local(4,nres))
17067 !(4,maxres)
17068       allocate(itask_cont_from(0:nfgtasks-1))
17069       allocate(itask_cont_to(0:nfgtasks-1))
17070 !(0:max_fg_procs-1)
17071
17072
17073
17074 !----------------------
17075 ! commom.deriv;
17076 !      common /derivat/
17077       allocate(dcdv(6,maxdim))
17078       allocate(dxdv(6,maxdim))
17079 !(6,maxdim)
17080       allocate(dxds(6,nres))
17081 !(6,maxres)
17082       allocate(gradx(3,nres,0:2))
17083       allocate(gradc(3,nres,0:2))
17084 !(3,maxres,2)
17085       allocate(gvdwx(3,nres))
17086       allocate(gvdwc(3,nres))
17087       allocate(gelc(3,nres))
17088       allocate(gelc_long(3,nres))
17089       allocate(gvdwpp(3,nres))
17090       allocate(gvdwc_scpp(3,nres))
17091       allocate(gradx_scp(3,nres))
17092       allocate(gvdwc_scp(3,nres))
17093       allocate(ghpbx(3,nres))
17094       allocate(ghpbc(3,nres))
17095       allocate(gradcorr(3,nres))
17096       allocate(gradcorr_long(3,nres))
17097       allocate(gradcorr5_long(3,nres))
17098       allocate(gradcorr6_long(3,nres))
17099       allocate(gcorr6_turn_long(3,nres))
17100       allocate(gradxorr(3,nres))
17101       allocate(gradcorr5(3,nres))
17102       allocate(gradcorr6(3,nres))
17103 !(3,maxres)
17104       allocate(gloc(0:maxvar,0:2))
17105       allocate(gloc_x(0:maxvar,2))
17106 !(maxvar,2)
17107       allocate(gel_loc(3,nres))
17108       allocate(gel_loc_long(3,nres))
17109       allocate(gcorr3_turn(3,nres))
17110       allocate(gcorr4_turn(3,nres))
17111       allocate(gcorr6_turn(3,nres))
17112       allocate(gradb(3,nres))
17113       allocate(gradbx(3,nres))
17114 !(3,maxres)
17115       allocate(gel_loc_loc(maxvar))
17116       allocate(gel_loc_turn3(maxvar))
17117       allocate(gel_loc_turn4(maxvar))
17118       allocate(gel_loc_turn6(maxvar))
17119       allocate(gcorr_loc(maxvar))
17120       allocate(g_corr5_loc(maxvar))
17121       allocate(g_corr6_loc(maxvar))
17122 !(maxvar)
17123       allocate(gsccorc(3,nres))
17124       allocate(gsccorx(3,nres))
17125 !(3,maxres)
17126       allocate(gsccor_loc(nres))
17127 !(maxres)
17128       allocate(dtheta(3,2,nres))
17129 !(3,2,maxres)
17130       allocate(gscloc(3,nres))
17131       allocate(gsclocx(3,nres))
17132 !(3,maxres)
17133       allocate(dphi(3,3,nres))
17134       allocate(dalpha(3,3,nres))
17135       allocate(domega(3,3,nres))
17136 !(3,3,maxres)
17137 !      common /deriv_scloc/
17138       allocate(dXX_C1tab(3,nres))
17139       allocate(dYY_C1tab(3,nres))
17140       allocate(dZZ_C1tab(3,nres))
17141       allocate(dXX_Ctab(3,nres))
17142       allocate(dYY_Ctab(3,nres))
17143       allocate(dZZ_Ctab(3,nres))
17144       allocate(dXX_XYZtab(3,nres))
17145       allocate(dYY_XYZtab(3,nres))
17146       allocate(dZZ_XYZtab(3,nres))
17147 !(3,maxres)
17148 !      common /mpgrad/
17149       allocate(jgrad_start(nres))
17150       allocate(jgrad_end(nres))
17151 !(maxres)
17152 !----------------------
17153
17154 !      common /indices/
17155       allocate(ibond_displ(0:nfgtasks-1))
17156       allocate(ibond_count(0:nfgtasks-1))
17157       allocate(ithet_displ(0:nfgtasks-1))
17158       allocate(ithet_count(0:nfgtasks-1))
17159       allocate(iphi_displ(0:nfgtasks-1))
17160       allocate(iphi_count(0:nfgtasks-1))
17161       allocate(iphi1_displ(0:nfgtasks-1))
17162       allocate(iphi1_count(0:nfgtasks-1))
17163       allocate(ivec_displ(0:nfgtasks-1))
17164       allocate(ivec_count(0:nfgtasks-1))
17165       allocate(iset_displ(0:nfgtasks-1))
17166       allocate(iset_count(0:nfgtasks-1))
17167       allocate(iint_count(0:nfgtasks-1))
17168       allocate(iint_displ(0:nfgtasks-1))
17169 !(0:max_fg_procs-1)
17170 !----------------------
17171 ! common.MD
17172 !      common /mdgrad/
17173       allocate(gcart(3,0:nres))
17174       allocate(gxcart(3,0:nres))
17175 !(3,0:MAXRES)
17176       allocate(gradcag(3,nres))
17177       allocate(gradxag(3,nres))
17178 !(3,MAXRES)
17179 !      common /back_constr/
17180 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
17181       allocate(dutheta(nres))
17182       allocate(dugamma(nres))
17183 !(maxres)
17184       allocate(duscdiff(3,nres))
17185       allocate(duscdiffx(3,nres))
17186 !(3,maxres)
17187 !el i io:read_fragments
17188 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
17189 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
17190 !      common /qmeas/
17191 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
17192 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
17193       allocate(mset(0:nprocs))  !(maxprocs/20)
17194       mset(:)=0
17195 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
17196 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
17197       allocate(dUdconst(3,0:nres))
17198       allocate(dUdxconst(3,0:nres))
17199       allocate(dqwol(3,0:nres))
17200       allocate(dxqwol(3,0:nres))
17201 !(3,0:MAXRES)
17202 !----------------------
17203 ! common.sbridge
17204 !      common /sbridge/ in io_common: read_bridge
17205 !el    allocate((:),allocatable :: iss  !(maxss)
17206 !      common /links/  in io_common: read_bridge
17207 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
17208 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
17209 !      common /dyn_ssbond/
17210 ! and side-chain vectors in theta or phi.
17211       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
17212 !(maxres,maxres)
17213 !      do i=1,nres
17214 !        do j=i+1,nres
17215       dyn_ssbond_ij(:,:)=1.0d300
17216 !        enddo
17217 !      enddo
17218
17219       if (nss.gt.0) then
17220         allocate(idssb(nss),jdssb(nss))
17221 !(maxdim)
17222       endif
17223       allocate(dyn_ss_mask(nres))
17224 !(maxres)
17225       dyn_ss_mask(:)=.false.
17226 !----------------------
17227 ! common.sccor
17228 ! Parameters of the SCCOR term
17229 !      common/sccor/
17230 !el in io_conf: parmread
17231 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
17232 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
17233 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
17234 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
17235 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
17236 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
17237 !      allocate(vlor1sccor(maxterm_sccor,20,20))
17238 !      allocate(vlor2sccor(maxterm_sccor,20,20))
17239 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
17240 !----------------
17241       allocate(gloc_sc(3,0:2*nres,0:10))
17242 !(3,0:maxres2,10)maxres2=2*maxres
17243       allocate(dcostau(3,3,3,2*nres))
17244       allocate(dsintau(3,3,3,2*nres))
17245       allocate(dtauangle(3,3,3,2*nres))
17246       allocate(dcosomicron(3,3,3,2*nres))
17247       allocate(domicron(3,3,3,2*nres))
17248 !(3,3,3,maxres2)maxres2=2*maxres
17249 !----------------------
17250 ! common.var
17251 !      common /restr/
17252       allocate(varall(maxvar))
17253 !(maxvar)(maxvar=6*maxres)
17254       allocate(mask_theta(nres))
17255       allocate(mask_phi(nres))
17256       allocate(mask_side(nres))
17257 !(maxres)
17258 !----------------------
17259 ! common.vectors
17260 !      common /vectors/
17261       allocate(uy(3,nres))
17262       allocate(uz(3,nres))
17263 !(3,maxres)
17264       allocate(uygrad(3,3,2,nres))
17265       allocate(uzgrad(3,3,2,nres))
17266 !(3,3,2,maxres)
17267
17268       return
17269       end subroutine alloc_ener_arrays
17270 !-----------------------------------------------------------------------------
17271 !-----------------------------------------------------------------------------
17272       end module energy