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       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2865       xj_safe=xj
2866       yj_safe=yj
2867       zj_safe=zj
2868       do xshift=-1,1
2869       do yshift=-1,1
2870       do zshift=-1,1
2871           xj=xj_safe+xshift*boxxsize
2872           yj=yj_safe+yshift*boxysize
2873           zj=zj_safe+zshift*boxzsize
2874           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2875           if(dist_temp.lt.dist_init) then
2876             dist_init=dist_temp
2877             xj_temp=xj
2878             yj_temp=yj
2879             zj_temp=zj
2880             isubchap=1
2881           endif
2882        enddo
2883        enddo
2884        enddo
2885        if (isubchap.eq.1) then
2886 !C          print *,i,j
2887           xj=xj_temp-xmedi
2888           yj=yj_temp-ymedi
2889           zj=zj_temp-zmedi
2890        else
2891           xj=xj_safe-xmedi
2892           yj=yj_safe-ymedi
2893           zj=zj_safe-zmedi
2894        endif
2895
2896           rij=xj*xj+yj*yj+zj*zj
2897           rrmij=1.0D0/rij
2898           rij=dsqrt(rij)
2899 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
2900             sss_ele_cut=sscale_ele(rij)
2901             sss_ele_grad=sscagrad_ele(rij)
2902 !             sss_ele_cut=1.0d0
2903 !             sss_ele_grad=0.0d0
2904 !            print *,sss_ele_cut,sss_ele_grad,&
2905 !            (rij),r_cut_ele,rlamb_ele
2906 !            if (sss_ele_cut.le.0.0) go to 128
2907
2908           rmij=1.0D0/rij
2909           r3ij=rrmij*rmij
2910           r6ij=r3ij*r3ij
2911           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2912           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2913           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2914           fac=cosa-3.0D0*cosb*cosg
2915           ev1=aaa*r6ij*r6ij
2916 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2917           if (j.eq.i+2) ev1=scal_el*ev1
2918           ev2=bbb*r6ij
2919           fac3=ael6i*r6ij
2920           fac4=ael3i*r3ij
2921           evdwij=ev1+ev2
2922           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2923           el2=fac4*fac
2924           eesij=el1+el2
2925 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2926           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2927           ees=ees+eesij*sss_ele_cut
2928           evdw1=evdw1+evdwij*sss_ele_cut
2929 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2930 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2931 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2932 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2933
2934           if (energy_dec) then
2935 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2936 !                  'evdw1',i,j,evdwij,&
2937 !                  iteli,itelj,aaa,evdw1
2938               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2939               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2940           endif
2941 !
2942 ! Calculate contributions to the Cartesian gradient.
2943 !
2944 #ifdef SPLITELE
2945           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut
2946           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
2947           fac1=fac
2948           erij(1)=xj*rmij
2949           erij(2)=yj*rmij
2950           erij(3)=zj*rmij
2951 !
2952 ! Radial derivatives. First process both termini of the fragment (i,j)
2953 !
2954           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
2955           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
2956           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
2957
2958 !          do k=1,3
2959 !            ghalf=0.5D0*ggg(k)
2960 !            gelc(k,i)=gelc(k,i)+ghalf
2961 !            gelc(k,j)=gelc(k,j)+ghalf
2962 !          enddo
2963 ! 9/28/08 AL Gradient compotents will be summed only at the end
2964           do k=1,3
2965             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2966             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2967           enddo
2968 !
2969 ! Loop over residues i+1 thru j-1.
2970 !
2971 !grad          do k=i+1,j-1
2972 !grad            do l=1,3
2973 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2974 !grad            enddo
2975 !grad          enddo
2976           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj
2977           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj
2978           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj
2979 !          do k=1,3
2980 !            ghalf=0.5D0*ggg(k)
2981 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2982 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2983 !          enddo
2984 ! 9/28/08 AL Gradient compotents will be summed only at the end
2985           do k=1,3
2986             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2987             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2988           enddo
2989 !
2990 ! Loop over residues i+1 thru j-1.
2991 !
2992 !grad          do k=i+1,j-1
2993 !grad            do l=1,3
2994 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2995 !grad            enddo
2996 !grad          enddo
2997 #else
2998           facvdw=(ev1+evdwij)*sss_ele_cut
2999           facel=(el1+eesij)*sss_ele_cut
3000           fac1=fac
3001           fac=-3*rrmij*(facvdw+facvdw+facel)
3002           erij(1)=xj*rmij
3003           erij(2)=yj*rmij
3004           erij(3)=zj*rmij
3005 !
3006 ! Radial derivatives. First process both termini of the fragment (i,j)
3007 !
3008           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3009           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3010           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3011 !          do k=1,3
3012 !            ghalf=0.5D0*ggg(k)
3013 !            gelc(k,i)=gelc(k,i)+ghalf
3014 !            gelc(k,j)=gelc(k,j)+ghalf
3015 !          enddo
3016 ! 9/28/08 AL Gradient compotents will be summed only at the end
3017           do k=1,3
3018             gelc_long(k,j)=gelc(k,j)+ggg(k)
3019             gelc_long(k,i)=gelc(k,i)-ggg(k)
3020           enddo
3021 !
3022 ! Loop over residues i+1 thru j-1.
3023 !
3024 !grad          do k=i+1,j-1
3025 !grad            do l=1,3
3026 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3027 !grad            enddo
3028 !grad          enddo
3029 ! 9/28/08 AL Gradient compotents will be summed only at the end
3030           ggg(1)=facvdw*xj
3031           ggg(2)=facvdw*yj
3032           ggg(3)=facvdw*zj
3033           do k=1,3
3034             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3035             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3036           enddo
3037 #endif
3038 !
3039 ! Angular part
3040 !
3041           ecosa=2.0D0*fac3*fac1+fac4
3042           fac4=-3.0D0*fac4
3043           fac3=-6.0D0*fac3
3044           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3045           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3046           do k=1,3
3047             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3048             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3049           enddo
3050 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3051 !d   &          (dcosg(k),k=1,3)
3052           do k=1,3
3053             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut
3054           enddo
3055 !          do k=1,3
3056 !            ghalf=0.5D0*ggg(k)
3057 !            gelc(k,i)=gelc(k,i)+ghalf
3058 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3059 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3060 !            gelc(k,j)=gelc(k,j)+ghalf
3061 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3062 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3063 !          enddo
3064 !grad          do k=i+1,j-1
3065 !grad            do l=1,3
3066 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3067 !grad            enddo
3068 !grad          enddo
3069           do k=1,3
3070             gelc(k,i)=gelc(k,i) &
3071                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3072                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3073                      *sss_ele_cut
3074             gelc(k,j)=gelc(k,j) &
3075                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3076                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3077                      *sss_ele_cut
3078             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3079             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3080           enddo
3081
3082           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3083               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3084               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3085 !
3086 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3087 !   energy of a peptide unit is assumed in the form of a second-order
3088 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3089 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3090 !   are computed for EVERY pair of non-contiguous peptide groups.
3091 !
3092           if (j.lt.nres-1) then
3093             j1=j+1
3094             j2=j-1
3095           else
3096             j1=j-1
3097             j2=j-2
3098           endif
3099           kkk=0
3100           do k=1,2
3101             do l=1,2
3102               kkk=kkk+1
3103               muij(kkk)=mu(k,i)*mu(l,j)
3104             enddo
3105           enddo
3106 !d         write (iout,*) 'EELEC: i',i,' j',j
3107 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3108 !d          write(iout,*) 'muij',muij
3109           ury=scalar(uy(1,i),erij)
3110           urz=scalar(uz(1,i),erij)
3111           vry=scalar(uy(1,j),erij)
3112           vrz=scalar(uz(1,j),erij)
3113           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3114           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3115           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3116           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3117           fac=dsqrt(-ael6i)*r3ij
3118           a22=a22*fac
3119           a23=a23*fac
3120           a32=a32*fac
3121           a33=a33*fac
3122 !d          write (iout,'(4i5,4f10.5)')
3123 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3124 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3125 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3126 !d     &      uy(:,j),uz(:,j)
3127 !d          write (iout,'(4f10.5)')
3128 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3129 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3130 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3131 !d           write (iout,'(9f10.5/)')
3132 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3133 ! Derivatives of the elements of A in virtual-bond vectors
3134           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3135           do k=1,3
3136             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3137             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3138             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3139             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3140             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3141             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3142             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3143             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3144             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3145             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3146             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3147             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3148           enddo
3149 ! Compute radial contributions to the gradient
3150           facr=-3.0d0*rrmij
3151           a22der=a22*facr
3152           a23der=a23*facr
3153           a32der=a32*facr
3154           a33der=a33*facr
3155           agg(1,1)=a22der*xj
3156           agg(2,1)=a22der*yj
3157           agg(3,1)=a22der*zj
3158           agg(1,2)=a23der*xj
3159           agg(2,2)=a23der*yj
3160           agg(3,2)=a23der*zj
3161           agg(1,3)=a32der*xj
3162           agg(2,3)=a32der*yj
3163           agg(3,3)=a32der*zj
3164           agg(1,4)=a33der*xj
3165           agg(2,4)=a33der*yj
3166           agg(3,4)=a33der*zj
3167 ! Add the contributions coming from er
3168           fac3=-3.0d0*fac
3169           do k=1,3
3170             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3171             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3172             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3173             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3174           enddo
3175           do k=1,3
3176 ! Derivatives in DC(i)
3177 !grad            ghalf1=0.5d0*agg(k,1)
3178 !grad            ghalf2=0.5d0*agg(k,2)
3179 !grad            ghalf3=0.5d0*agg(k,3)
3180 !grad            ghalf4=0.5d0*agg(k,4)
3181             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3182             -3.0d0*uryg(k,2)*vry)!+ghalf1
3183             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3184             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3185             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3186             -3.0d0*urzg(k,2)*vry)!+ghalf3
3187             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3188             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3189 ! Derivatives in DC(i+1)
3190             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3191             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3192             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3193             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3194             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3195             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3196             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3197             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3198 ! Derivatives in DC(j)
3199             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3200             -3.0d0*vryg(k,2)*ury)!+ghalf1
3201             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3202             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3203             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3204             -3.0d0*vryg(k,2)*urz)!+ghalf3
3205             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3206             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3207 ! Derivatives in DC(j+1) or DC(nres-1)
3208             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3209             -3.0d0*vryg(k,3)*ury)
3210             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3211             -3.0d0*vrzg(k,3)*ury)
3212             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3213             -3.0d0*vryg(k,3)*urz)
3214             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3215             -3.0d0*vrzg(k,3)*urz)
3216 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3217 !grad              do l=1,4
3218 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3219 !grad              enddo
3220 !grad            endif
3221           enddo
3222           acipa(1,1)=a22
3223           acipa(1,2)=a23
3224           acipa(2,1)=a32
3225           acipa(2,2)=a33
3226           a22=-a22
3227           a23=-a23
3228           do l=1,2
3229             do k=1,3
3230               agg(k,l)=-agg(k,l)
3231               aggi(k,l)=-aggi(k,l)
3232               aggi1(k,l)=-aggi1(k,l)
3233               aggj(k,l)=-aggj(k,l)
3234               aggj1(k,l)=-aggj1(k,l)
3235             enddo
3236           enddo
3237           if (j.lt.nres-1) then
3238             a22=-a22
3239             a32=-a32
3240             do l=1,3,2
3241               do k=1,3
3242                 agg(k,l)=-agg(k,l)
3243                 aggi(k,l)=-aggi(k,l)
3244                 aggi1(k,l)=-aggi1(k,l)
3245                 aggj(k,l)=-aggj(k,l)
3246                 aggj1(k,l)=-aggj1(k,l)
3247               enddo
3248             enddo
3249           else
3250             a22=-a22
3251             a23=-a23
3252             a32=-a32
3253             a33=-a33
3254             do l=1,4
3255               do k=1,3
3256                 agg(k,l)=-agg(k,l)
3257                 aggi(k,l)=-aggi(k,l)
3258                 aggi1(k,l)=-aggi1(k,l)
3259                 aggj(k,l)=-aggj(k,l)
3260                 aggj1(k,l)=-aggj1(k,l)
3261               enddo
3262             enddo
3263           endif
3264           ENDIF ! WCORR
3265           IF (wel_loc.gt.0.0d0) THEN
3266 ! Contribution to the local-electrostatic energy coming from the i-j pair
3267           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3268            +a33*muij(4)
3269 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3270 !           eel_loc_ij=0.0
3271           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3272                   'eelloc',i,j,eel_loc_ij
3273 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3274 !          if (energy_dec) write (iout,*) "muij",muij
3275 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3276
3277           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3278 ! Partial derivatives in virtual-bond dihedral angles gamma
3279           if (i.gt.1) &
3280           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3281                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3282                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3283                  *sss_ele_cut
3284           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3285                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3286                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3287                  *sss_ele_cut
3288 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3289 !          do l=1,3
3290 !            ggg(1)=(agg(1,1)*muij(1)+ &
3291 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3292 !            *sss_ele_cut &
3293 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3294 !            ggg(2)=(agg(2,1)*muij(1)+ &
3295 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3296 !            *sss_ele_cut &
3297 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3298 !            ggg(3)=(agg(3,1)*muij(1)+ &
3299 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3300 !            *sss_ele_cut &
3301 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3302            xtemp(1)=xj
3303            xtemp(2)=yj
3304            xtemp(3)=zj
3305
3306            do l=1,3
3307             ggg(l)=(agg(l,1)*muij(1)+ &
3308                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3309             *sss_ele_cut &
3310              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3311
3312             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3313             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3314 !grad            ghalf=0.5d0*ggg(l)
3315 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3316 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3317           enddo
3318 !grad          do k=i+1,j2
3319 !grad            do l=1,3
3320 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3321 !grad            enddo
3322 !grad          enddo
3323 ! Remaining derivatives of eello
3324           do l=1,3
3325             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3326                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3327             *sss_ele_cut
3328 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3329             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3330                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3331             +aggi1(l,4)*muij(4))&
3332             *sss_ele_cut
3333 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3334             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3335                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3336             *sss_ele_cut
3337 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3338             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3339                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3340             +aggj1(l,4)*muij(4))&
3341             *sss_ele_cut
3342 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3343           enddo
3344           ENDIF
3345 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3346 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3347           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3348              .and. num_conti.le.maxconts) then
3349 !            write (iout,*) i,j," entered corr"
3350 !
3351 ! Calculate the contact function. The ith column of the array JCONT will
3352 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3353 ! greater than I). The arrays FACONT and GACONT will contain the values of
3354 ! the contact function and its derivative.
3355 !           r0ij=1.02D0*rpp(iteli,itelj)
3356 !           r0ij=1.11D0*rpp(iteli,itelj)
3357             r0ij=2.20D0*rpp(iteli,itelj)
3358 !           r0ij=1.55D0*rpp(iteli,itelj)
3359             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3360 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3361             if (fcont.gt.0.0D0) then
3362               num_conti=num_conti+1
3363               if (num_conti.gt.maxconts) then
3364 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3365 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3366                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3367                                ' will skip next contacts for this conf.', num_conti
3368               else
3369                 jcont_hb(num_conti,i)=j
3370 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3371 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3372                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3373                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3374 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3375 !  terms.
3376                 d_cont(num_conti,i)=rij
3377 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3378 !     --- Electrostatic-interaction matrix ---
3379                 a_chuj(1,1,num_conti,i)=a22
3380                 a_chuj(1,2,num_conti,i)=a23
3381                 a_chuj(2,1,num_conti,i)=a32
3382                 a_chuj(2,2,num_conti,i)=a33
3383 !     --- Gradient of rij
3384                 do kkk=1,3
3385                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3386                 enddo
3387                 kkll=0
3388                 do k=1,2
3389                   do l=1,2
3390                     kkll=kkll+1
3391                     do m=1,3
3392                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3393                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3394                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3395                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3396                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3397                     enddo
3398                   enddo
3399                 enddo
3400                 ENDIF
3401                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3402 ! Calculate contact energies
3403                 cosa4=4.0D0*cosa
3404                 wij=cosa-3.0D0*cosb*cosg
3405                 cosbg1=cosb+cosg
3406                 cosbg2=cosb-cosg
3407 !               fac3=dsqrt(-ael6i)/r0ij**3
3408                 fac3=dsqrt(-ael6i)*r3ij
3409 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3410                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3411                 if (ees0tmp.gt.0) then
3412                   ees0pij=dsqrt(ees0tmp)
3413                 else
3414                   ees0pij=0
3415                 endif
3416 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3417                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3418                 if (ees0tmp.gt.0) then
3419                   ees0mij=dsqrt(ees0tmp)
3420                 else
3421                   ees0mij=0
3422                 endif
3423 !               ees0mij=0.0D0
3424                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3425                      *sss_ele_cut
3426
3427                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3428                      *sss_ele_cut
3429
3430 ! Diagnostics. Comment out or remove after debugging!
3431 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3432 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3433 !               ees0m(num_conti,i)=0.0D0
3434 ! End diagnostics.
3435 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3436 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3437 ! Angular derivatives of the contact function
3438                 ees0pij1=fac3/ees0pij
3439                 ees0mij1=fac3/ees0mij
3440                 fac3p=-3.0D0*fac3*rrmij
3441                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3442                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3443 !               ees0mij1=0.0D0
3444                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3445                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3446                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3447                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3448                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3449                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3450                 ecosap=ecosa1+ecosa2
3451                 ecosbp=ecosb1+ecosb2
3452                 ecosgp=ecosg1+ecosg2
3453                 ecosam=ecosa1-ecosa2
3454                 ecosbm=ecosb1-ecosb2
3455                 ecosgm=ecosg1-ecosg2
3456 ! Diagnostics
3457 !               ecosap=ecosa1
3458 !               ecosbp=ecosb1
3459 !               ecosgp=ecosg1
3460 !               ecosam=0.0D0
3461 !               ecosbm=0.0D0
3462 !               ecosgm=0.0D0
3463 ! End diagnostics
3464                 facont_hb(num_conti,i)=fcont
3465                 fprimcont=fprimcont/rij
3466 !d              facont_hb(num_conti,i)=1.0D0
3467 ! Following line is for diagnostics.
3468 !d              fprimcont=0.0D0
3469                 do k=1,3
3470                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3471                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3472                 enddo
3473                 do k=1,3
3474                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3475                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3476                 enddo
3477                 gggp(1)=gggp(1)+ees0pijp*xj &
3478                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3479                 gggp(2)=gggp(2)+ees0pijp*yj &
3480                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3481                 gggp(3)=gggp(3)+ees0pijp*zj &
3482                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3483
3484                 gggm(1)=gggm(1)+ees0mijp*xj &
3485                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3486
3487                 gggm(2)=gggm(2)+ees0mijp*yj &
3488                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3489
3490                 gggm(3)=gggm(3)+ees0mijp*zj &
3491                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3492
3493 ! Derivatives due to the contact function
3494                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3495                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3496                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3497                 do k=1,3
3498 !
3499 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3500 !          following the change of gradient-summation algorithm.
3501 !
3502 !grad                  ghalfp=0.5D0*gggp(k)
3503 !grad                  ghalfm=0.5D0*gggm(k)
3504                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3505                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3506                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3507                      *sss_ele_cut
3508
3509                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3510                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3511                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3512                      *sss_ele_cut
3513
3514                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3515                      *sss_ele_cut
3516
3517                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3518                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3519                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3520                      *sss_ele_cut
3521
3522                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3523                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3524                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3525                      *sss_ele_cut
3526
3527                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3528                      *sss_ele_cut
3529
3530                 enddo
3531 ! Diagnostics. Comment out or remove after debugging!
3532 !diag           do k=1,3
3533 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3534 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3535 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3536 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3537 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3538 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3539 !diag           enddo
3540               ENDIF ! wcorr
3541               endif  ! num_conti.le.maxconts
3542             endif  ! fcont.gt.0
3543           endif    ! j.gt.i+1
3544           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3545             do k=1,4
3546               do l=1,3
3547                 ghalf=0.5d0*agg(l,k)
3548                 aggi(l,k)=aggi(l,k)+ghalf
3549                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3550                 aggj(l,k)=aggj(l,k)+ghalf
3551               enddo
3552             enddo
3553             if (j.eq.nres-1 .and. i.lt.j-2) then
3554               do k=1,4
3555                 do l=1,3
3556                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3557                 enddo
3558               enddo
3559             endif
3560           endif
3561  128  continue
3562 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3563       return
3564       end subroutine eelecij
3565 !-----------------------------------------------------------------------------
3566       subroutine eturn3(i,eello_turn3)
3567 ! Third- and fourth-order contributions from turns
3568
3569       use comm_locel
3570 !      implicit real*8 (a-h,o-z)
3571 !      include 'DIMENSIONS'
3572 !      include 'COMMON.IOUNITS'
3573 !      include 'COMMON.GEO'
3574 !      include 'COMMON.VAR'
3575 !      include 'COMMON.LOCAL'
3576 !      include 'COMMON.CHAIN'
3577 !      include 'COMMON.DERIV'
3578 !      include 'COMMON.INTERACT'
3579 !      include 'COMMON.CONTACTS'
3580 !      include 'COMMON.TORSION'
3581 !      include 'COMMON.VECTORS'
3582 !      include 'COMMON.FFIELD'
3583 !      include 'COMMON.CONTROL'
3584       real(kind=8),dimension(3) :: ggg
3585       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3586         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3587       real(kind=8),dimension(2) :: auxvec,auxvec1
3588 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3589       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3590 !el      integer :: num_conti,j1,j2
3591 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3592 !el        dz_normi,xmedi,ymedi,zmedi
3593
3594 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3595 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3596 !el         num_conti,j1,j2
3597 !el local variables
3598       integer :: i,j,l
3599       real(kind=8) :: eello_turn3
3600
3601       j=i+2
3602 !      write (iout,*) "eturn3",i,j,j1,j2
3603       a_temp(1,1)=a22
3604       a_temp(1,2)=a23
3605       a_temp(2,1)=a32
3606       a_temp(2,2)=a33
3607 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3608 !
3609 !               Third-order contributions
3610 !
3611 !                 (i+2)o----(i+3)
3612 !                      | |
3613 !                      | |
3614 !                 (i+1)o----i
3615 !
3616 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3617 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3618         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3619         call transpose2(auxmat(1,1),auxmat1(1,1))
3620         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3621         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3622         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3623                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3624 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3625 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3626 !d     &    ' eello_turn3_num',4*eello_turn3_num
3627 ! Derivatives in gamma(i)
3628         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3629         call transpose2(auxmat2(1,1),auxmat3(1,1))
3630         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3631         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3632 ! Derivatives in gamma(i+1)
3633         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3634         call transpose2(auxmat2(1,1),auxmat3(1,1))
3635         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3636         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3637           +0.5d0*(pizda(1,1)+pizda(2,2))
3638 ! Cartesian derivatives
3639         do l=1,3
3640 !            ghalf1=0.5d0*agg(l,1)
3641 !            ghalf2=0.5d0*agg(l,2)
3642 !            ghalf3=0.5d0*agg(l,3)
3643 !            ghalf4=0.5d0*agg(l,4)
3644           a_temp(1,1)=aggi(l,1)!+ghalf1
3645           a_temp(1,2)=aggi(l,2)!+ghalf2
3646           a_temp(2,1)=aggi(l,3)!+ghalf3
3647           a_temp(2,2)=aggi(l,4)!+ghalf4
3648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3649           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3650             +0.5d0*(pizda(1,1)+pizda(2,2))
3651           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3652           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3653           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3654           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3655           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3656           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3657             +0.5d0*(pizda(1,1)+pizda(2,2))
3658           a_temp(1,1)=aggj(l,1)!+ghalf1
3659           a_temp(1,2)=aggj(l,2)!+ghalf2
3660           a_temp(2,1)=aggj(l,3)!+ghalf3
3661           a_temp(2,2)=aggj(l,4)!+ghalf4
3662           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3663           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3664             +0.5d0*(pizda(1,1)+pizda(2,2))
3665           a_temp(1,1)=aggj1(l,1)
3666           a_temp(1,2)=aggj1(l,2)
3667           a_temp(2,1)=aggj1(l,3)
3668           a_temp(2,2)=aggj1(l,4)
3669           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3670           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3671             +0.5d0*(pizda(1,1)+pizda(2,2))
3672         enddo
3673       return
3674       end subroutine eturn3
3675 !-----------------------------------------------------------------------------
3676       subroutine eturn4(i,eello_turn4)
3677 ! Third- and fourth-order contributions from turns
3678
3679       use comm_locel
3680 !      implicit real*8 (a-h,o-z)
3681 !      include 'DIMENSIONS'
3682 !      include 'COMMON.IOUNITS'
3683 !      include 'COMMON.GEO'
3684 !      include 'COMMON.VAR'
3685 !      include 'COMMON.LOCAL'
3686 !      include 'COMMON.CHAIN'
3687 !      include 'COMMON.DERIV'
3688 !      include 'COMMON.INTERACT'
3689 !      include 'COMMON.CONTACTS'
3690 !      include 'COMMON.TORSION'
3691 !      include 'COMMON.VECTORS'
3692 !      include 'COMMON.FFIELD'
3693 !      include 'COMMON.CONTROL'
3694       real(kind=8),dimension(3) :: ggg
3695       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3696         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3697       real(kind=8),dimension(2) :: auxvec,auxvec1
3698 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3699       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3700 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3701 !el        dz_normi,xmedi,ymedi,zmedi
3702 !el      integer :: num_conti,j1,j2
3703 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3704 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3705 !el          num_conti,j1,j2
3706 !el local variables
3707       integer :: i,j,iti1,iti2,iti3,l
3708       real(kind=8) :: eello_turn4,s1,s2,s3
3709
3710       j=i+3
3711 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3712 !
3713 !               Fourth-order contributions
3714 !
3715 !                 (i+3)o----(i+4)
3716 !                     /  |
3717 !               (i+2)o   |
3718 !                     \  |
3719 !                 (i+1)o----i
3720 !
3721 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3722 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3723 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3724         a_temp(1,1)=a22
3725         a_temp(1,2)=a23
3726         a_temp(2,1)=a32
3727         a_temp(2,2)=a33
3728         iti1=itortyp(itype(i+1))
3729         iti2=itortyp(itype(i+2))
3730         iti3=itortyp(itype(i+3))
3731 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3732         call transpose2(EUg(1,1,i+1),e1t(1,1))
3733         call transpose2(Eug(1,1,i+2),e2t(1,1))
3734         call transpose2(Eug(1,1,i+3),e3t(1,1))
3735         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3736         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3737         s1=scalar2(b1(1,iti2),auxvec(1))
3738         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3739         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3740         s2=scalar2(b1(1,iti1),auxvec(1))
3741         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3742         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3743         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3744         eello_turn4=eello_turn4-(s1+s2+s3)
3745         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3746            'eturn4',i,j,-(s1+s2+s3)
3747 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3748 !d     &    ' eello_turn4_num',8*eello_turn4_num
3749 ! Derivatives in gamma(i)
3750         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3751         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3752         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3753         s1=scalar2(b1(1,iti2),auxvec(1))
3754         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3755         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3756         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3757 ! Derivatives in gamma(i+1)
3758         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3759         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3760         s2=scalar2(b1(1,iti1),auxvec(1))
3761         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3762         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3763         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3764         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3765 ! Derivatives in gamma(i+2)
3766         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3767         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3768         s1=scalar2(b1(1,iti2),auxvec(1))
3769         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3770         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3771         s2=scalar2(b1(1,iti1),auxvec(1))
3772         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3773         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3774         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3775         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3776 ! Cartesian derivatives
3777 ! Derivatives of this turn contributions in DC(i+2)
3778         if (j.lt.nres-1) then
3779           do l=1,3
3780             a_temp(1,1)=agg(l,1)
3781             a_temp(1,2)=agg(l,2)
3782             a_temp(2,1)=agg(l,3)
3783             a_temp(2,2)=agg(l,4)
3784             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3785             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3786             s1=scalar2(b1(1,iti2),auxvec(1))
3787             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3788             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3789             s2=scalar2(b1(1,iti1),auxvec(1))
3790             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793             ggg(l)=-(s1+s2+s3)
3794             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3795           enddo
3796         endif
3797 ! Remaining derivatives of this turn contribution
3798         do l=1,3
3799           a_temp(1,1)=aggi(l,1)
3800           a_temp(1,2)=aggi(l,2)
3801           a_temp(2,1)=aggi(l,3)
3802           a_temp(2,2)=aggi(l,4)
3803           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3804           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3805           s1=scalar2(b1(1,iti2),auxvec(1))
3806           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3807           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3808           s2=scalar2(b1(1,iti1),auxvec(1))
3809           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3810           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3811           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3812           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3813           a_temp(1,1)=aggi1(l,1)
3814           a_temp(1,2)=aggi1(l,2)
3815           a_temp(2,1)=aggi1(l,3)
3816           a_temp(2,2)=aggi1(l,4)
3817           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3818           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3819           s1=scalar2(b1(1,iti2),auxvec(1))
3820           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3821           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3822           s2=scalar2(b1(1,iti1),auxvec(1))
3823           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3824           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3825           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3826           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3827           a_temp(1,1)=aggj(l,1)
3828           a_temp(1,2)=aggj(l,2)
3829           a_temp(2,1)=aggj(l,3)
3830           a_temp(2,2)=aggj(l,4)
3831           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3832           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3833           s1=scalar2(b1(1,iti2),auxvec(1))
3834           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3835           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3836           s2=scalar2(b1(1,iti1),auxvec(1))
3837           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3838           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3839           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3840           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3841           a_temp(1,1)=aggj1(l,1)
3842           a_temp(1,2)=aggj1(l,2)
3843           a_temp(2,1)=aggj1(l,3)
3844           a_temp(2,2)=aggj1(l,4)
3845           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3846           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3847           s1=scalar2(b1(1,iti2),auxvec(1))
3848           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3849           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3850           s2=scalar2(b1(1,iti1),auxvec(1))
3851           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3852           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3853           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3854 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3855           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3856         enddo
3857       return
3858       end subroutine eturn4
3859 !-----------------------------------------------------------------------------
3860       subroutine unormderiv(u,ugrad,unorm,ungrad)
3861 ! This subroutine computes the derivatives of a normalized vector u, given
3862 ! the derivatives computed without normalization conditions, ugrad. Returns
3863 ! ungrad.
3864 !      implicit none
3865       real(kind=8),dimension(3) :: u,vec
3866       real(kind=8),dimension(3,3) ::ugrad,ungrad
3867       real(kind=8) :: unorm     !,scalar
3868       integer :: i,j
3869 !      write (2,*) 'ugrad',ugrad
3870 !      write (2,*) 'u',u
3871       do i=1,3
3872         vec(i)=scalar(ugrad(1,i),u(1))
3873       enddo
3874 !      write (2,*) 'vec',vec
3875       do i=1,3
3876         do j=1,3
3877           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3878         enddo
3879       enddo
3880 !      write (2,*) 'ungrad',ungrad
3881       return
3882       end subroutine unormderiv
3883 !-----------------------------------------------------------------------------
3884       subroutine escp_soft_sphere(evdw2,evdw2_14)
3885 !
3886 ! This subroutine calculates the excluded-volume interaction energy between
3887 ! peptide-group centers and side chains and its gradient in virtual-bond and
3888 ! side-chain vectors.
3889 !
3890 !      implicit real*8 (a-h,o-z)
3891 !      include 'DIMENSIONS'
3892 !      include 'COMMON.GEO'
3893 !      include 'COMMON.VAR'
3894 !      include 'COMMON.LOCAL'
3895 !      include 'COMMON.CHAIN'
3896 !      include 'COMMON.DERIV'
3897 !      include 'COMMON.INTERACT'
3898 !      include 'COMMON.FFIELD'
3899 !      include 'COMMON.IOUNITS'
3900 !      include 'COMMON.CONTROL'
3901       real(kind=8),dimension(3) :: ggg
3902 !el local variables
3903       integer :: i,iint,j,k,iteli,itypj
3904       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3905                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3906
3907       evdw2=0.0D0
3908       evdw2_14=0.0d0
3909       r0_scp=4.5d0
3910 !d    print '(a)','Enter ESCP'
3911 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3912       do i=iatscp_s,iatscp_e
3913         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3914         iteli=itel(i)
3915         xi=0.5D0*(c(1,i)+c(1,i+1))
3916         yi=0.5D0*(c(2,i)+c(2,i+1))
3917         zi=0.5D0*(c(3,i)+c(3,i+1))
3918
3919         do iint=1,nscp_gr(i)
3920
3921         do j=iscpstart(i,iint),iscpend(i,iint)
3922           if (itype(j).eq.ntyp1) cycle
3923           itypj=iabs(itype(j))
3924 ! Uncomment following three lines for SC-p interactions
3925 !         xj=c(1,nres+j)-xi
3926 !         yj=c(2,nres+j)-yi
3927 !         zj=c(3,nres+j)-zi
3928 ! Uncomment following three lines for Ca-p interactions
3929           xj=c(1,j)-xi
3930           yj=c(2,j)-yi
3931           zj=c(3,j)-zi
3932           rij=xj*xj+yj*yj+zj*zj
3933           r0ij=r0_scp
3934           r0ijsq=r0ij*r0ij
3935           if (rij.lt.r0ijsq) then
3936             evdwij=0.25d0*(rij-r0ijsq)**2
3937             fac=rij-r0ijsq
3938           else
3939             evdwij=0.0d0
3940             fac=0.0d0
3941           endif
3942           evdw2=evdw2+evdwij
3943 !
3944 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3945 !
3946           ggg(1)=xj*fac
3947           ggg(2)=yj*fac
3948           ggg(3)=zj*fac
3949 !grad          if (j.lt.i) then
3950 !d          write (iout,*) 'j<i'
3951 ! Uncomment following three lines for SC-p interactions
3952 !           do k=1,3
3953 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3954 !           enddo
3955 !grad          else
3956 !d          write (iout,*) 'j>i'
3957 !grad            do k=1,3
3958 !grad              ggg(k)=-ggg(k)
3959 ! Uncomment following line for SC-p interactions
3960 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3961 !grad            enddo
3962 !grad          endif
3963 !grad          do k=1,3
3964 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3965 !grad          enddo
3966 !grad          kstart=min0(i+1,j)
3967 !grad          kend=max0(i-1,j-1)
3968 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3969 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3970 !grad          do k=kstart,kend
3971 !grad            do l=1,3
3972 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3973 !grad            enddo
3974 !grad          enddo
3975           do k=1,3
3976             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3977             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3978           enddo
3979         enddo
3980
3981         enddo ! iint
3982       enddo ! i
3983       return
3984       end subroutine escp_soft_sphere
3985 !-----------------------------------------------------------------------------
3986       subroutine escp(evdw2,evdw2_14)
3987 !
3988 ! This subroutine calculates the excluded-volume interaction energy between
3989 ! peptide-group centers and side chains and its gradient in virtual-bond and
3990 ! side-chain vectors.
3991 !
3992 !      implicit real*8 (a-h,o-z)
3993 !      include 'DIMENSIONS'
3994 !      include 'COMMON.GEO'
3995 !      include 'COMMON.VAR'
3996 !      include 'COMMON.LOCAL'
3997 !      include 'COMMON.CHAIN'
3998 !      include 'COMMON.DERIV'
3999 !      include 'COMMON.INTERACT'
4000 !      include 'COMMON.FFIELD'
4001 !      include 'COMMON.IOUNITS'
4002 !      include 'COMMON.CONTROL'
4003       real(kind=8),dimension(3) :: ggg
4004 !el local variables
4005       integer :: i,iint,j,k,iteli,itypj,subchap
4006       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4007                    e1,e2,evdwij,rij
4008       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4009                     dist_temp, dist_init
4010       integer xshift,yshift,zshift
4011
4012       evdw2=0.0D0
4013       evdw2_14=0.0d0
4014 !d    print '(a)','Enter ESCP'
4015 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4016       do i=iatscp_s,iatscp_e
4017         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4018         iteli=itel(i)
4019         xi=0.5D0*(c(1,i)+c(1,i+1))
4020         yi=0.5D0*(c(2,i)+c(2,i+1))
4021         zi=0.5D0*(c(3,i)+c(3,i+1))
4022           xi=mod(xi,boxxsize)
4023           if (xi.lt.0) xi=xi+boxxsize
4024           yi=mod(yi,boxysize)
4025           if (yi.lt.0) yi=yi+boxysize
4026           zi=mod(zi,boxzsize)
4027           if (zi.lt.0) zi=zi+boxzsize
4028
4029         do iint=1,nscp_gr(i)
4030
4031         do j=iscpstart(i,iint),iscpend(i,iint)
4032           itypj=iabs(itype(j))
4033           if (itypj.eq.ntyp1) cycle
4034 ! Uncomment following three lines for SC-p interactions
4035 !         xj=c(1,nres+j)-xi
4036 !         yj=c(2,nres+j)-yi
4037 !         zj=c(3,nres+j)-zi
4038 ! Uncomment following three lines for Ca-p interactions
4039 !          xj=c(1,j)-xi
4040 !          yj=c(2,j)-yi
4041 !          zj=c(3,j)-zi
4042           xj=c(1,j)
4043           yj=c(2,j)
4044           zj=c(3,j)
4045           xj=mod(xj,boxxsize)
4046           if (xj.lt.0) xj=xj+boxxsize
4047           yj=mod(yj,boxysize)
4048           if (yj.lt.0) yj=yj+boxysize
4049           zj=mod(zj,boxzsize)
4050           if (zj.lt.0) zj=zj+boxzsize
4051       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4052       xj_safe=xj
4053       yj_safe=yj
4054       zj_safe=zj
4055       subchap=0
4056       do xshift=-1,1
4057       do yshift=-1,1
4058       do zshift=-1,1
4059           xj=xj_safe+xshift*boxxsize
4060           yj=yj_safe+yshift*boxysize
4061           zj=zj_safe+zshift*boxzsize
4062           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4063           if(dist_temp.lt.dist_init) then
4064             dist_init=dist_temp
4065             xj_temp=xj
4066             yj_temp=yj
4067             zj_temp=zj
4068             subchap=1
4069           endif
4070        enddo
4071        enddo
4072        enddo
4073        if (subchap.eq.1) then
4074           xj=xj_temp-xi
4075           yj=yj_temp-yi
4076           zj=zj_temp-zi
4077        else
4078           xj=xj_safe-xi
4079           yj=yj_safe-yi
4080           zj=zj_safe-zi
4081        endif
4082
4083           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4084           rij=dsqrt(1.0d0/rrij)
4085             sss_ele_cut=sscale_ele(rij)
4086             sss_ele_grad=sscagrad_ele(rij)
4087 !            print *,sss_ele_cut,sss_ele_grad,&
4088 !            (rij),r_cut_ele,rlamb_ele
4089             if (sss_ele_cut.le.0.0) cycle
4090           fac=rrij**expon2
4091           e1=fac*fac*aad(itypj,iteli)
4092           e2=fac*bad(itypj,iteli)
4093           if (iabs(j-i) .le. 2) then
4094             e1=scal14*e1
4095             e2=scal14*e2
4096             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4097           endif
4098           evdwij=e1+e2
4099           evdw2=evdw2+evdwij*sss_ele_cut
4100 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4101 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4102           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4103              'evdw2',i,j,evdwij
4104 !
4105 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4106 !
4107           fac=-(evdwij+e1)*rrij*sss_ele_cut
4108           fac=fac+evdwij*sss_ele_grad/rij/expon
4109           ggg(1)=xj*fac
4110           ggg(2)=yj*fac
4111           ggg(3)=zj*fac
4112 !grad          if (j.lt.i) then
4113 !d          write (iout,*) 'j<i'
4114 ! Uncomment following three lines for SC-p interactions
4115 !           do k=1,3
4116 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4117 !           enddo
4118 !grad          else
4119 !d          write (iout,*) 'j>i'
4120 !grad            do k=1,3
4121 !grad              ggg(k)=-ggg(k)
4122 ! Uncomment following line for SC-p interactions
4123 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4124 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4125 !grad            enddo
4126 !grad          endif
4127 !grad          do k=1,3
4128 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4129 !grad          enddo
4130 !grad          kstart=min0(i+1,j)
4131 !grad          kend=max0(i-1,j-1)
4132 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4133 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4134 !grad          do k=kstart,kend
4135 !grad            do l=1,3
4136 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4137 !grad            enddo
4138 !grad          enddo
4139           do k=1,3
4140             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4141             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4142           enddo
4143         enddo
4144
4145         enddo ! iint
4146       enddo ! i
4147       do i=1,nct
4148         do j=1,3
4149           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4150           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4151           gradx_scp(j,i)=expon*gradx_scp(j,i)
4152         enddo
4153       enddo
4154 !******************************************************************************
4155 !
4156 !                              N O T E !!!
4157 !
4158 ! To save time the factor EXPON has been extracted from ALL components
4159 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4160 ! use!
4161 !
4162 !******************************************************************************
4163       return
4164       end subroutine escp
4165 !-----------------------------------------------------------------------------
4166       subroutine edis(ehpb)
4167 !
4168 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4169 !
4170 !      implicit real*8 (a-h,o-z)
4171 !      include 'DIMENSIONS'
4172 !      include 'COMMON.SBRIDGE'
4173 !      include 'COMMON.CHAIN'
4174 !      include 'COMMON.DERIV'
4175 !      include 'COMMON.VAR'
4176 !      include 'COMMON.INTERACT'
4177 !      include 'COMMON.IOUNITS'
4178       real(kind=8),dimension(3) :: ggg
4179 !el local variables
4180       integer :: i,j,ii,jj,iii,jjj,k
4181       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4182
4183       ehpb=0.0D0
4184 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4185 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4186       if (link_end.eq.0) return
4187       do i=link_start,link_end
4188 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4189 ! CA-CA distance used in regularization of structure.
4190         ii=ihpb(i)
4191         jj=jhpb(i)
4192 ! iii and jjj point to the residues for which the distance is assigned.
4193         if (ii.gt.nres) then
4194           iii=ii-nres
4195           jjj=jj-nres
4196         else
4197           iii=ii
4198           jjj=jj
4199         endif
4200 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4201 !     &    dhpb(i),dhpb1(i),forcon(i)
4202 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4203 !    distance and angle dependent SS bond potential.
4204 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4205 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4206         if (.not.dyn_ss .and. i.le.nss) then
4207 ! 15/02/13 CC dynamic SSbond - additional check
4208          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4209         iabs(itype(jjj)).eq.1) then
4210           call ssbond_ene(iii,jjj,eij)
4211           ehpb=ehpb+2*eij
4212 !d          write (iout,*) "eij",eij
4213          endif
4214         else
4215 ! Calculate the distance between the two points and its difference from the
4216 ! target distance.
4217         dd=dist(ii,jj)
4218         rdis=dd-dhpb(i)
4219 ! Get the force constant corresponding to this distance.
4220         waga=forcon(i)
4221 ! Calculate the contribution to energy.
4222         ehpb=ehpb+waga*rdis*rdis
4223 !
4224 ! Evaluate gradient.
4225 !
4226         fac=waga*rdis/dd
4227 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4228 !d   &   ' waga=',waga,' fac=',fac
4229         do j=1,3
4230           ggg(j)=fac*(c(j,jj)-c(j,ii))
4231         enddo
4232 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4233 ! If this is a SC-SC distance, we need to calculate the contributions to the
4234 ! Cartesian gradient in the SC vectors (ghpbx).
4235         if (iii.lt.ii) then
4236           do j=1,3
4237             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4238             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4239           enddo
4240         endif
4241 !grad        do j=iii,jjj-1
4242 !grad          do k=1,3
4243 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4244 !grad          enddo
4245 !grad        enddo
4246         do k=1,3
4247           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4248           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4249         enddo
4250         endif
4251       enddo
4252       ehpb=0.5D0*ehpb
4253       return
4254       end subroutine edis
4255 !-----------------------------------------------------------------------------
4256       subroutine ssbond_ene(i,j,eij)
4257 !
4258 ! Calculate the distance and angle dependent SS-bond potential energy
4259 ! using a free-energy function derived based on RHF/6-31G** ab initio
4260 ! calculations of diethyl disulfide.
4261 !
4262 ! A. Liwo and U. Kozlowska, 11/24/03
4263 !
4264 !      implicit real*8 (a-h,o-z)
4265 !      include 'DIMENSIONS'
4266 !      include 'COMMON.SBRIDGE'
4267 !      include 'COMMON.CHAIN'
4268 !      include 'COMMON.DERIV'
4269 !      include 'COMMON.LOCAL'
4270 !      include 'COMMON.INTERACT'
4271 !      include 'COMMON.VAR'
4272 !      include 'COMMON.IOUNITS'
4273       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4274 !el local variables
4275       integer :: i,j,itypi,itypj,k
4276       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4277                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4278                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4279                    cosphi,ggk
4280
4281       itypi=iabs(itype(i))
4282       xi=c(1,nres+i)
4283       yi=c(2,nres+i)
4284       zi=c(3,nres+i)
4285       dxi=dc_norm(1,nres+i)
4286       dyi=dc_norm(2,nres+i)
4287       dzi=dc_norm(3,nres+i)
4288 !      dsci_inv=dsc_inv(itypi)
4289       dsci_inv=vbld_inv(nres+i)
4290       itypj=iabs(itype(j))
4291 !      dscj_inv=dsc_inv(itypj)
4292       dscj_inv=vbld_inv(nres+j)
4293       xj=c(1,nres+j)-xi
4294       yj=c(2,nres+j)-yi
4295       zj=c(3,nres+j)-zi
4296       dxj=dc_norm(1,nres+j)
4297       dyj=dc_norm(2,nres+j)
4298       dzj=dc_norm(3,nres+j)
4299       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4300       rij=dsqrt(rrij)
4301       erij(1)=xj*rij
4302       erij(2)=yj*rij
4303       erij(3)=zj*rij
4304       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4305       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4306       om12=dxi*dxj+dyi*dyj+dzi*dzj
4307       do k=1,3
4308         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4309         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4310       enddo
4311       rij=1.0d0/rij
4312       deltad=rij-d0cm
4313       deltat1=1.0d0-om1
4314       deltat2=1.0d0+om2
4315       deltat12=om2-om1+2.0d0
4316       cosphi=om12-om1*om2
4317       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4318         +akct*deltad*deltat12 &
4319         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4320 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4321 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4322 !     &  " deltat12",deltat12," eij",eij
4323       ed=2*akcm*deltad+akct*deltat12
4324       pom1=akct*deltad
4325       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4326       eom1=-2*akth*deltat1-pom1-om2*pom2
4327       eom2= 2*akth*deltat2+pom1-om1*pom2
4328       eom12=pom2
4329       do k=1,3
4330         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4331         ghpbx(k,i)=ghpbx(k,i)-ggk &
4332                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4333                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4334         ghpbx(k,j)=ghpbx(k,j)+ggk &
4335                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4336                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4337         ghpbc(k,i)=ghpbc(k,i)-ggk
4338         ghpbc(k,j)=ghpbc(k,j)+ggk
4339       enddo
4340 !
4341 ! Calculate the components of the gradient in DC and X
4342 !
4343 !grad      do k=i,j-1
4344 !grad        do l=1,3
4345 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4346 !grad        enddo
4347 !grad      enddo
4348       return
4349       end subroutine ssbond_ene
4350 !-----------------------------------------------------------------------------
4351       subroutine ebond(estr)
4352 !
4353 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4354 !
4355 !      implicit real*8 (a-h,o-z)
4356 !      include 'DIMENSIONS'
4357 !      include 'COMMON.LOCAL'
4358 !      include 'COMMON.GEO'
4359 !      include 'COMMON.INTERACT'
4360 !      include 'COMMON.DERIV'
4361 !      include 'COMMON.VAR'
4362 !      include 'COMMON.CHAIN'
4363 !      include 'COMMON.IOUNITS'
4364 !      include 'COMMON.NAMES'
4365 !      include 'COMMON.FFIELD'
4366 !      include 'COMMON.CONTROL'
4367 !      include 'COMMON.SETUP'
4368       real(kind=8),dimension(3) :: u,ud
4369 !el local variables
4370       integer :: i,j,iti,nbi,k
4371       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4372                    uprod1,uprod2
4373
4374       estr=0.0d0
4375       estr1=0.0d0
4376 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4377 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4378
4379       do i=ibondp_start,ibondp_end
4380         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4381         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4382 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4383 !C          do j=1,3
4384 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4385 !C            *dc(j,i-1)/vbld(i)
4386 !C          enddo
4387 !C          if (energy_dec) write(iout,*) &
4388 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4389         diff = vbld(i)-vbldpDUM
4390         else
4391         diff = vbld(i)-vbldp0
4392         endif
4393         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4394            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4395         estr=estr+diff*diff
4396         do j=1,3
4397           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4398         enddo
4399 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4400 !        endif
4401       enddo
4402       estr=0.5d0*AKP*estr+estr1
4403 !
4404 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4405 !
4406       do i=ibond_start,ibond_end
4407         iti=iabs(itype(i))
4408         if (iti.ne.10 .and. iti.ne.ntyp1) then
4409           nbi=nbondterm(iti)
4410           if (nbi.eq.1) then
4411             diff=vbld(i+nres)-vbldsc0(1,iti)
4412             if (energy_dec) write (iout,*) &
4413             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4414             AKSC(1,iti),AKSC(1,iti)*diff*diff
4415             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4416             do j=1,3
4417               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4418             enddo
4419           else
4420             do j=1,nbi
4421               diff=vbld(i+nres)-vbldsc0(j,iti)
4422               ud(j)=aksc(j,iti)*diff
4423               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4424             enddo
4425             uprod=u(1)
4426             do j=2,nbi
4427               uprod=uprod*u(j)
4428             enddo
4429             usum=0.0d0
4430             usumsqder=0.0d0
4431             do j=1,nbi
4432               uprod1=1.0d0
4433               uprod2=1.0d0
4434               do k=1,nbi
4435                 if (k.ne.j) then
4436                   uprod1=uprod1*u(k)
4437                   uprod2=uprod2*u(k)*u(k)
4438                 endif
4439               enddo
4440               usum=usum+uprod1
4441               usumsqder=usumsqder+ud(j)*uprod2
4442             enddo
4443             estr=estr+uprod/usum
4444             do j=1,3
4445              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4446             enddo
4447           endif
4448         endif
4449       enddo
4450       return
4451       end subroutine ebond
4452 #ifdef CRYST_THETA
4453 !-----------------------------------------------------------------------------
4454       subroutine ebend(etheta)
4455 !
4456 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4457 ! angles gamma and its derivatives in consecutive thetas and gammas.
4458 !
4459       use comm_calcthet
4460 !      implicit real*8 (a-h,o-z)
4461 !      include 'DIMENSIONS'
4462 !      include 'COMMON.LOCAL'
4463 !      include 'COMMON.GEO'
4464 !      include 'COMMON.INTERACT'
4465 !      include 'COMMON.DERIV'
4466 !      include 'COMMON.VAR'
4467 !      include 'COMMON.CHAIN'
4468 !      include 'COMMON.IOUNITS'
4469 !      include 'COMMON.NAMES'
4470 !      include 'COMMON.FFIELD'
4471 !      include 'COMMON.CONTROL'
4472 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4473 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4474 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4475 !el      integer :: it
4476 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4477 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4478 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4479 !el local variables
4480       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4481        ichir21,ichir22
4482       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4483        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4484        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4485       real(kind=8),dimension(2) :: y,z
4486
4487       delta=0.02d0*pi
4488 !      time11=dexp(-2*time)
4489 !      time12=1.0d0
4490       etheta=0.0D0
4491 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4492       do i=ithet_start,ithet_end
4493         if (itype(i-1).eq.ntyp1) cycle
4494 ! Zero the energy function and its derivative at 0 or pi.
4495         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4496         it=itype(i-1)
4497         ichir1=isign(1,itype(i-2))
4498         ichir2=isign(1,itype(i))
4499          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4500          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4501          if (itype(i-1).eq.10) then
4502           itype1=isign(10,itype(i-2))
4503           ichir11=isign(1,itype(i-2))
4504           ichir12=isign(1,itype(i-2))
4505           itype2=isign(10,itype(i))
4506           ichir21=isign(1,itype(i))
4507           ichir22=isign(1,itype(i))
4508          endif
4509
4510         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4511 #ifdef OSF
4512           phii=phi(i)
4513           if (phii.ne.phii) phii=150.0
4514 #else
4515           phii=phi(i)
4516 #endif
4517           y(1)=dcos(phii)
4518           y(2)=dsin(phii)
4519         else
4520           y(1)=0.0D0
4521           y(2)=0.0D0
4522         endif
4523         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4524 #ifdef OSF
4525           phii1=phi(i+1)
4526           if (phii1.ne.phii1) phii1=150.0
4527           phii1=pinorm(phii1)
4528           z(1)=cos(phii1)
4529 #else
4530           phii1=phi(i+1)
4531           z(1)=dcos(phii1)
4532 #endif
4533           z(2)=dsin(phii1)
4534         else
4535           z(1)=0.0D0
4536           z(2)=0.0D0
4537         endif
4538 ! Calculate the "mean" value of theta from the part of the distribution
4539 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4540 ! In following comments this theta will be referred to as t_c.
4541         thet_pred_mean=0.0d0
4542         do k=1,2
4543             athetk=athet(k,it,ichir1,ichir2)
4544             bthetk=bthet(k,it,ichir1,ichir2)
4545           if (it.eq.10) then
4546              athetk=athet(k,itype1,ichir11,ichir12)
4547              bthetk=bthet(k,itype2,ichir21,ichir22)
4548           endif
4549          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4550         enddo
4551         dthett=thet_pred_mean*ssd
4552         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4553 ! Derivatives of the "mean" values in gamma1 and gamma2.
4554         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4555                +athet(2,it,ichir1,ichir2)*y(1))*ss
4556         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4557                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4558          if (it.eq.10) then
4559         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4560              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4561         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4562                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4563          endif
4564         if (theta(i).gt.pi-delta) then
4565           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4566                E_tc0)
4567           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4568           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4569           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4570               E_theta)
4571           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4572               E_tc)
4573         else if (theta(i).lt.delta) then
4574           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4575           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4576           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4577               E_theta)
4578           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4579           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4580               E_tc)
4581         else
4582           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4583               E_theta,E_tc)
4584         endif
4585         etheta=etheta+ethetai
4586         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4587             'ebend',i,ethetai
4588         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4589         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4590         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4591       enddo
4592 ! Ufff.... We've done all this!!!
4593       return
4594       end subroutine ebend
4595 !-----------------------------------------------------------------------------
4596       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4597
4598       use comm_calcthet
4599 !      implicit real*8 (a-h,o-z)
4600 !      include 'DIMENSIONS'
4601 !      include 'COMMON.LOCAL'
4602 !      include 'COMMON.IOUNITS'
4603 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4604 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4605 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4606       integer :: i,j,k
4607       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4608 !el      integer :: it
4609 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4610 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4611 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4612 !el local variables
4613       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4614        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4615
4616 ! Calculate the contributions to both Gaussian lobes.
4617 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4618 ! The "polynomial part" of the "standard deviation" of this part of
4619 ! the distribution.
4620         sig=polthet(3,it)
4621         do j=2,0,-1
4622           sig=sig*thet_pred_mean+polthet(j,it)
4623         enddo
4624 ! Derivative of the "interior part" of the "standard deviation of the"
4625 ! gamma-dependent Gaussian lobe in t_c.
4626         sigtc=3*polthet(3,it)
4627         do j=2,1,-1
4628           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4629         enddo
4630         sigtc=sig*sigtc
4631 ! Set the parameters of both Gaussian lobes of the distribution.
4632 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4633         fac=sig*sig+sigc0(it)
4634         sigcsq=fac+fac
4635         sigc=1.0D0/sigcsq
4636 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4637         sigsqtc=-4.0D0*sigcsq*sigtc
4638 !       print *,i,sig,sigtc,sigsqtc
4639 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4640         sigtc=-sigtc/(fac*fac)
4641 ! Following variable is sigma(t_c)**(-2)
4642         sigcsq=sigcsq*sigcsq
4643         sig0i=sig0(it)
4644         sig0inv=1.0D0/sig0i**2
4645         delthec=thetai-thet_pred_mean
4646         delthe0=thetai-theta0i
4647         term1=-0.5D0*sigcsq*delthec*delthec
4648         term2=-0.5D0*sig0inv*delthe0*delthe0
4649 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4650 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4651 ! to the energy (this being the log of the distribution) at the end of energy
4652 ! term evaluation for this virtual-bond angle.
4653         if (term1.gt.term2) then
4654           termm=term1
4655           term2=dexp(term2-termm)
4656           term1=1.0d0
4657         else
4658           termm=term2
4659           term1=dexp(term1-termm)
4660           term2=1.0d0
4661         endif
4662 ! The ratio between the gamma-independent and gamma-dependent lobes of
4663 ! the distribution is a Gaussian function of thet_pred_mean too.
4664         diffak=gthet(2,it)-thet_pred_mean
4665         ratak=diffak/gthet(3,it)**2
4666         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4667 ! Let's differentiate it in thet_pred_mean NOW.
4668         aktc=ak*ratak
4669 ! Now put together the distribution terms to make complete distribution.
4670         termexp=term1+ak*term2
4671         termpre=sigc+ak*sig0i
4672 ! Contribution of the bending energy from this theta is just the -log of
4673 ! the sum of the contributions from the two lobes and the pre-exponential
4674 ! factor. Simple enough, isn't it?
4675         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4676 ! NOW the derivatives!!!
4677 ! 6/6/97 Take into account the deformation.
4678         E_theta=(delthec*sigcsq*term1 &
4679              +ak*delthe0*sig0inv*term2)/termexp
4680         E_tc=((sigtc+aktc*sig0i)/termpre &
4681             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4682              aktc*term2)/termexp)
4683       return
4684       end subroutine theteng
4685 #else
4686 !-----------------------------------------------------------------------------
4687       subroutine ebend(etheta)
4688 !
4689 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4690 ! angles gamma and its derivatives in consecutive thetas and gammas.
4691 ! ab initio-derived potentials from
4692 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4693 !
4694 !      implicit real*8 (a-h,o-z)
4695 !      include 'DIMENSIONS'
4696 !      include 'COMMON.LOCAL'
4697 !      include 'COMMON.GEO'
4698 !      include 'COMMON.INTERACT'
4699 !      include 'COMMON.DERIV'
4700 !      include 'COMMON.VAR'
4701 !      include 'COMMON.CHAIN'
4702 !      include 'COMMON.IOUNITS'
4703 !      include 'COMMON.NAMES'
4704 !      include 'COMMON.FFIELD'
4705 !      include 'COMMON.CONTROL'
4706       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4707       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4708       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4709       logical :: lprn=.false., lprn1=.false.
4710 !el local variables
4711       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4712       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4713       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4714
4715       etheta=0.0D0
4716       do i=ithet_start,ithet_end
4717         if (itype(i-1).eq.ntyp1) cycle
4718         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4719         if (iabs(itype(i+1)).eq.20) iblock=2
4720         if (iabs(itype(i+1)).ne.20) iblock=1
4721         dethetai=0.0d0
4722         dephii=0.0d0
4723         dephii1=0.0d0
4724         theti2=0.5d0*theta(i)
4725         ityp2=ithetyp((itype(i-1)))
4726         do k=1,nntheterm
4727           coskt(k)=dcos(k*theti2)
4728           sinkt(k)=dsin(k*theti2)
4729         enddo
4730         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4731 #ifdef OSF
4732           phii=phi(i)
4733           if (phii.ne.phii) phii=150.0
4734 #else
4735           phii=phi(i)
4736 #endif
4737           ityp1=ithetyp((itype(i-2)))
4738 ! propagation of chirality for glycine type
4739           do k=1,nsingle
4740             cosph1(k)=dcos(k*phii)
4741             sinph1(k)=dsin(k*phii)
4742           enddo
4743         else
4744           phii=0.0d0
4745           ityp1=ithetyp(itype(i-2))
4746           do k=1,nsingle
4747             cosph1(k)=0.0d0
4748             sinph1(k)=0.0d0
4749           enddo
4750         endif
4751         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4752 #ifdef OSF
4753           phii1=phi(i+1)
4754           if (phii1.ne.phii1) phii1=150.0
4755           phii1=pinorm(phii1)
4756 #else
4757           phii1=phi(i+1)
4758 #endif
4759           ityp3=ithetyp((itype(i)))
4760           do k=1,nsingle
4761             cosph2(k)=dcos(k*phii1)
4762             sinph2(k)=dsin(k*phii1)
4763           enddo
4764         else
4765           phii1=0.0d0
4766           ityp3=ithetyp(itype(i))
4767           do k=1,nsingle
4768             cosph2(k)=0.0d0
4769             sinph2(k)=0.0d0
4770           enddo
4771         endif
4772         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4773         do k=1,ndouble
4774           do l=1,k-1
4775             ccl=cosph1(l)*cosph2(k-l)
4776             ssl=sinph1(l)*sinph2(k-l)
4777             scl=sinph1(l)*cosph2(k-l)
4778             csl=cosph1(l)*sinph2(k-l)
4779             cosph1ph2(l,k)=ccl-ssl
4780             cosph1ph2(k,l)=ccl+ssl
4781             sinph1ph2(l,k)=scl+csl
4782             sinph1ph2(k,l)=scl-csl
4783           enddo
4784         enddo
4785         if (lprn) then
4786         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4787           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4788         write (iout,*) "coskt and sinkt"
4789         do k=1,nntheterm
4790           write (iout,*) k,coskt(k),sinkt(k)
4791         enddo
4792         endif
4793         do k=1,ntheterm
4794           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4795           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4796             *coskt(k)
4797           if (lprn) &
4798           write (iout,*) "k",k,&
4799            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4800            " ethetai",ethetai
4801         enddo
4802         if (lprn) then
4803         write (iout,*) "cosph and sinph"
4804         do k=1,nsingle
4805           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4806         enddo
4807         write (iout,*) "cosph1ph2 and sinph2ph2"
4808         do k=2,ndouble
4809           do l=1,k-1
4810             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4811                sinph1ph2(l,k),sinph1ph2(k,l)
4812           enddo
4813         enddo
4814         write(iout,*) "ethetai",ethetai
4815         endif
4816         do m=1,ntheterm2
4817           do k=1,nsingle
4818             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4819                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4820                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4821                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4822             ethetai=ethetai+sinkt(m)*aux
4823             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4824             dephii=dephii+k*sinkt(m)* &
4825                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4826                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4827             dephii1=dephii1+k*sinkt(m)* &
4828                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4829                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4830             if (lprn) &
4831             write (iout,*) "m",m," k",k," bbthet", &
4832                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4833                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4834                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4835                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4836           enddo
4837         enddo
4838         if (lprn) &
4839         write(iout,*) "ethetai",ethetai
4840         do m=1,ntheterm3
4841           do k=2,ndouble
4842             do l=1,k-1
4843               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4844                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4845                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4846                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4847               ethetai=ethetai+sinkt(m)*aux
4848               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4849               dephii=dephii+l*sinkt(m)* &
4850                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4851                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4852                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4853                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4854               dephii1=dephii1+(k-l)*sinkt(m)* &
4855                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4856                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4857                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4858                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4859               if (lprn) then
4860               write (iout,*) "m",m," k",k," l",l," ffthet",&
4861                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4862                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4863                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4864                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4865                   " ethetai",ethetai
4866               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4867                   cosph1ph2(k,l)*sinkt(m),&
4868                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4869               endif
4870             enddo
4871           enddo
4872         enddo
4873 10      continue
4874 !        lprn1=.true.
4875         if (lprn1) &
4876           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4877          i,theta(i)*rad2deg,phii*rad2deg,&
4878          phii1*rad2deg,ethetai
4879 !        lprn1=.false.
4880         etheta=etheta+ethetai
4881         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4882                                     'ebend',i,ethetai
4883         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4884         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4885         gloc(nphi+i-2,icg)=wang*dethetai
4886       enddo
4887       return
4888       end subroutine ebend
4889 #endif
4890 #ifdef CRYST_SC
4891 !-----------------------------------------------------------------------------
4892       subroutine esc(escloc)
4893 ! Calculate the local energy of a side chain and its derivatives in the
4894 ! corresponding virtual-bond valence angles THETA and the spherical angles
4895 ! ALPHA and OMEGA.
4896 !
4897       use comm_sccalc
4898 !      implicit real*8 (a-h,o-z)
4899 !      include 'DIMENSIONS'
4900 !      include 'COMMON.GEO'
4901 !      include 'COMMON.LOCAL'
4902 !      include 'COMMON.VAR'
4903 !      include 'COMMON.INTERACT'
4904 !      include 'COMMON.DERIV'
4905 !      include 'COMMON.CHAIN'
4906 !      include 'COMMON.IOUNITS'
4907 !      include 'COMMON.NAMES'
4908 !      include 'COMMON.FFIELD'
4909 !      include 'COMMON.CONTROL'
4910       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4911          ddersc0,ddummy,xtemp,temp
4912 !el      real(kind=8) :: time11,time12,time112,theti
4913       real(kind=8) :: escloc,delta
4914 !el      integer :: it,nlobit
4915 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4916 !el local variables
4917       integer :: i,k
4918       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4919        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4920       delta=0.02d0*pi
4921       escloc=0.0D0
4922 !     write (iout,'(a)') 'ESC'
4923       do i=loc_start,loc_end
4924         it=itype(i)
4925         if (it.eq.ntyp1) cycle
4926         if (it.eq.10) goto 1
4927         nlobit=nlob(iabs(it))
4928 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4929 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4930         theti=theta(i+1)-pipol
4931         x(1)=dtan(theti)
4932         x(2)=alph(i)
4933         x(3)=omeg(i)
4934
4935         if (x(2).gt.pi-delta) then
4936           xtemp(1)=x(1)
4937           xtemp(2)=pi-delta
4938           xtemp(3)=x(3)
4939           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4940           xtemp(2)=pi
4941           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4942           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4943               escloci,dersc(2))
4944           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4945               ddersc0(1),dersc(1))
4946           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4947               ddersc0(3),dersc(3))
4948           xtemp(2)=pi-delta
4949           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4950           xtemp(2)=pi
4951           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4952           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4953                   dersc0(2),esclocbi,dersc02)
4954           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4955                   dersc12,dersc01)
4956           call splinthet(x(2),0.5d0*delta,ss,ssd)
4957           dersc0(1)=dersc01
4958           dersc0(2)=dersc02
4959           dersc0(3)=0.0d0
4960           do k=1,3
4961             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4962           enddo
4963           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4964 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4965 !    &             esclocbi,ss,ssd
4966           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4967 !         escloci=esclocbi
4968 !         write (iout,*) escloci
4969         else if (x(2).lt.delta) then
4970           xtemp(1)=x(1)
4971           xtemp(2)=delta
4972           xtemp(3)=x(3)
4973           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4974           xtemp(2)=0.0d0
4975           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4976           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4977               escloci,dersc(2))
4978           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4979               ddersc0(1),dersc(1))
4980           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4981               ddersc0(3),dersc(3))
4982           xtemp(2)=delta
4983           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4984           xtemp(2)=0.0d0
4985           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4986           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4987                   dersc0(2),esclocbi,dersc02)
4988           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4989                   dersc12,dersc01)
4990           dersc0(1)=dersc01
4991           dersc0(2)=dersc02
4992           dersc0(3)=0.0d0
4993           call splinthet(x(2),0.5d0*delta,ss,ssd)
4994           do k=1,3
4995             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4996           enddo
4997           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4998 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4999 !    &             esclocbi,ss,ssd
5000           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5001 !         write (iout,*) escloci
5002         else
5003           call enesc(x,escloci,dersc,ddummy,.false.)
5004         endif
5005
5006         escloc=escloc+escloci
5007         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5008            'escloc',i,escloci
5009 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5010
5011         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5012          wscloc*dersc(1)
5013         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5014         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5015     1   continue
5016       enddo
5017       return
5018       end subroutine esc
5019 !-----------------------------------------------------------------------------
5020       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5021
5022       use comm_sccalc
5023 !      implicit real*8 (a-h,o-z)
5024 !      include 'DIMENSIONS'
5025 !      include 'COMMON.GEO'
5026 !      include 'COMMON.LOCAL'
5027 !      include 'COMMON.IOUNITS'
5028 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5029       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5030       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5031       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5032       real(kind=8) :: escloci
5033       logical :: mixed
5034 !el local variables
5035       integer :: j,iii,l,k !el,it,nlobit
5036       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5037 !el       time11,time12,time112
5038 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5039         escloc_i=0.0D0
5040         do j=1,3
5041           dersc(j)=0.0D0
5042           if (mixed) ddersc(j)=0.0d0
5043         enddo
5044         x3=x(3)
5045
5046 ! Because of periodicity of the dependence of the SC energy in omega we have
5047 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5048 ! To avoid underflows, first compute & store the exponents.
5049
5050         do iii=-1,1
5051
5052           x(3)=x3+iii*dwapi
5053
5054           do j=1,nlobit
5055             do k=1,3
5056               z(k)=x(k)-censc(k,j,it)
5057             enddo
5058             do k=1,3
5059               Axk=0.0D0
5060               do l=1,3
5061                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5062               enddo
5063               Ax(k,j,iii)=Axk
5064             enddo
5065             expfac=0.0D0
5066             do k=1,3
5067               expfac=expfac+Ax(k,j,iii)*z(k)
5068             enddo
5069             contr(j,iii)=expfac
5070           enddo ! j
5071
5072         enddo ! iii
5073
5074         x(3)=x3
5075 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5076 ! subsequent NaNs and INFs in energy calculation.
5077 ! Find the largest exponent
5078         emin=contr(1,-1)
5079         do iii=-1,1
5080           do j=1,nlobit
5081             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5082           enddo
5083         enddo
5084         emin=0.5D0*emin
5085 !d      print *,'it=',it,' emin=',emin
5086
5087 ! Compute the contribution to SC energy and derivatives
5088         do iii=-1,1
5089
5090           do j=1,nlobit
5091 #ifdef OSF
5092             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5093             if(adexp.ne.adexp) adexp=1.0
5094             expfac=dexp(adexp)
5095 #else
5096             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5097 #endif
5098 !d          print *,'j=',j,' expfac=',expfac
5099             escloc_i=escloc_i+expfac
5100             do k=1,3
5101               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5102             enddo
5103             if (mixed) then
5104               do k=1,3,2
5105                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5106                   +gaussc(k,2,j,it))*expfac
5107               enddo
5108             endif
5109           enddo
5110
5111         enddo ! iii
5112
5113         dersc(1)=dersc(1)/cos(theti)**2
5114         ddersc(1)=ddersc(1)/cos(theti)**2
5115         ddersc(3)=ddersc(3)
5116
5117         escloci=-(dlog(escloc_i)-emin)
5118         do j=1,3
5119           dersc(j)=dersc(j)/escloc_i
5120         enddo
5121         if (mixed) then
5122           do j=1,3,2
5123             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5124           enddo
5125         endif
5126       return
5127       end subroutine enesc
5128 !-----------------------------------------------------------------------------
5129       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5130
5131       use comm_sccalc
5132 !      implicit real*8 (a-h,o-z)
5133 !      include 'DIMENSIONS'
5134 !      include 'COMMON.GEO'
5135 !      include 'COMMON.LOCAL'
5136 !      include 'COMMON.IOUNITS'
5137 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5138       real(kind=8),dimension(3) :: x,z,dersc
5139       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5140       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5141       real(kind=8) :: escloci,dersc12,emin
5142       logical :: mixed
5143 !el local varables
5144       integer :: j,k,l !el,it,nlobit
5145       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5146
5147       escloc_i=0.0D0
5148
5149       do j=1,3
5150         dersc(j)=0.0D0
5151       enddo
5152
5153       do j=1,nlobit
5154         do k=1,2
5155           z(k)=x(k)-censc(k,j,it)
5156         enddo
5157         z(3)=dwapi
5158         do k=1,3
5159           Axk=0.0D0
5160           do l=1,3
5161             Axk=Axk+gaussc(l,k,j,it)*z(l)
5162           enddo
5163           Ax(k,j)=Axk
5164         enddo
5165         expfac=0.0D0
5166         do k=1,3
5167           expfac=expfac+Ax(k,j)*z(k)
5168         enddo
5169         contr(j)=expfac
5170       enddo ! j
5171
5172 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5173 ! subsequent NaNs and INFs in energy calculation.
5174 ! Find the largest exponent
5175       emin=contr(1)
5176       do j=1,nlobit
5177         if (emin.gt.contr(j)) emin=contr(j)
5178       enddo
5179       emin=0.5D0*emin
5180
5181 ! Compute the contribution to SC energy and derivatives
5182
5183       dersc12=0.0d0
5184       do j=1,nlobit
5185         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5186         escloc_i=escloc_i+expfac
5187         do k=1,2
5188           dersc(k)=dersc(k)+Ax(k,j)*expfac
5189         enddo
5190         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5191                   +gaussc(1,2,j,it))*expfac
5192         dersc(3)=0.0d0
5193       enddo
5194
5195       dersc(1)=dersc(1)/cos(theti)**2
5196       dersc12=dersc12/cos(theti)**2
5197       escloci=-(dlog(escloc_i)-emin)
5198       do j=1,2
5199         dersc(j)=dersc(j)/escloc_i
5200       enddo
5201       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5202       return
5203       end subroutine enesc_bound
5204 #else
5205 !-----------------------------------------------------------------------------
5206       subroutine esc(escloc)
5207 ! Calculate the local energy of a side chain and its derivatives in the
5208 ! corresponding virtual-bond valence angles THETA and the spherical angles
5209 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5210 ! added by Urszula Kozlowska. 07/11/2007
5211 !
5212       use comm_sccalc
5213 !      implicit real*8 (a-h,o-z)
5214 !      include 'DIMENSIONS'
5215 !      include 'COMMON.GEO'
5216 !      include 'COMMON.LOCAL'
5217 !      include 'COMMON.VAR'
5218 !      include 'COMMON.SCROT'
5219 !      include 'COMMON.INTERACT'
5220 !      include 'COMMON.DERIV'
5221 !      include 'COMMON.CHAIN'
5222 !      include 'COMMON.IOUNITS'
5223 !      include 'COMMON.NAMES'
5224 !      include 'COMMON.FFIELD'
5225 !      include 'COMMON.CONTROL'
5226 !      include 'COMMON.VECTORS'
5227       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5228       real(kind=8),dimension(65) :: x
5229       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5230          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5231       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5232       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5233          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5234 !el local variables
5235       integer :: i,j,k !el,it,nlobit
5236       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5237 !el      real(kind=8) :: time11,time12,time112,theti
5238 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5239       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5240                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5241                    sumene1x,sumene2x,sumene3x,sumene4x,&
5242                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5243                    cosfac2xx,sinfac2yy
5244 #ifdef DEBUG
5245       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5246                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5247                    de_dt_num
5248 #endif
5249 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5250
5251       delta=0.02d0*pi
5252       escloc=0.0D0
5253       do i=loc_start,loc_end
5254         if (itype(i).eq.ntyp1) cycle
5255         costtab(i+1) =dcos(theta(i+1))
5256         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5257         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5258         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5259         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5260         cosfac=dsqrt(cosfac2)
5261         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5262         sinfac=dsqrt(sinfac2)
5263         it=iabs(itype(i))
5264         if (it.eq.10) goto 1
5265 !
5266 !  Compute the axes of tghe local cartesian coordinates system; store in
5267 !   x_prime, y_prime and z_prime
5268 !
5269         do j=1,3
5270           x_prime(j) = 0.00
5271           y_prime(j) = 0.00
5272           z_prime(j) = 0.00
5273         enddo
5274 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5275 !     &   dc_norm(3,i+nres)
5276         do j = 1,3
5277           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5278           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5279         enddo
5280         do j = 1,3
5281           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5282         enddo
5283 !       write (2,*) "i",i
5284 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5285 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5286 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5287 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5288 !      & " xy",scalar(x_prime(1),y_prime(1)),
5289 !      & " xz",scalar(x_prime(1),z_prime(1)),
5290 !      & " yy",scalar(y_prime(1),y_prime(1)),
5291 !      & " yz",scalar(y_prime(1),z_prime(1)),
5292 !      & " zz",scalar(z_prime(1),z_prime(1))
5293 !
5294 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5295 ! to local coordinate system. Store in xx, yy, zz.
5296 !
5297         xx=0.0d0
5298         yy=0.0d0
5299         zz=0.0d0
5300         do j = 1,3
5301           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5302           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5303           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5304         enddo
5305
5306         xxtab(i)=xx
5307         yytab(i)=yy
5308         zztab(i)=zz
5309 !
5310 ! Compute the energy of the ith side cbain
5311 !
5312 !        write (2,*) "xx",xx," yy",yy," zz",zz
5313         it=iabs(itype(i))
5314         do j = 1,65
5315           x(j) = sc_parmin(j,it)
5316         enddo
5317 #ifdef CHECK_COORD
5318 !c diagnostics - remove later
5319         xx1 = dcos(alph(2))
5320         yy1 = dsin(alph(2))*dcos(omeg(2))
5321         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5322         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5323           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5324           xx1,yy1,zz1
5325 !,"  --- ", xx_w,yy_w,zz_w
5326 ! end diagnostics
5327 #endif
5328         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5329          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5330          + x(10)*yy*zz
5331         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5332          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5333          + x(20)*yy*zz
5334         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5335          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5336          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5337          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5338          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5339          +x(40)*xx*yy*zz
5340         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5341          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5342          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5343          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5344          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5345          +x(60)*xx*yy*zz
5346         dsc_i   = 0.743d0+x(61)
5347         dp2_i   = 1.9d0+x(62)
5348         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5349                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5350         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5351                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5352         s1=(1+x(63))/(0.1d0 + dscp1)
5353         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5354         s2=(1+x(65))/(0.1d0 + dscp2)
5355         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5356         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5357       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5358 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5359 !     &   sumene4,
5360 !     &   dscp1,dscp2,sumene
5361 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5362         escloc = escloc + sumene
5363 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5364 !     & ,zz,xx,yy
5365 !#define DEBUG
5366 #ifdef DEBUG
5367 !
5368 ! This section to check the numerical derivatives of the energy of ith side
5369 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5370 ! #define DEBUG in the code to turn it on.
5371 !
5372         write (2,*) "sumene               =",sumene
5373         aincr=1.0d-7
5374         xxsave=xx
5375         xx=xx+aincr
5376         write (2,*) xx,yy,zz
5377         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         de_dxx_num=(sumenep-sumene)/aincr
5379         xx=xxsave
5380         write (2,*) "xx+ sumene from enesc=",sumenep
5381         yysave=yy
5382         yy=yy+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dyy_num=(sumenep-sumene)/aincr
5386         yy=yysave
5387         write (2,*) "yy+ sumene from enesc=",sumenep
5388         zzsave=zz
5389         zz=zz+aincr
5390         write (2,*) xx,yy,zz
5391         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5392         de_dzz_num=(sumenep-sumene)/aincr
5393         zz=zzsave
5394         write (2,*) "zz+ sumene from enesc=",sumenep
5395         costsave=cost2tab(i+1)
5396         sintsave=sint2tab(i+1)
5397         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5398         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5399         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5400         de_dt_num=(sumenep-sumene)/aincr
5401         write (2,*) " t+ sumene from enesc=",sumenep
5402         cost2tab(i+1)=costsave
5403         sint2tab(i+1)=sintsave
5404 ! End of diagnostics section.
5405 #endif
5406 !
5407 ! Compute the gradient of esc
5408 !
5409 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5410         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5411         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5412         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5413         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5414         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5415         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5416         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5417         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5418         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5419            *(pom_s1/dscp1+pom_s16*dscp1**4)
5420         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5421            *(pom_s2/dscp2+pom_s26*dscp2**4)
5422         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5423         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5424         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5425         +x(40)*yy*zz
5426         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5427         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5428         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5429         +x(60)*yy*zz
5430         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5431               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5432               +(pom1+pom2)*pom_dx
5433 #ifdef DEBUG
5434         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5435 #endif
5436 !
5437         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5438         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5439         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5440         +x(40)*xx*zz
5441         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5442         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5443         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5444         +x(59)*zz**2 +x(60)*xx*zz
5445         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5446               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5447               +(pom1-pom2)*pom_dy
5448 #ifdef DEBUG
5449         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5450 #endif
5451 !
5452         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5453         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5454         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5455         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5456         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5457         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5458         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5459         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5460 #ifdef DEBUG
5461         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5462 #endif
5463 !
5464         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5465         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5466         +pom1*pom_dt1+pom2*pom_dt2
5467 #ifdef DEBUG
5468         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5469 #endif
5470 !
5471 !
5472        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5473        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5474        cosfac2xx=cosfac2*xx
5475        sinfac2yy=sinfac2*yy
5476        do k = 1,3
5477          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5478             vbld_inv(i+1)
5479          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5480             vbld_inv(i)
5481          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5482          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5483 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5484 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5485 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5486 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5487          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5488          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5489          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5490          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5491          dZZ_Ci1(k)=0.0d0
5492          dZZ_Ci(k)=0.0d0
5493          do j=1,3
5494            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5495            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5496            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5497            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5498          enddo
5499
5500          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5501          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5502          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5503          (z_prime(k)-zz*dC_norm(k,i+nres))
5504 !
5505          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5506          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5507        enddo
5508
5509        do k=1,3
5510          dXX_Ctab(k,i)=dXX_Ci(k)
5511          dXX_C1tab(k,i)=dXX_Ci1(k)
5512          dYY_Ctab(k,i)=dYY_Ci(k)
5513          dYY_C1tab(k,i)=dYY_Ci1(k)
5514          dZZ_Ctab(k,i)=dZZ_Ci(k)
5515          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5516          dXX_XYZtab(k,i)=dXX_XYZ(k)
5517          dYY_XYZtab(k,i)=dYY_XYZ(k)
5518          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5519        enddo
5520
5521        do k = 1,3
5522 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5523 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5524 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5525 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5526 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5527 !     &    dt_dci(k)
5528 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5529 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5530          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5531           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5532          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5533           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5534          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5535           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5536        enddo
5537 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5538 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5539
5540 ! to check gradient call subroutine check_grad
5541
5542     1 continue
5543       enddo
5544       return
5545       end subroutine esc
5546 !-----------------------------------------------------------------------------
5547       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5548 !      implicit none
5549       real(kind=8),dimension(65) :: x
5550       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5551         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5552
5553       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5554         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5555         + x(10)*yy*zz
5556       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5557         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5558         + x(20)*yy*zz
5559       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5560         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5561         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5562         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5563         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5564         +x(40)*xx*yy*zz
5565       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5566         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5567         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5568         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5569         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5570         +x(60)*xx*yy*zz
5571       dsc_i   = 0.743d0+x(61)
5572       dp2_i   = 1.9d0+x(62)
5573       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5574                 *(xx*cost2+yy*sint2))
5575       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5576                 *(xx*cost2-yy*sint2))
5577       s1=(1+x(63))/(0.1d0 + dscp1)
5578       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5579       s2=(1+x(65))/(0.1d0 + dscp2)
5580       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5581       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5582        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5583       enesc=sumene
5584       return
5585       end function enesc
5586 #endif
5587 !-----------------------------------------------------------------------------
5588       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5589 !
5590 ! This procedure calculates two-body contact function g(rij) and its derivative:
5591 !
5592 !           eps0ij                                     !       x < -1
5593 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5594 !            0                                         !       x > 1
5595 !
5596 ! where x=(rij-r0ij)/delta
5597 !
5598 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5599 !
5600 !      implicit none
5601       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5602       real(kind=8) :: x,x2,x4,delta
5603 !     delta=0.02D0*r0ij
5604 !      delta=0.2D0*r0ij
5605       x=(rij-r0ij)/delta
5606       if (x.lt.-1.0D0) then
5607         fcont=eps0ij
5608         fprimcont=0.0D0
5609       else if (x.le.1.0D0) then
5610         x2=x*x
5611         x4=x2*x2
5612         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5613         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5614       else
5615         fcont=0.0D0
5616         fprimcont=0.0D0
5617       endif
5618       return
5619       end subroutine gcont
5620 !-----------------------------------------------------------------------------
5621       subroutine splinthet(theti,delta,ss,ssder)
5622 !      implicit real*8 (a-h,o-z)
5623 !      include 'DIMENSIONS'
5624 !      include 'COMMON.VAR'
5625 !      include 'COMMON.GEO'
5626       real(kind=8) :: theti,delta,ss,ssder
5627       real(kind=8) :: thetup,thetlow
5628       thetup=pi-delta
5629       thetlow=delta
5630       if (theti.gt.pipol) then
5631         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5632       else
5633         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5634         ssder=-ssder
5635       endif
5636       return
5637       end subroutine splinthet
5638 !-----------------------------------------------------------------------------
5639       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5640 !      implicit none
5641       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5642       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5643       a1=fprim0*delta/(f1-f0)
5644       a2=3.0d0-2.0d0*a1
5645       a3=a1-2.0d0
5646       ksi=(x-x0)/delta
5647       ksi2=ksi*ksi
5648       ksi3=ksi2*ksi
5649       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5650       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5651       return
5652       end subroutine spline1
5653 !-----------------------------------------------------------------------------
5654       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5655 !      implicit none
5656       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5657       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5658       ksi=(x-x0)/delta
5659       ksi2=ksi*ksi
5660       ksi3=ksi2*ksi
5661       a1=fprim0x*delta
5662       a2=3*(f1x-f0x)-2*fprim0x*delta
5663       a3=fprim0x*delta-2*(f1x-f0x)
5664       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5665       return
5666       end subroutine spline2
5667 !-----------------------------------------------------------------------------
5668 #ifdef CRYST_TOR
5669 !-----------------------------------------------------------------------------
5670       subroutine etor(etors,edihcnstr)
5671 !      implicit real*8 (a-h,o-z)
5672 !      include 'DIMENSIONS'
5673 !      include 'COMMON.VAR'
5674 !      include 'COMMON.GEO'
5675 !      include 'COMMON.LOCAL'
5676 !      include 'COMMON.TORSION'
5677 !      include 'COMMON.INTERACT'
5678 !      include 'COMMON.DERIV'
5679 !      include 'COMMON.CHAIN'
5680 !      include 'COMMON.NAMES'
5681 !      include 'COMMON.IOUNITS'
5682 !      include 'COMMON.FFIELD'
5683 !      include 'COMMON.TORCNSTR'
5684 !      include 'COMMON.CONTROL'
5685       real(kind=8) :: etors,edihcnstr
5686       logical :: lprn
5687 !el local variables
5688       integer :: i,j,
5689       real(kind=8) :: phii,fac,etors_ii
5690
5691 ! Set lprn=.true. for debugging
5692       lprn=.false.
5693 !      lprn=.true.
5694       etors=0.0D0
5695       do i=iphi_start,iphi_end
5696       etors_ii=0.0D0
5697         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5698             .or. itype(i).eq.ntyp1) cycle
5699         itori=itortyp(itype(i-2))
5700         itori1=itortyp(itype(i-1))
5701         phii=phi(i)
5702         gloci=0.0D0
5703 ! Proline-Proline pair is a special case...
5704         if (itori.eq.3 .and. itori1.eq.3) then
5705           if (phii.gt.-dwapi3) then
5706             cosphi=dcos(3*phii)
5707             fac=1.0D0/(1.0D0-cosphi)
5708             etorsi=v1(1,3,3)*fac
5709             etorsi=etorsi+etorsi
5710             etors=etors+etorsi-v1(1,3,3)
5711             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5712             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5713           endif
5714           do j=1,3
5715             v1ij=v1(j+1,itori,itori1)
5716             v2ij=v2(j+1,itori,itori1)
5717             cosphi=dcos(j*phii)
5718             sinphi=dsin(j*phii)
5719             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5720             if (energy_dec) etors_ii=etors_ii+ &
5721                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5722             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5723           enddo
5724         else
5725           do j=1,nterm_old
5726             v1ij=v1(j,itori,itori1)
5727             v2ij=v2(j,itori,itori1)
5728             cosphi=dcos(j*phii)
5729             sinphi=dsin(j*phii)
5730             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5731             if (energy_dec) etors_ii=etors_ii+ &
5732                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5733             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5734           enddo
5735         endif
5736         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5737              'etor',i,etors_ii
5738         if (lprn) &
5739         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5740         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5741         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5742         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5743 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5744       enddo
5745 ! 6/20/98 - dihedral angle constraints
5746       edihcnstr=0.0d0
5747       do i=1,ndih_constr
5748         itori=idih_constr(i)
5749         phii=phi(itori)
5750         difi=phii-phi0(i)
5751         if (difi.gt.drange(i)) then
5752           difi=difi-drange(i)
5753           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5754           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5755         else if (difi.lt.-drange(i)) then
5756           difi=difi+drange(i)
5757           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5758           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5759         endif
5760 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5761 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5762       enddo
5763 !      write (iout,*) 'edihcnstr',edihcnstr
5764       return
5765       end subroutine etor
5766 !-----------------------------------------------------------------------------
5767       subroutine etor_d(etors_d)
5768       real(kind=8) :: etors_d
5769       etors_d=0.0d0
5770       return
5771       end subroutine etor_d
5772 #else
5773 !-----------------------------------------------------------------------------
5774       subroutine etor(etors,edihcnstr)
5775 !      implicit real*8 (a-h,o-z)
5776 !      include 'DIMENSIONS'
5777 !      include 'COMMON.VAR'
5778 !      include 'COMMON.GEO'
5779 !      include 'COMMON.LOCAL'
5780 !      include 'COMMON.TORSION'
5781 !      include 'COMMON.INTERACT'
5782 !      include 'COMMON.DERIV'
5783 !      include 'COMMON.CHAIN'
5784 !      include 'COMMON.NAMES'
5785 !      include 'COMMON.IOUNITS'
5786 !      include 'COMMON.FFIELD'
5787 !      include 'COMMON.TORCNSTR'
5788 !      include 'COMMON.CONTROL'
5789       real(kind=8) :: etors,edihcnstr
5790       logical :: lprn
5791 !el local variables
5792       integer :: i,j,iblock,itori,itori1
5793       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5794                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5795 ! Set lprn=.true. for debugging
5796       lprn=.false.
5797 !     lprn=.true.
5798       etors=0.0D0
5799       do i=iphi_start,iphi_end
5800         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5801              .or. itype(i-3).eq.ntyp1 &
5802              .or. itype(i).eq.ntyp1) cycle
5803         etors_ii=0.0D0
5804          if (iabs(itype(i)).eq.20) then
5805          iblock=2
5806          else
5807          iblock=1
5808          endif
5809         itori=itortyp(itype(i-2))
5810         itori1=itortyp(itype(i-1))
5811         phii=phi(i)
5812         gloci=0.0D0
5813 ! Regular cosine and sine terms
5814         do j=1,nterm(itori,itori1,iblock)
5815           v1ij=v1(j,itori,itori1,iblock)
5816           v2ij=v2(j,itori,itori1,iblock)
5817           cosphi=dcos(j*phii)
5818           sinphi=dsin(j*phii)
5819           etors=etors+v1ij*cosphi+v2ij*sinphi
5820           if (energy_dec) etors_ii=etors_ii+ &
5821                      v1ij*cosphi+v2ij*sinphi
5822           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5823         enddo
5824 ! Lorentz terms
5825 !                         v1
5826 !  E = SUM ----------------------------------- - v1
5827 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5828 !
5829         cosphi=dcos(0.5d0*phii)
5830         sinphi=dsin(0.5d0*phii)
5831         do j=1,nlor(itori,itori1,iblock)
5832           vl1ij=vlor1(j,itori,itori1)
5833           vl2ij=vlor2(j,itori,itori1)
5834           vl3ij=vlor3(j,itori,itori1)
5835           pom=vl2ij*cosphi+vl3ij*sinphi
5836           pom1=1.0d0/(pom*pom+1.0d0)
5837           etors=etors+vl1ij*pom1
5838           if (energy_dec) etors_ii=etors_ii+ &
5839                      vl1ij*pom1
5840           pom=-pom*pom1*pom1
5841           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5842         enddo
5843 ! Subtract the constant term
5844         etors=etors-v0(itori,itori1,iblock)
5845           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5846                'etor',i,etors_ii-v0(itori,itori1,iblock)
5847         if (lprn) &
5848         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5849         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5850         (v1(j,itori,itori1,iblock),j=1,6),&
5851         (v2(j,itori,itori1,iblock),j=1,6)
5852         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5853 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5854       enddo
5855 ! 6/20/98 - dihedral angle constraints
5856       edihcnstr=0.0d0
5857 !      do i=1,ndih_constr
5858       do i=idihconstr_start,idihconstr_end
5859         itori=idih_constr(i)
5860         phii=phi(itori)
5861         difi=pinorm(phii-phi0(i))
5862         if (difi.gt.drange(i)) then
5863           difi=difi-drange(i)
5864           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5865           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5866         else if (difi.lt.-drange(i)) then
5867           difi=difi+drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else
5871           difi=0.0
5872         endif
5873 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5874 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5875 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5876       enddo
5877 !d       write (iout,*) 'edihcnstr',edihcnstr
5878       return
5879       end subroutine etor
5880 !-----------------------------------------------------------------------------
5881       subroutine etor_d(etors_d)
5882 ! 6/23/01 Compute double torsional energy
5883 !      implicit real*8 (a-h,o-z)
5884 !      include 'DIMENSIONS'
5885 !      include 'COMMON.VAR'
5886 !      include 'COMMON.GEO'
5887 !      include 'COMMON.LOCAL'
5888 !      include 'COMMON.TORSION'
5889 !      include 'COMMON.INTERACT'
5890 !      include 'COMMON.DERIV'
5891 !      include 'COMMON.CHAIN'
5892 !      include 'COMMON.NAMES'
5893 !      include 'COMMON.IOUNITS'
5894 !      include 'COMMON.FFIELD'
5895 !      include 'COMMON.TORCNSTR'
5896       real(kind=8) :: etors_d,etors_d_ii
5897       logical :: lprn
5898 !el local variables
5899       integer :: i,j,k,l,itori,itori1,itori2,iblock
5900       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5901                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5902                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5903                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5904 ! Set lprn=.true. for debugging
5905       lprn=.false.
5906 !     lprn=.true.
5907       etors_d=0.0D0
5908 !      write(iout,*) "a tu??"
5909       do i=iphid_start,iphid_end
5910         etors_d_ii=0.0D0
5911         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5912             .or. itype(i-3).eq.ntyp1 &
5913             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5914         itori=itortyp(itype(i-2))
5915         itori1=itortyp(itype(i-1))
5916         itori2=itortyp(itype(i))
5917         phii=phi(i)
5918         phii1=phi(i+1)
5919         gloci1=0.0D0
5920         gloci2=0.0D0
5921         iblock=1
5922         if (iabs(itype(i+1)).eq.20) iblock=2
5923
5924 ! Regular cosine and sine terms
5925         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5926           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5927           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5928           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5929           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5930           cosphi1=dcos(j*phii)
5931           sinphi1=dsin(j*phii)
5932           cosphi2=dcos(j*phii1)
5933           sinphi2=dsin(j*phii1)
5934           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5935            v2cij*cosphi2+v2sij*sinphi2
5936           if (energy_dec) etors_d_ii=etors_d_ii+ &
5937            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5938           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5939           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5940         enddo
5941         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5942           do l=1,k-1
5943             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5944             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5945             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5946             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5947             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5948             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5949             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5950             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5951             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5952               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5953             if (energy_dec) etors_d_ii=etors_d_ii+ &
5954               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5955               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5956             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5957               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5958             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5959               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5960           enddo
5961         enddo
5962         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5963                             'etor_d',i,etors_d_ii
5964         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5965         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5966       enddo
5967       return
5968       end subroutine etor_d
5969 #endif
5970 !-----------------------------------------------------------------------------
5971       subroutine eback_sc_corr(esccor)
5972 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5973 !        conformational states; temporarily implemented as differences
5974 !        between UNRES torsional potentials (dependent on three types of
5975 !        residues) and the torsional potentials dependent on all 20 types
5976 !        of residues computed from AM1  energy surfaces of terminally-blocked
5977 !        amino-acid residues.
5978 !      implicit real*8 (a-h,o-z)
5979 !      include 'DIMENSIONS'
5980 !      include 'COMMON.VAR'
5981 !      include 'COMMON.GEO'
5982 !      include 'COMMON.LOCAL'
5983 !      include 'COMMON.TORSION'
5984 !      include 'COMMON.SCCOR'
5985 !      include 'COMMON.INTERACT'
5986 !      include 'COMMON.DERIV'
5987 !      include 'COMMON.CHAIN'
5988 !      include 'COMMON.NAMES'
5989 !      include 'COMMON.IOUNITS'
5990 !      include 'COMMON.FFIELD'
5991 !      include 'COMMON.CONTROL'
5992       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5993                    cosphi,sinphi
5994       logical :: lprn
5995       integer :: i,interty,j,isccori,isccori1,intertyp
5996 ! Set lprn=.true. for debugging
5997       lprn=.false.
5998 !      lprn=.true.
5999 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6000       esccor=0.0D0
6001       do i=itau_start,itau_end
6002         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6003         esccor_ii=0.0D0
6004         isccori=isccortyp(itype(i-2))
6005         isccori1=isccortyp(itype(i-1))
6006
6007 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6008         phii=phi(i)
6009         do intertyp=1,3 !intertyp
6010          esccor_ii=0.0D0
6011 !c Added 09 May 2012 (Adasko)
6012 !c  Intertyp means interaction type of backbone mainchain correlation:
6013 !   1 = SC...Ca...Ca...Ca
6014 !   2 = Ca...Ca...Ca...SC
6015 !   3 = SC...Ca...Ca...SCi
6016         gloci=0.0D0
6017         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6018             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6019             (itype(i-1).eq.ntyp1))) &
6020           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6021            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6022            .or.(itype(i).eq.ntyp1))) &
6023           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6024             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6025             (itype(i-3).eq.ntyp1)))) cycle
6026         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6027         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6028        cycle
6029        do j=1,nterm_sccor(isccori,isccori1)
6030           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6031           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6032           cosphi=dcos(j*tauangle(intertyp,i))
6033           sinphi=dsin(j*tauangle(intertyp,i))
6034           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6035           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6036           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6037         enddo
6038         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6039                                 'esccor',i,intertyp,esccor_ii
6040 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6041         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6042         if (lprn) &
6043         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6044         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6045         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6046         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6047         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6048        enddo !intertyp
6049       enddo
6050
6051       return
6052       end subroutine eback_sc_corr
6053 !-----------------------------------------------------------------------------
6054       subroutine multibody(ecorr)
6055 ! This subroutine calculates multi-body contributions to energy following
6056 ! the idea of Skolnick et al. If side chains I and J make a contact and
6057 ! at the same time side chains I+1 and J+1 make a contact, an extra
6058 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6059 !      implicit real*8 (a-h,o-z)
6060 !      include 'DIMENSIONS'
6061 !      include 'COMMON.IOUNITS'
6062 !      include 'COMMON.DERIV'
6063 !      include 'COMMON.INTERACT'
6064 !      include 'COMMON.CONTACTS'
6065       real(kind=8),dimension(3) :: gx,gx1
6066       logical :: lprn
6067       real(kind=8) :: ecorr
6068       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6069 ! Set lprn=.true. for debugging
6070       lprn=.false.
6071
6072       if (lprn) then
6073         write (iout,'(a)') 'Contact function values:'
6074         do i=nnt,nct-2
6075           write (iout,'(i2,20(1x,i2,f10.5))') &
6076               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6077         enddo
6078       endif
6079       ecorr=0.0D0
6080
6081 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6082 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6083       do i=nnt,nct
6084         do j=1,3
6085           gradcorr(j,i)=0.0D0
6086           gradxorr(j,i)=0.0D0
6087         enddo
6088       enddo
6089       do i=nnt,nct-2
6090
6091         DO ISHIFT = 3,4
6092
6093         i1=i+ishift
6094         num_conti=num_cont(i)
6095         num_conti1=num_cont(i1)
6096         do jj=1,num_conti
6097           j=jcont(jj,i)
6098           do kk=1,num_conti1
6099             j1=jcont(kk,i1)
6100             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6101 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6102 !d   &                   ' ishift=',ishift
6103 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6104 ! The system gains extra energy.
6105               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6106             endif   ! j1==j+-ishift
6107           enddo     ! kk
6108         enddo       ! jj
6109
6110         ENDDO ! ISHIFT
6111
6112       enddo         ! i
6113       return
6114       end subroutine multibody
6115 !-----------------------------------------------------------------------------
6116       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6117 !      implicit real*8 (a-h,o-z)
6118 !      include 'DIMENSIONS'
6119 !      include 'COMMON.IOUNITS'
6120 !      include 'COMMON.DERIV'
6121 !      include 'COMMON.INTERACT'
6122 !      include 'COMMON.CONTACTS'
6123       real(kind=8),dimension(3) :: gx,gx1
6124       logical :: lprn
6125       integer :: i,j,k,l,jj,kk,m,ll
6126       real(kind=8) :: eij,ekl
6127       lprn=.false.
6128       eij=facont(jj,i)
6129       ekl=facont(kk,k)
6130 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6131 ! Calculate the multi-body contribution to energy.
6132 ! Calculate multi-body contributions to the gradient.
6133 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6134 !d   & k,l,(gacont(m,kk,k),m=1,3)
6135       do m=1,3
6136         gx(m) =ekl*gacont(m,jj,i)
6137         gx1(m)=eij*gacont(m,kk,k)
6138         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6139         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6140         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6141         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6142       enddo
6143       do m=i,j-1
6144         do ll=1,3
6145           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6146         enddo
6147       enddo
6148       do m=k,l-1
6149         do ll=1,3
6150           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6151         enddo
6152       enddo
6153       esccorr=-eij*ekl
6154       return
6155       end function esccorr
6156 !-----------------------------------------------------------------------------
6157       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6158 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6159 !      implicit real*8 (a-h,o-z)
6160 !      include 'DIMENSIONS'
6161 !      include 'COMMON.IOUNITS'
6162 #ifdef MPI
6163       include "mpif.h"
6164 !      integer :: maxconts !max_cont=maxconts  =nres/4
6165       integer,parameter :: max_dim=26
6166       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6167       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6168 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6169 !el      common /przechowalnia/ zapas
6170       integer :: status(MPI_STATUS_SIZE)
6171       integer,dimension((nres/4)*2) :: req !maxconts*2
6172       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6173 #endif
6174 !      include 'COMMON.SETUP'
6175 !      include 'COMMON.FFIELD'
6176 !      include 'COMMON.DERIV'
6177 !      include 'COMMON.INTERACT'
6178 !      include 'COMMON.CONTACTS'
6179 !      include 'COMMON.CONTROL'
6180 !      include 'COMMON.LOCAL'
6181       real(kind=8),dimension(3) :: gx,gx1
6182       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6183       logical :: lprn,ldone
6184 !el local variables
6185       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6186               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6187
6188 ! Set lprn=.true. for debugging
6189       lprn=.false.
6190 #ifdef MPI
6191 !      maxconts=nres/4
6192       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6193       n_corr=0
6194       n_corr1=0
6195       if (nfgtasks.le.1) goto 30
6196       if (lprn) then
6197         write (iout,'(a)') 'Contact function values before RECEIVE:'
6198         do i=nnt,nct-2
6199           write (iout,'(2i3,50(1x,i2,f5.2))') &
6200           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6201           j=1,num_cont_hb(i))
6202         enddo
6203       endif
6204       call flush(iout)
6205       do i=1,ntask_cont_from
6206         ncont_recv(i)=0
6207       enddo
6208       do i=1,ntask_cont_to
6209         ncont_sent(i)=0
6210       enddo
6211 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6212 !     & ntask_cont_to
6213 ! Make the list of contacts to send to send to other procesors
6214 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6215 !      call flush(iout)
6216       do i=iturn3_start,iturn3_end
6217 !        write (iout,*) "make contact list turn3",i," num_cont",
6218 !     &    num_cont_hb(i)
6219         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6220       enddo
6221       do i=iturn4_start,iturn4_end
6222 !        write (iout,*) "make contact list turn4",i," num_cont",
6223 !     &   num_cont_hb(i)
6224         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6225       enddo
6226       do ii=1,nat_sent
6227         i=iat_sent(ii)
6228 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6229 !     &    num_cont_hb(i)
6230         do j=1,num_cont_hb(i)
6231         do k=1,4
6232           jjc=jcont_hb(j,i)
6233           iproc=iint_sent_local(k,jjc,ii)
6234 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6235           if (iproc.gt.0) then
6236             ncont_sent(iproc)=ncont_sent(iproc)+1
6237             nn=ncont_sent(iproc)
6238             zapas(1,nn,iproc)=i
6239             zapas(2,nn,iproc)=jjc
6240             zapas(3,nn,iproc)=facont_hb(j,i)
6241             zapas(4,nn,iproc)=ees0p(j,i)
6242             zapas(5,nn,iproc)=ees0m(j,i)
6243             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6244             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6245             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6246             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6247             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6248             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6249             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6250             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6251             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6252             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6253             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6254             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6255             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6256             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6257             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6258             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6259             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6260             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6261             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6262             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6263             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6264           endif
6265         enddo
6266         enddo
6267       enddo
6268       if (lprn) then
6269       write (iout,*) &
6270         "Numbers of contacts to be sent to other processors",&
6271         (ncont_sent(i),i=1,ntask_cont_to)
6272       write (iout,*) "Contacts sent"
6273       do ii=1,ntask_cont_to
6274         nn=ncont_sent(ii)
6275         iproc=itask_cont_to(ii)
6276         write (iout,*) nn," contacts to processor",iproc,&
6277          " of CONT_TO_COMM group"
6278         do i=1,nn
6279           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6280         enddo
6281       enddo
6282       call flush(iout)
6283       endif
6284       CorrelType=477
6285       CorrelID=fg_rank+1
6286       CorrelType1=478
6287       CorrelID1=nfgtasks+fg_rank+1
6288       ireq=0
6289 ! Receive the numbers of needed contacts from other processors
6290       do ii=1,ntask_cont_from
6291         iproc=itask_cont_from(ii)
6292         ireq=ireq+1
6293         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6294           FG_COMM,req(ireq),IERR)
6295       enddo
6296 !      write (iout,*) "IRECV ended"
6297 !      call flush(iout)
6298 ! Send the number of contacts needed by other processors
6299       do ii=1,ntask_cont_to
6300         iproc=itask_cont_to(ii)
6301         ireq=ireq+1
6302         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6303           FG_COMM,req(ireq),IERR)
6304       enddo
6305 !      write (iout,*) "ISEND ended"
6306 !      write (iout,*) "number of requests (nn)",ireq
6307       call flush(iout)
6308       if (ireq.gt.0) &
6309         call MPI_Waitall(ireq,req,status_array,ierr)
6310 !      write (iout,*)
6311 !     &  "Numbers of contacts to be received from other processors",
6312 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6313 !      call flush(iout)
6314 ! Receive contacts
6315       ireq=0
6316       do ii=1,ntask_cont_from
6317         iproc=itask_cont_from(ii)
6318         nn=ncont_recv(ii)
6319 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6320 !     &   " of CONT_TO_COMM group"
6321         call flush(iout)
6322         if (nn.gt.0) then
6323           ireq=ireq+1
6324           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6325           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6326 !          write (iout,*) "ireq,req",ireq,req(ireq)
6327         endif
6328       enddo
6329 ! Send the contacts to processors that need them
6330       do ii=1,ntask_cont_to
6331         iproc=itask_cont_to(ii)
6332         nn=ncont_sent(ii)
6333 !        write (iout,*) nn," contacts to processor",iproc,
6334 !     &   " of CONT_TO_COMM group"
6335         if (nn.gt.0) then
6336           ireq=ireq+1
6337           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6338             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6339 !          write (iout,*) "ireq,req",ireq,req(ireq)
6340 !          do i=1,nn
6341 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6342 !          enddo
6343         endif
6344       enddo
6345 !      write (iout,*) "number of requests (contacts)",ireq
6346 !      write (iout,*) "req",(req(i),i=1,4)
6347 !      call flush(iout)
6348       if (ireq.gt.0) &
6349        call MPI_Waitall(ireq,req,status_array,ierr)
6350       do iii=1,ntask_cont_from
6351         iproc=itask_cont_from(iii)
6352         nn=ncont_recv(iii)
6353         if (lprn) then
6354         write (iout,*) "Received",nn," contacts from processor",iproc,&
6355          " of CONT_FROM_COMM group"
6356         call flush(iout)
6357         do i=1,nn
6358           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6359         enddo
6360         call flush(iout)
6361         endif
6362         do i=1,nn
6363           ii=zapas_recv(1,i,iii)
6364 ! Flag the received contacts to prevent double-counting
6365           jj=-zapas_recv(2,i,iii)
6366 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6367 !          call flush(iout)
6368           nnn=num_cont_hb(ii)+1
6369           num_cont_hb(ii)=nnn
6370           jcont_hb(nnn,ii)=jj
6371           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6372           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6373           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6374           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6375           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6376           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6377           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6378           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6379           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6380           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6381           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6382           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6383           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6384           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6385           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6386           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6387           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6388           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6389           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6390           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6391           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6392           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6393           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6394           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6395         enddo
6396       enddo
6397       call flush(iout)
6398       if (lprn) then
6399         write (iout,'(a)') 'Contact function values after receive:'
6400         do i=nnt,nct-2
6401           write (iout,'(2i3,50(1x,i3,f5.2))') &
6402           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6403           j=1,num_cont_hb(i))
6404         enddo
6405         call flush(iout)
6406       endif
6407    30 continue
6408 #endif
6409       if (lprn) then
6410         write (iout,'(a)') 'Contact function values:'
6411         do i=nnt,nct-2
6412           write (iout,'(2i3,50(1x,i3,f5.2))') &
6413           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6414           j=1,num_cont_hb(i))
6415         enddo
6416       endif
6417       ecorr=0.0D0
6418
6419 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6420 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6421 ! Remove the loop below after debugging !!!
6422       do i=nnt,nct
6423         do j=1,3
6424           gradcorr(j,i)=0.0D0
6425           gradxorr(j,i)=0.0D0
6426         enddo
6427       enddo
6428 ! Calculate the local-electrostatic correlation terms
6429       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6430         i1=i+1
6431         num_conti=num_cont_hb(i)
6432         num_conti1=num_cont_hb(i+1)
6433         do jj=1,num_conti
6434           j=jcont_hb(jj,i)
6435           jp=iabs(j)
6436           do kk=1,num_conti1
6437             j1=jcont_hb(kk,i1)
6438             jp1=iabs(j1)
6439 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6440 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6441             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6442                 .or. j.lt.0 .and. j1.gt.0) .and. &
6443                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6444 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6445 ! The system gains extra energy.
6446               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6447               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6448                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6449               n_corr=n_corr+1
6450             else if (j1.eq.j) then
6451 ! Contacts I-J and I-(J+1) occur simultaneously.
6452 ! The system loses extra energy.
6453 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6454             endif
6455           enddo ! kk
6456           do kk=1,num_conti
6457             j1=jcont_hb(kk,i)
6458 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6459 !    &         ' jj=',jj,' kk=',kk
6460             if (j1.eq.j+1) then
6461 ! Contacts I-J and (I+1)-J occur simultaneously.
6462 ! The system loses extra energy.
6463 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6464             endif ! j1==j+1
6465           enddo ! kk
6466         enddo ! jj
6467       enddo ! i
6468       return
6469       end subroutine multibody_hb
6470 !-----------------------------------------------------------------------------
6471       subroutine add_hb_contact(ii,jj,itask)
6472 !      implicit real*8 (a-h,o-z)
6473 !      include "DIMENSIONS"
6474 !      include "COMMON.IOUNITS"
6475 !      include "COMMON.CONTACTS"
6476 !      integer,parameter :: maxconts=nres/4
6477       integer,parameter :: max_dim=26
6478       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6479 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6480 !      common /przechowalnia/ zapas
6481       integer :: i,j,ii,jj,iproc,nn,jjc
6482       integer,dimension(4) :: itask
6483 !      write (iout,*) "itask",itask
6484       do i=1,2
6485         iproc=itask(i)
6486         if (iproc.gt.0) then
6487           do j=1,num_cont_hb(ii)
6488             jjc=jcont_hb(j,ii)
6489 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6490             if (jjc.eq.jj) then
6491               ncont_sent(iproc)=ncont_sent(iproc)+1
6492               nn=ncont_sent(iproc)
6493               zapas(1,nn,iproc)=ii
6494               zapas(2,nn,iproc)=jjc
6495               zapas(3,nn,iproc)=facont_hb(j,ii)
6496               zapas(4,nn,iproc)=ees0p(j,ii)
6497               zapas(5,nn,iproc)=ees0m(j,ii)
6498               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6499               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6500               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6501               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6502               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6503               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6504               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6505               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6506               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6507               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6508               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6509               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6510               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6511               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6512               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6513               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6514               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6515               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6516               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6517               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6518               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6519               exit
6520             endif
6521           enddo
6522         endif
6523       enddo
6524       return
6525       end subroutine add_hb_contact
6526 !-----------------------------------------------------------------------------
6527       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6528 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6529 !      implicit real*8 (a-h,o-z)
6530 !      include 'DIMENSIONS'
6531 !      include 'COMMON.IOUNITS'
6532       integer,parameter :: max_dim=70
6533 #ifdef MPI
6534       include "mpif.h"
6535 !      integer :: maxconts !max_cont=maxconts=nres/4
6536       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6537       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6538 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6539 !      common /przechowalnia/ zapas
6540       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6541         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6542         ierr,iii,nnn
6543 #endif
6544 !      include 'COMMON.SETUP'
6545 !      include 'COMMON.FFIELD'
6546 !      include 'COMMON.DERIV'
6547 !      include 'COMMON.LOCAL'
6548 !      include 'COMMON.INTERACT'
6549 !      include 'COMMON.CONTACTS'
6550 !      include 'COMMON.CHAIN'
6551 !      include 'COMMON.CONTROL'
6552       real(kind=8),dimension(3) :: gx,gx1
6553       integer,dimension(nres) :: num_cont_hb_old
6554       logical :: lprn,ldone
6555 !EL      double precision eello4,eello5,eelo6,eello_turn6
6556 !EL      external eello4,eello5,eello6,eello_turn6
6557 !el local variables
6558       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6559               j1,jp1,i1,num_conti1
6560       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6561       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6562
6563 ! Set lprn=.true. for debugging
6564       lprn=.false.
6565       eturn6=0.0d0
6566 #ifdef MPI
6567 !      maxconts=nres/4
6568       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6569       do i=1,nres
6570         num_cont_hb_old(i)=num_cont_hb(i)
6571       enddo
6572       n_corr=0
6573       n_corr1=0
6574       if (nfgtasks.le.1) goto 30
6575       if (lprn) then
6576         write (iout,'(a)') 'Contact function values before RECEIVE:'
6577         do i=nnt,nct-2
6578           write (iout,'(2i3,50(1x,i2,f5.2))') &
6579           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6580           j=1,num_cont_hb(i))
6581         enddo
6582       endif
6583       call flush(iout)
6584       do i=1,ntask_cont_from
6585         ncont_recv(i)=0
6586       enddo
6587       do i=1,ntask_cont_to
6588         ncont_sent(i)=0
6589       enddo
6590 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6591 !     & ntask_cont_to
6592 ! Make the list of contacts to send to send to other procesors
6593       do i=iturn3_start,iturn3_end
6594 !        write (iout,*) "make contact list turn3",i," num_cont",
6595 !     &    num_cont_hb(i)
6596         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6597       enddo
6598       do i=iturn4_start,iturn4_end
6599 !        write (iout,*) "make contact list turn4",i," num_cont",
6600 !     &   num_cont_hb(i)
6601         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6602       enddo
6603       do ii=1,nat_sent
6604         i=iat_sent(ii)
6605 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6606 !     &    num_cont_hb(i)
6607         do j=1,num_cont_hb(i)
6608         do k=1,4
6609           jjc=jcont_hb(j,i)
6610           iproc=iint_sent_local(k,jjc,ii)
6611 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6612           if (iproc.ne.0) then
6613             ncont_sent(iproc)=ncont_sent(iproc)+1
6614             nn=ncont_sent(iproc)
6615             zapas(1,nn,iproc)=i
6616             zapas(2,nn,iproc)=jjc
6617             zapas(3,nn,iproc)=d_cont(j,i)
6618             ind=3
6619             do kk=1,3
6620               ind=ind+1
6621               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6622             enddo
6623             do kk=1,2
6624               do ll=1,2
6625                 ind=ind+1
6626                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6627               enddo
6628             enddo
6629             do jj=1,5
6630               do kk=1,3
6631                 do ll=1,2
6632                   do mm=1,2
6633                     ind=ind+1
6634                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6635                   enddo
6636                 enddo
6637               enddo
6638             enddo
6639           endif
6640         enddo
6641         enddo
6642       enddo
6643       if (lprn) then
6644       write (iout,*) &
6645         "Numbers of contacts to be sent to other processors",&
6646         (ncont_sent(i),i=1,ntask_cont_to)
6647       write (iout,*) "Contacts sent"
6648       do ii=1,ntask_cont_to
6649         nn=ncont_sent(ii)
6650         iproc=itask_cont_to(ii)
6651         write (iout,*) nn," contacts to processor",iproc,&
6652          " of CONT_TO_COMM group"
6653         do i=1,nn
6654           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6655         enddo
6656       enddo
6657       call flush(iout)
6658       endif
6659       CorrelType=477
6660       CorrelID=fg_rank+1
6661       CorrelType1=478
6662       CorrelID1=nfgtasks+fg_rank+1
6663       ireq=0
6664 ! Receive the numbers of needed contacts from other processors
6665       do ii=1,ntask_cont_from
6666         iproc=itask_cont_from(ii)
6667         ireq=ireq+1
6668         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6669           FG_COMM,req(ireq),IERR)
6670       enddo
6671 !      write (iout,*) "IRECV ended"
6672 !      call flush(iout)
6673 ! Send the number of contacts needed by other processors
6674       do ii=1,ntask_cont_to
6675         iproc=itask_cont_to(ii)
6676         ireq=ireq+1
6677         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6678           FG_COMM,req(ireq),IERR)
6679       enddo
6680 !      write (iout,*) "ISEND ended"
6681 !      write (iout,*) "number of requests (nn)",ireq
6682       call flush(iout)
6683       if (ireq.gt.0) &
6684         call MPI_Waitall(ireq,req,status_array,ierr)
6685 !      write (iout,*)
6686 !     &  "Numbers of contacts to be received from other processors",
6687 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6688 !      call flush(iout)
6689 ! Receive contacts
6690       ireq=0
6691       do ii=1,ntask_cont_from
6692         iproc=itask_cont_from(ii)
6693         nn=ncont_recv(ii)
6694 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6695 !     &   " of CONT_TO_COMM group"
6696         call flush(iout)
6697         if (nn.gt.0) then
6698           ireq=ireq+1
6699           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6700           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6701 !          write (iout,*) "ireq,req",ireq,req(ireq)
6702         endif
6703       enddo
6704 ! Send the contacts to processors that need them
6705       do ii=1,ntask_cont_to
6706         iproc=itask_cont_to(ii)
6707         nn=ncont_sent(ii)
6708 !        write (iout,*) nn," contacts to processor",iproc,
6709 !     &   " of CONT_TO_COMM group"
6710         if (nn.gt.0) then
6711           ireq=ireq+1
6712           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6713             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6714 !          write (iout,*) "ireq,req",ireq,req(ireq)
6715 !          do i=1,nn
6716 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6717 !          enddo
6718         endif
6719       enddo
6720 !      write (iout,*) "number of requests (contacts)",ireq
6721 !      write (iout,*) "req",(req(i),i=1,4)
6722 !      call flush(iout)
6723       if (ireq.gt.0) &
6724        call MPI_Waitall(ireq,req,status_array,ierr)
6725       do iii=1,ntask_cont_from
6726         iproc=itask_cont_from(iii)
6727         nn=ncont_recv(iii)
6728         if (lprn) then
6729         write (iout,*) "Received",nn," contacts from processor",iproc,&
6730          " of CONT_FROM_COMM group"
6731         call flush(iout)
6732         do i=1,nn
6733           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6734         enddo
6735         call flush(iout)
6736         endif
6737         do i=1,nn
6738           ii=zapas_recv(1,i,iii)
6739 ! Flag the received contacts to prevent double-counting
6740           jj=-zapas_recv(2,i,iii)
6741 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6742 !          call flush(iout)
6743           nnn=num_cont_hb(ii)+1
6744           num_cont_hb(ii)=nnn
6745           jcont_hb(nnn,ii)=jj
6746           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6747           ind=3
6748           do kk=1,3
6749             ind=ind+1
6750             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6751           enddo
6752           do kk=1,2
6753             do ll=1,2
6754               ind=ind+1
6755               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6756             enddo
6757           enddo
6758           do jj=1,5
6759             do kk=1,3
6760               do ll=1,2
6761                 do mm=1,2
6762                   ind=ind+1
6763                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6764                 enddo
6765               enddo
6766             enddo
6767           enddo
6768         enddo
6769       enddo
6770       call flush(iout)
6771       if (lprn) then
6772         write (iout,'(a)') 'Contact function values after receive:'
6773         do i=nnt,nct-2
6774           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6775           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6776           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6777         enddo
6778         call flush(iout)
6779       endif
6780    30 continue
6781 #endif
6782       if (lprn) then
6783         write (iout,'(a)') 'Contact function values:'
6784         do i=nnt,nct-2
6785           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6786           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6787           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6788         enddo
6789       endif
6790       ecorr=0.0D0
6791       ecorr5=0.0d0
6792       ecorr6=0.0d0
6793
6794 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6795 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6796 ! Remove the loop below after debugging !!!
6797       do i=nnt,nct
6798         do j=1,3
6799           gradcorr(j,i)=0.0D0
6800           gradxorr(j,i)=0.0D0
6801         enddo
6802       enddo
6803 ! Calculate the dipole-dipole interaction energies
6804       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6805       do i=iatel_s,iatel_e+1
6806         num_conti=num_cont_hb(i)
6807         do jj=1,num_conti
6808           j=jcont_hb(jj,i)
6809 #ifdef MOMENT
6810           call dipole(i,j,jj)
6811 #endif
6812         enddo
6813       enddo
6814       endif
6815 ! Calculate the local-electrostatic correlation terms
6816 !                write (iout,*) "gradcorr5 in eello5 before loop"
6817 !                do iii=1,nres
6818 !                  write (iout,'(i5,3f10.5)')
6819 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6820 !                enddo
6821       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6822 !        write (iout,*) "corr loop i",i
6823         i1=i+1
6824         num_conti=num_cont_hb(i)
6825         num_conti1=num_cont_hb(i+1)
6826         do jj=1,num_conti
6827           j=jcont_hb(jj,i)
6828           jp=iabs(j)
6829           do kk=1,num_conti1
6830             j1=jcont_hb(kk,i1)
6831             jp1=iabs(j1)
6832 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6833 !     &         ' jj=',jj,' kk=',kk
6834 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6835             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6836                 .or. j.lt.0 .and. j1.gt.0) .and. &
6837                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6838 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6839 ! The system gains extra energy.
6840               n_corr=n_corr+1
6841               sqd1=dsqrt(d_cont(jj,i))
6842               sqd2=dsqrt(d_cont(kk,i1))
6843               sred_geom = sqd1*sqd2
6844               IF (sred_geom.lt.cutoff_corr) THEN
6845                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6846                   ekont,fprimcont)
6847 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6848 !d     &         ' jj=',jj,' kk=',kk
6849                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6850                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6851                 do l=1,3
6852                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6853                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6854                 enddo
6855                 n_corr1=n_corr1+1
6856 !d               write (iout,*) 'sred_geom=',sred_geom,
6857 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6858 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6859 !d               write (iout,*) "g_contij",g_contij
6860 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6861 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6862                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6863                 if (wcorr4.gt.0.0d0) &
6864                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6865                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6866                        write (iout,'(a6,4i5,0pf7.3)') &
6867                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6868 !                write (iout,*) "gradcorr5 before eello5"
6869 !                do iii=1,nres
6870 !                  write (iout,'(i5,3f10.5)')
6871 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6872 !                enddo
6873                 if (wcorr5.gt.0.0d0) &
6874                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6875 !                write (iout,*) "gradcorr5 after eello5"
6876 !                do iii=1,nres
6877 !                  write (iout,'(i5,3f10.5)')
6878 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6879 !                enddo
6880                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6881                        write (iout,'(a6,4i5,0pf7.3)') &
6882                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6883 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6884 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6885                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6886                      .or. wturn6.eq.0.0d0))then
6887 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6888                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6889                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6890                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6891 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6892 !d     &            'ecorr6=',ecorr6
6893 !d                write (iout,'(4e15.5)') sred_geom,
6894 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6895 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6896 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6897                 else if (wturn6.gt.0.0d0 &
6898                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6899 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6900                   eturn6=eturn6+eello_turn6(i,jj,kk)
6901                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6902                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6903 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6904                 endif
6905               ENDIF
6906 1111          continue
6907             endif
6908           enddo ! kk
6909         enddo ! jj
6910       enddo ! i
6911       do i=1,nres
6912         num_cont_hb(i)=num_cont_hb_old(i)
6913       enddo
6914 !                write (iout,*) "gradcorr5 in eello5"
6915 !                do iii=1,nres
6916 !                  write (iout,'(i5,3f10.5)')
6917 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6918 !                enddo
6919       return
6920       end subroutine multibody_eello
6921 !-----------------------------------------------------------------------------
6922       subroutine add_hb_contact_eello(ii,jj,itask)
6923 !      implicit real*8 (a-h,o-z)
6924 !      include "DIMENSIONS"
6925 !      include "COMMON.IOUNITS"
6926 !      include "COMMON.CONTACTS"
6927 !      integer,parameter :: maxconts=nres/4
6928       integer,parameter :: max_dim=70
6929       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6930 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6931 !      common /przechowalnia/ zapas
6932
6933       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6934       integer,dimension(4) ::itask
6935 !      write (iout,*) "itask",itask
6936       do i=1,2
6937         iproc=itask(i)
6938         if (iproc.gt.0) then
6939           do j=1,num_cont_hb(ii)
6940             jjc=jcont_hb(j,ii)
6941 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6942             if (jjc.eq.jj) then
6943               ncont_sent(iproc)=ncont_sent(iproc)+1
6944               nn=ncont_sent(iproc)
6945               zapas(1,nn,iproc)=ii
6946               zapas(2,nn,iproc)=jjc
6947               zapas(3,nn,iproc)=d_cont(j,ii)
6948               ind=3
6949               do kk=1,3
6950                 ind=ind+1
6951                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6952               enddo
6953               do kk=1,2
6954                 do ll=1,2
6955                   ind=ind+1
6956                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6957                 enddo
6958               enddo
6959               do jj=1,5
6960                 do kk=1,3
6961                   do ll=1,2
6962                     do mm=1,2
6963                       ind=ind+1
6964                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6965                     enddo
6966                   enddo
6967                 enddo
6968               enddo
6969               exit
6970             endif
6971           enddo
6972         endif
6973       enddo
6974       return
6975       end subroutine add_hb_contact_eello
6976 !-----------------------------------------------------------------------------
6977       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6978 !      implicit real*8 (a-h,o-z)
6979 !      include 'DIMENSIONS'
6980 !      include 'COMMON.IOUNITS'
6981 !      include 'COMMON.DERIV'
6982 !      include 'COMMON.INTERACT'
6983 !      include 'COMMON.CONTACTS'
6984       real(kind=8),dimension(3) :: gx,gx1
6985       logical :: lprn
6986 !el local variables
6987       integer :: i,j,k,l,jj,kk,ll
6988       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6989                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6990                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6991
6992       lprn=.false.
6993       eij=facont_hb(jj,i)
6994       ekl=facont_hb(kk,k)
6995       ees0pij=ees0p(jj,i)
6996       ees0pkl=ees0p(kk,k)
6997       ees0mij=ees0m(jj,i)
6998       ees0mkl=ees0m(kk,k)
6999       ekont=eij*ekl
7000       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7001 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7002 ! Following 4 lines for diagnostics.
7003 !d    ees0pkl=0.0D0
7004 !d    ees0pij=1.0D0
7005 !d    ees0mkl=0.0D0
7006 !d    ees0mij=1.0D0
7007 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7008 !     & 'Contacts ',i,j,
7009 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7010 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7011 !     & 'gradcorr_long'
7012 ! Calculate the multi-body contribution to energy.
7013 !      ecorr=ecorr+ekont*ees
7014 ! Calculate multi-body contributions to the gradient.
7015       coeffpees0pij=coeffp*ees0pij
7016       coeffmees0mij=coeffm*ees0mij
7017       coeffpees0pkl=coeffp*ees0pkl
7018       coeffmees0mkl=coeffm*ees0mkl
7019       do ll=1,3
7020 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7021         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7022         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7023         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7024         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7025         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7026         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7027 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7028         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7029         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7030         coeffmees0mij*gacontm_hb1(ll,kk,k))
7031         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7032         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7033         coeffmees0mij*gacontm_hb2(ll,kk,k))
7034         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7035            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7036            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7037         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7038         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7039         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7040            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7041            coeffmees0mij*gacontm_hb3(ll,kk,k))
7042         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7043         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7044 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7045       enddo
7046 !      write (iout,*)
7047 !grad      do m=i+1,j-1
7048 !grad        do ll=1,3
7049 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7050 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7051 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7052 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7053 !grad        enddo
7054 !grad      enddo
7055 !grad      do m=k+1,l-1
7056 !grad        do ll=1,3
7057 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7058 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7059 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7060 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7061 !grad        enddo
7062 !grad      enddo
7063 !      write (iout,*) "ehbcorr",ekont*ees
7064       ehbcorr=ekont*ees
7065       return
7066       end function ehbcorr
7067 #ifdef MOMENT
7068 !-----------------------------------------------------------------------------
7069       subroutine dipole(i,j,jj)
7070 !      implicit real*8 (a-h,o-z)
7071 !      include 'DIMENSIONS'
7072 !      include 'COMMON.IOUNITS'
7073 !      include 'COMMON.CHAIN'
7074 !      include 'COMMON.FFIELD'
7075 !      include 'COMMON.DERIV'
7076 !      include 'COMMON.INTERACT'
7077 !      include 'COMMON.CONTACTS'
7078 !      include 'COMMON.TORSION'
7079 !      include 'COMMON.VAR'
7080 !      include 'COMMON.GEO'
7081       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7082       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7083       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7084
7085       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7086       allocate(dipderx(3,5,4,maxconts,nres))
7087 !
7088
7089       iti1 = itortyp(itype(i+1))
7090       if (j.lt.nres-1) then
7091         itj1 = itortyp(itype(j+1))
7092       else
7093         itj1=ntortyp+1
7094       endif
7095       do iii=1,2
7096         dipi(iii,1)=Ub2(iii,i)
7097         dipderi(iii)=Ub2der(iii,i)
7098         dipi(iii,2)=b1(iii,iti1)
7099         dipj(iii,1)=Ub2(iii,j)
7100         dipderj(iii)=Ub2der(iii,j)
7101         dipj(iii,2)=b1(iii,itj1)
7102       enddo
7103       kkk=0
7104       do iii=1,2
7105         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7106         do jjj=1,2
7107           kkk=kkk+1
7108           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7109         enddo
7110       enddo
7111       do kkk=1,5
7112         do lll=1,3
7113           mmm=0
7114           do iii=1,2
7115             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7116               auxvec(1))
7117             do jjj=1,2
7118               mmm=mmm+1
7119               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7120             enddo
7121           enddo
7122         enddo
7123       enddo
7124       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7125       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7126       do iii=1,2
7127         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7128       enddo
7129       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7130       do iii=1,2
7131         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7132       enddo
7133       return
7134       end subroutine dipole
7135 #endif
7136 !-----------------------------------------------------------------------------
7137       subroutine calc_eello(i,j,k,l,jj,kk)
7138 !
7139 ! This subroutine computes matrices and vectors needed to calculate
7140 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7141 !
7142       use comm_kut
7143 !      implicit real*8 (a-h,o-z)
7144 !      include 'DIMENSIONS'
7145 !      include 'COMMON.IOUNITS'
7146 !      include 'COMMON.CHAIN'
7147 !      include 'COMMON.DERIV'
7148 !      include 'COMMON.INTERACT'
7149 !      include 'COMMON.CONTACTS'
7150 !      include 'COMMON.TORSION'
7151 !      include 'COMMON.VAR'
7152 !      include 'COMMON.GEO'
7153 !      include 'COMMON.FFIELD'
7154       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7155       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7156       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7157               itj1
7158 !el      logical :: lprn
7159 !el      common /kutas/ lprn
7160 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7161 !d     & ' jj=',jj,' kk=',kk
7162 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7163 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7164 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7165       do iii=1,2
7166         do jjj=1,2
7167           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7168           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7169         enddo
7170       enddo
7171       call transpose2(aa1(1,1),aa1t(1,1))
7172       call transpose2(aa2(1,1),aa2t(1,1))
7173       do kkk=1,5
7174         do lll=1,3
7175           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7176             aa1tder(1,1,lll,kkk))
7177           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7178             aa2tder(1,1,lll,kkk))
7179         enddo
7180       enddo
7181       if (l.eq.j+1) then
7182 ! parallel orientation of the two CA-CA-CA frames.
7183         if (i.gt.1) then
7184           iti=itortyp(itype(i))
7185         else
7186           iti=ntortyp+1
7187         endif
7188         itk1=itortyp(itype(k+1))
7189         itj=itortyp(itype(j))
7190         if (l.lt.nres-1) then
7191           itl1=itortyp(itype(l+1))
7192         else
7193           itl1=ntortyp+1
7194         endif
7195 ! A1 kernel(j+1) A2T
7196 !d        do iii=1,2
7197 !d          write (iout,'(3f10.5,5x,3f10.5)')
7198 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7199 !d        enddo
7200         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7201          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7202          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7203 ! Following matrices are needed only for 6-th order cumulants
7204         IF (wcorr6.gt.0.0d0) THEN
7205         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7206          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7207          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7208         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7209          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7210          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7211          ADtEAderx(1,1,1,1,1,1))
7212         lprn=.false.
7213         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7214          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7215          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7216          ADtEA1derx(1,1,1,1,1,1))
7217         ENDIF
7218 ! End 6-th order cumulants
7219 !d        lprn=.false.
7220 !d        if (lprn) then
7221 !d        write (2,*) 'In calc_eello6'
7222 !d        do iii=1,2
7223 !d          write (2,*) 'iii=',iii
7224 !d          do kkk=1,5
7225 !d            write (2,*) 'kkk=',kkk
7226 !d            do jjj=1,2
7227 !d              write (2,'(3(2f10.5),5x)')
7228 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7229 !d            enddo
7230 !d          enddo
7231 !d        enddo
7232 !d        endif
7233         call transpose2(EUgder(1,1,k),auxmat(1,1))
7234         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7235         call transpose2(EUg(1,1,k),auxmat(1,1))
7236         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7237         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7238         do iii=1,2
7239           do kkk=1,5
7240             do lll=1,3
7241               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7242                 EAEAderx(1,1,lll,kkk,iii,1))
7243             enddo
7244           enddo
7245         enddo
7246 ! A1T kernel(i+1) A2
7247         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7248          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7249          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7250 ! Following matrices are needed only for 6-th order cumulants
7251         IF (wcorr6.gt.0.0d0) THEN
7252         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7253          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7254          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7255         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7256          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7257          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7258          ADtEAderx(1,1,1,1,1,2))
7259         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7260          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7261          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7262          ADtEA1derx(1,1,1,1,1,2))
7263         ENDIF
7264 ! End 6-th order cumulants
7265         call transpose2(EUgder(1,1,l),auxmat(1,1))
7266         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7267         call transpose2(EUg(1,1,l),auxmat(1,1))
7268         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7269         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7270         do iii=1,2
7271           do kkk=1,5
7272             do lll=1,3
7273               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7274                 EAEAderx(1,1,lll,kkk,iii,2))
7275             enddo
7276           enddo
7277         enddo
7278 ! AEAb1 and AEAb2
7279 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7280 ! They are needed only when the fifth- or the sixth-order cumulants are
7281 ! indluded.
7282         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7283         call transpose2(AEA(1,1,1),auxmat(1,1))
7284         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7285         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7286         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7287         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7288         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7289         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7290         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7291         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7292         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7293         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7294         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7295         call transpose2(AEA(1,1,2),auxmat(1,1))
7296         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7297         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7298         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7299         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7300         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7301         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7302         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7303         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7304         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7305         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7306         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7307 ! Calculate the Cartesian derivatives of the vectors.
7308         do iii=1,2
7309           do kkk=1,5
7310             do lll=1,3
7311               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7312               call matvec2(auxmat(1,1),b1(1,iti),&
7313                 AEAb1derx(1,lll,kkk,iii,1,1))
7314               call matvec2(auxmat(1,1),Ub2(1,i),&
7315                 AEAb2derx(1,lll,kkk,iii,1,1))
7316               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7317                 AEAb1derx(1,lll,kkk,iii,2,1))
7318               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7319                 AEAb2derx(1,lll,kkk,iii,2,1))
7320               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7321               call matvec2(auxmat(1,1),b1(1,itj),&
7322                 AEAb1derx(1,lll,kkk,iii,1,2))
7323               call matvec2(auxmat(1,1),Ub2(1,j),&
7324                 AEAb2derx(1,lll,kkk,iii,1,2))
7325               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7326                 AEAb1derx(1,lll,kkk,iii,2,2))
7327               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7328                 AEAb2derx(1,lll,kkk,iii,2,2))
7329             enddo
7330           enddo
7331         enddo
7332         ENDIF
7333 ! End vectors
7334       else
7335 ! Antiparallel orientation of the two CA-CA-CA frames.
7336         if (i.gt.1) then
7337           iti=itortyp(itype(i))
7338         else
7339           iti=ntortyp+1
7340         endif
7341         itk1=itortyp(itype(k+1))
7342         itl=itortyp(itype(l))
7343         itj=itortyp(itype(j))
7344         if (j.lt.nres-1) then
7345           itj1=itortyp(itype(j+1))
7346         else
7347           itj1=ntortyp+1
7348         endif
7349 ! A2 kernel(j-1)T A1T
7350         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7351          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7352          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7353 ! Following matrices are needed only for 6-th order cumulants
7354         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7355            j.eq.i+4 .and. l.eq.i+3)) THEN
7356         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7357          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7358          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7359         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7360          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7361          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7362          ADtEAderx(1,1,1,1,1,1))
7363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7364          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7365          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7366          ADtEA1derx(1,1,1,1,1,1))
7367         ENDIF
7368 ! End 6-th order cumulants
7369         call transpose2(EUgder(1,1,k),auxmat(1,1))
7370         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7371         call transpose2(EUg(1,1,k),auxmat(1,1))
7372         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7373         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7374         do iii=1,2
7375           do kkk=1,5
7376             do lll=1,3
7377               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7378                 EAEAderx(1,1,lll,kkk,iii,1))
7379             enddo
7380           enddo
7381         enddo
7382 ! A2T kernel(i+1)T A1
7383         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7384          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7385          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7386 ! Following matrices are needed only for 6-th order cumulants
7387         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7388            j.eq.i+4 .and. l.eq.i+3)) THEN
7389         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7390          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7391          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7392         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7393          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7394          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7395          ADtEAderx(1,1,1,1,1,2))
7396         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7397          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7398          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7399          ADtEA1derx(1,1,1,1,1,2))
7400         ENDIF
7401 ! End 6-th order cumulants
7402         call transpose2(EUgder(1,1,j),auxmat(1,1))
7403         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7404         call transpose2(EUg(1,1,j),auxmat(1,1))
7405         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7406         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7407         do iii=1,2
7408           do kkk=1,5
7409             do lll=1,3
7410               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7411                 EAEAderx(1,1,lll,kkk,iii,2))
7412             enddo
7413           enddo
7414         enddo
7415 ! AEAb1 and AEAb2
7416 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7417 ! They are needed only when the fifth- or the sixth-order cumulants are
7418 ! indluded.
7419         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7420           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7421         call transpose2(AEA(1,1,1),auxmat(1,1))
7422         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7423         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7424         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7425         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7426         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7427         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7428         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7429         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7430         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7431         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7432         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7433         call transpose2(AEA(1,1,2),auxmat(1,1))
7434         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7435         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7436         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7437         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7438         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7439         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7440         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7441         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7442         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7443         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7444         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7445 ! Calculate the Cartesian derivatives of the vectors.
7446         do iii=1,2
7447           do kkk=1,5
7448             do lll=1,3
7449               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7450               call matvec2(auxmat(1,1),b1(1,iti),&
7451                 AEAb1derx(1,lll,kkk,iii,1,1))
7452               call matvec2(auxmat(1,1),Ub2(1,i),&
7453                 AEAb2derx(1,lll,kkk,iii,1,1))
7454               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7455                 AEAb1derx(1,lll,kkk,iii,2,1))
7456               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7457                 AEAb2derx(1,lll,kkk,iii,2,1))
7458               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7459               call matvec2(auxmat(1,1),b1(1,itl),&
7460                 AEAb1derx(1,lll,kkk,iii,1,2))
7461               call matvec2(auxmat(1,1),Ub2(1,l),&
7462                 AEAb2derx(1,lll,kkk,iii,1,2))
7463               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7464                 AEAb1derx(1,lll,kkk,iii,2,2))
7465               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7466                 AEAb2derx(1,lll,kkk,iii,2,2))
7467             enddo
7468           enddo
7469         enddo
7470         ENDIF
7471 ! End vectors
7472       endif
7473       return
7474       end subroutine calc_eello
7475 !-----------------------------------------------------------------------------
7476       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7477       use comm_kut
7478       implicit none
7479       integer :: nderg
7480       logical :: transp
7481       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7482       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7483       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7484       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7485       integer :: iii,kkk,lll
7486       integer :: jjj,mmm
7487 !el      logical :: lprn
7488 !el      common /kutas/ lprn
7489       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7490       do iii=1,nderg
7491         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7492           AKAderg(1,1,iii))
7493       enddo
7494 !d      if (lprn) write (2,*) 'In kernel'
7495       do kkk=1,5
7496 !d        if (lprn) write (2,*) 'kkk=',kkk
7497         do lll=1,3
7498           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7499             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7500 !d          if (lprn) then
7501 !d            write (2,*) 'lll=',lll
7502 !d            write (2,*) 'iii=1'
7503 !d            do jjj=1,2
7504 !d              write (2,'(3(2f10.5),5x)')
7505 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7506 !d            enddo
7507 !d          endif
7508           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7509             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7510 !d          if (lprn) then
7511 !d            write (2,*) 'lll=',lll
7512 !d            write (2,*) 'iii=2'
7513 !d            do jjj=1,2
7514 !d              write (2,'(3(2f10.5),5x)')
7515 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7516 !d            enddo
7517 !d          endif
7518         enddo
7519       enddo
7520       return
7521       end subroutine kernel
7522 !-----------------------------------------------------------------------------
7523       real(kind=8) function eello4(i,j,k,l,jj,kk)
7524 !      implicit real*8 (a-h,o-z)
7525 !      include 'DIMENSIONS'
7526 !      include 'COMMON.IOUNITS'
7527 !      include 'COMMON.CHAIN'
7528 !      include 'COMMON.DERIV'
7529 !      include 'COMMON.INTERACT'
7530 !      include 'COMMON.CONTACTS'
7531 !      include 'COMMON.TORSION'
7532 !      include 'COMMON.VAR'
7533 !      include 'COMMON.GEO'
7534       real(kind=8),dimension(2,2) :: pizda
7535       real(kind=8),dimension(3) :: ggg1,ggg2
7536       real(kind=8) ::  eel4,glongij,glongkl
7537       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7538 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7539 !d        eello4=0.0d0
7540 !d        return
7541 !d      endif
7542 !d      print *,'eello4:',i,j,k,l,jj,kk
7543 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7544 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7545 !old      eij=facont_hb(jj,i)
7546 !old      ekl=facont_hb(kk,k)
7547 !old      ekont=eij*ekl
7548       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7549 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7550       gcorr_loc(k-1)=gcorr_loc(k-1) &
7551          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7552       if (l.eq.j+1) then
7553         gcorr_loc(l-1)=gcorr_loc(l-1) &
7554            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7555       else
7556         gcorr_loc(j-1)=gcorr_loc(j-1) &
7557            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7558       endif
7559       do iii=1,2
7560         do kkk=1,5
7561           do lll=1,3
7562             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7563                               -EAEAderx(2,2,lll,kkk,iii,1)
7564 !d            derx(lll,kkk,iii)=0.0d0
7565           enddo
7566         enddo
7567       enddo
7568 !d      gcorr_loc(l-1)=0.0d0
7569 !d      gcorr_loc(j-1)=0.0d0
7570 !d      gcorr_loc(k-1)=0.0d0
7571 !d      eel4=1.0d0
7572 !d      write (iout,*)'Contacts have occurred for peptide groups',
7573 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7574 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7575       if (j.lt.nres-1) then
7576         j1=j+1
7577         j2=j-1
7578       else
7579         j1=j-1
7580         j2=j-2
7581       endif
7582       if (l.lt.nres-1) then
7583         l1=l+1
7584         l2=l-1
7585       else
7586         l1=l-1
7587         l2=l-2
7588       endif
7589       do ll=1,3
7590 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7591 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7592         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7593         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7594 !grad        ghalf=0.5d0*ggg1(ll)
7595         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7596         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7597         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7598         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7599         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7600         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7601 !grad        ghalf=0.5d0*ggg2(ll)
7602         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7603         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7604         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7605         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7606         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7607         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7608       enddo
7609 !grad      do m=i+1,j-1
7610 !grad        do ll=1,3
7611 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7612 !grad        enddo
7613 !grad      enddo
7614 !grad      do m=k+1,l-1
7615 !grad        do ll=1,3
7616 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7617 !grad        enddo
7618 !grad      enddo
7619 !grad      do m=i+2,j2
7620 !grad        do ll=1,3
7621 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7622 !grad        enddo
7623 !grad      enddo
7624 !grad      do m=k+2,l2
7625 !grad        do ll=1,3
7626 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7627 !grad        enddo
7628 !grad      enddo
7629 !d      do iii=1,nres-3
7630 !d        write (2,*) iii,gcorr_loc(iii)
7631 !d      enddo
7632       eello4=ekont*eel4
7633 !d      write (2,*) 'ekont',ekont
7634 !d      write (iout,*) 'eello4',ekont*eel4
7635       return
7636       end function eello4
7637 !-----------------------------------------------------------------------------
7638       real(kind=8) function eello5(i,j,k,l,jj,kk)
7639 !      implicit real*8 (a-h,o-z)
7640 !      include 'DIMENSIONS'
7641 !      include 'COMMON.IOUNITS'
7642 !      include 'COMMON.CHAIN'
7643 !      include 'COMMON.DERIV'
7644 !      include 'COMMON.INTERACT'
7645 !      include 'COMMON.CONTACTS'
7646 !      include 'COMMON.TORSION'
7647 !      include 'COMMON.VAR'
7648 !      include 'COMMON.GEO'
7649       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7650       real(kind=8),dimension(2) :: vv
7651       real(kind=8),dimension(3) :: ggg1,ggg2
7652       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7653       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7654       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7655 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7656 !                                                                              C
7657 !                            Parallel chains                                   C
7658 !                                                                              C
7659 !          o             o                   o             o                   C
7660 !         /l\           / \             \   / \           / \   /              C
7661 !        /   \         /   \             \ /   \         /   \ /               C
7662 !       j| o |l1       | o |              o| o |         | o |o                C
7663 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7664 !      \i/   \         /   \ /             /   \         /   \                 C
7665 !       o    k1             o                                                  C
7666 !         (I)          (II)                (III)          (IV)                 C
7667 !                                                                              C
7668 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7669 !                                                                              C
7670 !                            Antiparallel chains                               C
7671 !                                                                              C
7672 !          o             o                   o             o                   C
7673 !         /j\           / \             \   / \           / \   /              C
7674 !        /   \         /   \             \ /   \         /   \ /               C
7675 !      j1| o |l        | o |              o| o |         | o |o                C
7676 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7677 !      \i/   \         /   \ /             /   \         /   \                 C
7678 !       o     k1            o                                                  C
7679 !         (I)          (II)                (III)          (IV)                 C
7680 !                                                                              C
7681 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7682 !                                                                              C
7683 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7684 !                                                                              C
7685 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7686 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7687 !d        eello5=0.0d0
7688 !d        return
7689 !d      endif
7690 !d      write (iout,*)
7691 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7692 !d     &   ' and',k,l
7693       itk=itortyp(itype(k))
7694       itl=itortyp(itype(l))
7695       itj=itortyp(itype(j))
7696       eello5_1=0.0d0
7697       eello5_2=0.0d0
7698       eello5_3=0.0d0
7699       eello5_4=0.0d0
7700 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7701 !d     &   eel5_3_num,eel5_4_num)
7702       do iii=1,2
7703         do kkk=1,5
7704           do lll=1,3
7705             derx(lll,kkk,iii)=0.0d0
7706           enddo
7707         enddo
7708       enddo
7709 !d      eij=facont_hb(jj,i)
7710 !d      ekl=facont_hb(kk,k)
7711 !d      ekont=eij*ekl
7712 !d      write (iout,*)'Contacts have occurred for peptide groups',
7713 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7714 !d      goto 1111
7715 ! Contribution from the graph I.
7716 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7717 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7718       call transpose2(EUg(1,1,k),auxmat(1,1))
7719       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7720       vv(1)=pizda(1,1)-pizda(2,2)
7721       vv(2)=pizda(1,2)+pizda(2,1)
7722       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7723        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7724 ! Explicit gradient in virtual-dihedral angles.
7725       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7726        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7727        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7728       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7729       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7730       vv(1)=pizda(1,1)-pizda(2,2)
7731       vv(2)=pizda(1,2)+pizda(2,1)
7732       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7733        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7734        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7735       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7736       vv(1)=pizda(1,1)-pizda(2,2)
7737       vv(2)=pizda(1,2)+pizda(2,1)
7738       if (l.eq.j+1) then
7739         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7740          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7741          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7742       else
7743         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7744          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7745          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7746       endif
7747 ! Cartesian gradient
7748       do iii=1,2
7749         do kkk=1,5
7750           do lll=1,3
7751             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7752               pizda(1,1))
7753             vv(1)=pizda(1,1)-pizda(2,2)
7754             vv(2)=pizda(1,2)+pizda(2,1)
7755             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7756              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7757              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7758           enddo
7759         enddo
7760       enddo
7761 !      goto 1112
7762 !1111  continue
7763 ! Contribution from graph II
7764       call transpose2(EE(1,1,itk),auxmat(1,1))
7765       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7766       vv(1)=pizda(1,1)+pizda(2,2)
7767       vv(2)=pizda(2,1)-pizda(1,2)
7768       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7769        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7770 ! Explicit gradient in virtual-dihedral angles.
7771       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7772        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7773       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7774       vv(1)=pizda(1,1)+pizda(2,2)
7775       vv(2)=pizda(2,1)-pizda(1,2)
7776       if (l.eq.j+1) then
7777         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7778          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7779          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7780       else
7781         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7782          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7783          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7784       endif
7785 ! Cartesian gradient
7786       do iii=1,2
7787         do kkk=1,5
7788           do lll=1,3
7789             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7790               pizda(1,1))
7791             vv(1)=pizda(1,1)+pizda(2,2)
7792             vv(2)=pizda(2,1)-pizda(1,2)
7793             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7794              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7795              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7796           enddo
7797         enddo
7798       enddo
7799 !d      goto 1112
7800 !d1111  continue
7801       if (l.eq.j+1) then
7802 !d        goto 1110
7803 ! Parallel orientation
7804 ! Contribution from graph III
7805         call transpose2(EUg(1,1,l),auxmat(1,1))
7806         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7807         vv(1)=pizda(1,1)-pizda(2,2)
7808         vv(2)=pizda(1,2)+pizda(2,1)
7809         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7810          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7811 ! Explicit gradient in virtual-dihedral angles.
7812         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7813          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7814          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7815         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7816         vv(1)=pizda(1,1)-pizda(2,2)
7817         vv(2)=pizda(1,2)+pizda(2,1)
7818         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7819          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7820          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7821         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7822         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7823         vv(1)=pizda(1,1)-pizda(2,2)
7824         vv(2)=pizda(1,2)+pizda(2,1)
7825         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7826          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7827          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7828 ! Cartesian gradient
7829         do iii=1,2
7830           do kkk=1,5
7831             do lll=1,3
7832               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7833                 pizda(1,1))
7834               vv(1)=pizda(1,1)-pizda(2,2)
7835               vv(2)=pizda(1,2)+pizda(2,1)
7836               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7837                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7838                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7839             enddo
7840           enddo
7841         enddo
7842 !d        goto 1112
7843 ! Contribution from graph IV
7844 !d1110    continue
7845         call transpose2(EE(1,1,itl),auxmat(1,1))
7846         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7847         vv(1)=pizda(1,1)+pizda(2,2)
7848         vv(2)=pizda(2,1)-pizda(1,2)
7849         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7850          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7851 ! Explicit gradient in virtual-dihedral angles.
7852         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7853          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7854         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7855         vv(1)=pizda(1,1)+pizda(2,2)
7856         vv(2)=pizda(2,1)-pizda(1,2)
7857         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7858          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7859          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7860 ! Cartesian gradient
7861         do iii=1,2
7862           do kkk=1,5
7863             do lll=1,3
7864               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7865                 pizda(1,1))
7866               vv(1)=pizda(1,1)+pizda(2,2)
7867               vv(2)=pizda(2,1)-pizda(1,2)
7868               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7869                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7870                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7871             enddo
7872           enddo
7873         enddo
7874       else
7875 ! Antiparallel orientation
7876 ! Contribution from graph III
7877 !        goto 1110
7878         call transpose2(EUg(1,1,j),auxmat(1,1))
7879         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7880         vv(1)=pizda(1,1)-pizda(2,2)
7881         vv(2)=pizda(1,2)+pizda(2,1)
7882         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7883          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7884 ! Explicit gradient in virtual-dihedral angles.
7885         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7886          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7887          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7888         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7889         vv(1)=pizda(1,1)-pizda(2,2)
7890         vv(2)=pizda(1,2)+pizda(2,1)
7891         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7892          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7893          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7894         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7895         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7896         vv(1)=pizda(1,1)-pizda(2,2)
7897         vv(2)=pizda(1,2)+pizda(2,1)
7898         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7899          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7900          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7901 ! Cartesian gradient
7902         do iii=1,2
7903           do kkk=1,5
7904             do lll=1,3
7905               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7906                 pizda(1,1))
7907               vv(1)=pizda(1,1)-pizda(2,2)
7908               vv(2)=pizda(1,2)+pizda(2,1)
7909               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7910                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7911                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7912             enddo
7913           enddo
7914         enddo
7915 !d        goto 1112
7916 ! Contribution from graph IV
7917 1110    continue
7918         call transpose2(EE(1,1,itj),auxmat(1,1))
7919         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7920         vv(1)=pizda(1,1)+pizda(2,2)
7921         vv(2)=pizda(2,1)-pizda(1,2)
7922         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7923          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7924 ! Explicit gradient in virtual-dihedral angles.
7925         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7926          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7927         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7928         vv(1)=pizda(1,1)+pizda(2,2)
7929         vv(2)=pizda(2,1)-pizda(1,2)
7930         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7931          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7932          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7933 ! Cartesian gradient
7934         do iii=1,2
7935           do kkk=1,5
7936             do lll=1,3
7937               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7938                 pizda(1,1))
7939               vv(1)=pizda(1,1)+pizda(2,2)
7940               vv(2)=pizda(2,1)-pizda(1,2)
7941               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7942                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7943                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7944             enddo
7945           enddo
7946         enddo
7947       endif
7948 1112  continue
7949       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7950 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7951 !d        write (2,*) 'ijkl',i,j,k,l
7952 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7953 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7954 !d      endif
7955 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7956 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7957 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7958 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7959       if (j.lt.nres-1) then
7960         j1=j+1
7961         j2=j-1
7962       else
7963         j1=j-1
7964         j2=j-2
7965       endif
7966       if (l.lt.nres-1) then
7967         l1=l+1
7968         l2=l-1
7969       else
7970         l1=l-1
7971         l2=l-2
7972       endif
7973 !d      eij=1.0d0
7974 !d      ekl=1.0d0
7975 !d      ekont=1.0d0
7976 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7977 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7978 !        summed up outside the subrouine as for the other subroutines
7979 !        handling long-range interactions. The old code is commented out
7980 !        with "cgrad" to keep track of changes.
7981       do ll=1,3
7982 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7983 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7984         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7985         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7986 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7987 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7988 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7989 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7990 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7991 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7992 !     &   gradcorr5ij,
7993 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7994 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7995 !grad        ghalf=0.5d0*ggg1(ll)
7996 !d        ghalf=0.0d0
7997         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7998         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7999         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8000         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8001         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8002         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8003 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8004 !grad        ghalf=0.5d0*ggg2(ll)
8005         ghalf=0.0d0
8006         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8007         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8008         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8009         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8010         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8011         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8012       enddo
8013 !d      goto 1112
8014 !grad      do m=i+1,j-1
8015 !grad        do ll=1,3
8016 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8017 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8018 !grad        enddo
8019 !grad      enddo
8020 !grad      do m=k+1,l-1
8021 !grad        do ll=1,3
8022 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8023 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8024 !grad        enddo
8025 !grad      enddo
8026 !1112  continue
8027 !grad      do m=i+2,j2
8028 !grad        do ll=1,3
8029 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8030 !grad        enddo
8031 !grad      enddo
8032 !grad      do m=k+2,l2
8033 !grad        do ll=1,3
8034 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8035 !grad        enddo
8036 !grad      enddo
8037 !d      do iii=1,nres-3
8038 !d        write (2,*) iii,g_corr5_loc(iii)
8039 !d      enddo
8040       eello5=ekont*eel5
8041 !d      write (2,*) 'ekont',ekont
8042 !d      write (iout,*) 'eello5',ekont*eel5
8043       return
8044       end function eello5
8045 !-----------------------------------------------------------------------------
8046       real(kind=8) function eello6(i,j,k,l,jj,kk)
8047 !      implicit real*8 (a-h,o-z)
8048 !      include 'DIMENSIONS'
8049 !      include 'COMMON.IOUNITS'
8050 !      include 'COMMON.CHAIN'
8051 !      include 'COMMON.DERIV'
8052 !      include 'COMMON.INTERACT'
8053 !      include 'COMMON.CONTACTS'
8054 !      include 'COMMON.TORSION'
8055 !      include 'COMMON.VAR'
8056 !      include 'COMMON.GEO'
8057 !      include 'COMMON.FFIELD'
8058       real(kind=8),dimension(3) :: ggg1,ggg2
8059       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8060                    eello6_6,eel6
8061       real(kind=8) :: gradcorr6ij,gradcorr6kl
8062       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8063 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8064 !d        eello6=0.0d0
8065 !d        return
8066 !d      endif
8067 !d      write (iout,*)
8068 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8069 !d     &   ' and',k,l
8070       eello6_1=0.0d0
8071       eello6_2=0.0d0
8072       eello6_3=0.0d0
8073       eello6_4=0.0d0
8074       eello6_5=0.0d0
8075       eello6_6=0.0d0
8076 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8077 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8078       do iii=1,2
8079         do kkk=1,5
8080           do lll=1,3
8081             derx(lll,kkk,iii)=0.0d0
8082           enddo
8083         enddo
8084       enddo
8085 !d      eij=facont_hb(jj,i)
8086 !d      ekl=facont_hb(kk,k)
8087 !d      ekont=eij*ekl
8088 !d      eij=1.0d0
8089 !d      ekl=1.0d0
8090 !d      ekont=1.0d0
8091       if (l.eq.j+1) then
8092         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8093         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8094         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8095         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8096         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8097         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8098       else
8099         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8100         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8101         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8102         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8103         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8104           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8105         else
8106           eello6_5=0.0d0
8107         endif
8108         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8109       endif
8110 ! If turn contributions are considered, they will be handled separately.
8111       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8112 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8113 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8114 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8115 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8116 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8117 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8118 !d      goto 1112
8119       if (j.lt.nres-1) then
8120         j1=j+1
8121         j2=j-1
8122       else
8123         j1=j-1
8124         j2=j-2
8125       endif
8126       if (l.lt.nres-1) then
8127         l1=l+1
8128         l2=l-1
8129       else
8130         l1=l-1
8131         l2=l-2
8132       endif
8133       do ll=1,3
8134 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8135 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8136 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8137 !grad        ghalf=0.5d0*ggg1(ll)
8138 !d        ghalf=0.0d0
8139         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8140         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8141         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8142         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8143         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8144         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8145         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8146         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8147 !grad        ghalf=0.5d0*ggg2(ll)
8148 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8149 !d        ghalf=0.0d0
8150         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8151         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8152         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8153         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8154         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8155         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8156       enddo
8157 !d      goto 1112
8158 !grad      do m=i+1,j-1
8159 !grad        do ll=1,3
8160 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8161 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8162 !grad        enddo
8163 !grad      enddo
8164 !grad      do m=k+1,l-1
8165 !grad        do ll=1,3
8166 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8167 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8168 !grad        enddo
8169 !grad      enddo
8170 !grad1112  continue
8171 !grad      do m=i+2,j2
8172 !grad        do ll=1,3
8173 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8174 !grad        enddo
8175 !grad      enddo
8176 !grad      do m=k+2,l2
8177 !grad        do ll=1,3
8178 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8179 !grad        enddo
8180 !grad      enddo
8181 !d      do iii=1,nres-3
8182 !d        write (2,*) iii,g_corr6_loc(iii)
8183 !d      enddo
8184       eello6=ekont*eel6
8185 !d      write (2,*) 'ekont',ekont
8186 !d      write (iout,*) 'eello6',ekont*eel6
8187       return
8188       end function eello6
8189 !-----------------------------------------------------------------------------
8190       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8191       use comm_kut
8192 !      implicit real*8 (a-h,o-z)
8193 !      include 'DIMENSIONS'
8194 !      include 'COMMON.IOUNITS'
8195 !      include 'COMMON.CHAIN'
8196 !      include 'COMMON.DERIV'
8197 !      include 'COMMON.INTERACT'
8198 !      include 'COMMON.CONTACTS'
8199 !      include 'COMMON.TORSION'
8200 !      include 'COMMON.VAR'
8201 !      include 'COMMON.GEO'
8202       real(kind=8),dimension(2) :: vv,vv1
8203       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8204       logical :: swap
8205 !el      logical :: lprn
8206 !el      common /kutas/ lprn
8207       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8208       real(kind=8) :: s1,s2,s3,s4,s5
8209 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8210 !                                                                              C
8211 !      Parallel       Antiparallel                                             C
8212 !                                                                              C
8213 !          o             o                                                     C
8214 !         /l\           /j\                                                    C
8215 !        /   \         /   \                                                   C
8216 !       /| o |         | o |\                                                  C
8217 !     \ j|/k\|  /   \  |/k\|l /                                                C
8218 !      \ /   \ /     \ /   \ /                                                 C
8219 !       o     o       o     o                                                  C
8220 !       i             i                                                        C
8221 !                                                                              C
8222 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8223       itk=itortyp(itype(k))
8224       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8225       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8226       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8227       call transpose2(EUgC(1,1,k),auxmat(1,1))
8228       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8229       vv1(1)=pizda1(1,1)-pizda1(2,2)
8230       vv1(2)=pizda1(1,2)+pizda1(2,1)
8231       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8232       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8233       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8234       s5=scalar2(vv(1),Dtobr2(1,i))
8235 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8236       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8237       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8238        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8239        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8240        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8241        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8242        +scalar2(vv(1),Dtobr2der(1,i)))
8243       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8244       vv1(1)=pizda1(1,1)-pizda1(2,2)
8245       vv1(2)=pizda1(1,2)+pizda1(2,1)
8246       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8247       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8248       if (l.eq.j+1) then
8249         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8250        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8251        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8252        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8253        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8254       else
8255         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8256        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8257        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8258        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8259        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8260       endif
8261       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8262       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8263       vv1(1)=pizda1(1,1)-pizda1(2,2)
8264       vv1(2)=pizda1(1,2)+pizda1(2,1)
8265       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8266        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8267        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8268        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8269       do iii=1,2
8270         if (swap) then
8271           ind=3-iii
8272         else
8273           ind=iii
8274         endif
8275         do kkk=1,5
8276           do lll=1,3
8277             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8278             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8279             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8280             call transpose2(EUgC(1,1,k),auxmat(1,1))
8281             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8282               pizda1(1,1))
8283             vv1(1)=pizda1(1,1)-pizda1(2,2)
8284             vv1(2)=pizda1(1,2)+pizda1(2,1)
8285             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8286             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8287              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8288             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8289              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8290             s5=scalar2(vv(1),Dtobr2(1,i))
8291             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8292           enddo
8293         enddo
8294       enddo
8295       return
8296       end function eello6_graph1
8297 !-----------------------------------------------------------------------------
8298       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8299       use comm_kut
8300 !      implicit real*8 (a-h,o-z)
8301 !      include 'DIMENSIONS'
8302 !      include 'COMMON.IOUNITS'
8303 !      include 'COMMON.CHAIN'
8304 !      include 'COMMON.DERIV'
8305 !      include 'COMMON.INTERACT'
8306 !      include 'COMMON.CONTACTS'
8307 !      include 'COMMON.TORSION'
8308 !      include 'COMMON.VAR'
8309 !      include 'COMMON.GEO'
8310       logical :: swap
8311       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8312       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8313 !el      logical :: lprn
8314 !el      common /kutas/ lprn
8315       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8316       real(kind=8) :: s2,s3,s4
8317 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8318 !                                                                              C
8319 !      Parallel       Antiparallel                                             C
8320 !                                                                              C
8321 !          o             o                                                     C
8322 !     \   /l\           /j\   /                                                C
8323 !      \ /   \         /   \ /                                                 C
8324 !       o| o |         | o |o                                                  C
8325 !     \ j|/k\|      \  |/k\|l                                                  C
8326 !      \ /   \       \ /   \                                                   C
8327 !       o             o                                                        C
8328 !       i             i                                                        C
8329 !                                                                              C
8330 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8331 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8332 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8333 !           but not in a cluster cumulant
8334 #ifdef MOMENT
8335       s1=dip(1,jj,i)*dip(1,kk,k)
8336 #endif
8337       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8338       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8339       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8340       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8341       call transpose2(EUg(1,1,k),auxmat(1,1))
8342       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8343       vv(1)=pizda(1,1)-pizda(2,2)
8344       vv(2)=pizda(1,2)+pizda(2,1)
8345       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8346 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8347 #ifdef MOMENT
8348       eello6_graph2=-(s1+s2+s3+s4)
8349 #else
8350       eello6_graph2=-(s2+s3+s4)
8351 #endif
8352 !      eello6_graph2=-s3
8353 ! Derivatives in gamma(i-1)
8354       if (i.gt.1) then
8355 #ifdef MOMENT
8356         s1=dipderg(1,jj,i)*dip(1,kk,k)
8357 #endif
8358         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8359         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8360         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8361         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8362 #ifdef MOMENT
8363         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8364 #else
8365         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8366 #endif
8367 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8368       endif
8369 ! Derivatives in gamma(k-1)
8370 #ifdef MOMENT
8371       s1=dip(1,jj,i)*dipderg(1,kk,k)
8372 #endif
8373       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8374       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8375       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8376       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8377       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8378       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8379       vv(1)=pizda(1,1)-pizda(2,2)
8380       vv(2)=pizda(1,2)+pizda(2,1)
8381       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8382 #ifdef MOMENT
8383       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8384 #else
8385       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8386 #endif
8387 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8388 ! Derivatives in gamma(j-1) or gamma(l-1)
8389       if (j.gt.1) then
8390 #ifdef MOMENT
8391         s1=dipderg(3,jj,i)*dip(1,kk,k)
8392 #endif
8393         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8394         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8395         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8396         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8397         vv(1)=pizda(1,1)-pizda(2,2)
8398         vv(2)=pizda(1,2)+pizda(2,1)
8399         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8400 #ifdef MOMENT
8401         if (swap) then
8402           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8403         else
8404           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8405         endif
8406 #endif
8407         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8408 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8409       endif
8410 ! Derivatives in gamma(l-1) or gamma(j-1)
8411       if (l.gt.1) then
8412 #ifdef MOMENT
8413         s1=dip(1,jj,i)*dipderg(3,kk,k)
8414 #endif
8415         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8416         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8417         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8418         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8419         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8420         vv(1)=pizda(1,1)-pizda(2,2)
8421         vv(2)=pizda(1,2)+pizda(2,1)
8422         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8423 #ifdef MOMENT
8424         if (swap) then
8425           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8426         else
8427           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8428         endif
8429 #endif
8430         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8431 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8432       endif
8433 ! Cartesian derivatives.
8434       if (lprn) then
8435         write (2,*) 'In eello6_graph2'
8436         do iii=1,2
8437           write (2,*) 'iii=',iii
8438           do kkk=1,5
8439             write (2,*) 'kkk=',kkk
8440             do jjj=1,2
8441               write (2,'(3(2f10.5),5x)') &
8442               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8443             enddo
8444           enddo
8445         enddo
8446       endif
8447       do iii=1,2
8448         do kkk=1,5
8449           do lll=1,3
8450 #ifdef MOMENT
8451             if (iii.eq.1) then
8452               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8453             else
8454               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8455             endif
8456 #endif
8457             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8458               auxvec(1))
8459             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8460             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8461               auxvec(1))
8462             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8463             call transpose2(EUg(1,1,k),auxmat(1,1))
8464             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8465               pizda(1,1))
8466             vv(1)=pizda(1,1)-pizda(2,2)
8467             vv(2)=pizda(1,2)+pizda(2,1)
8468             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8469 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8470 #ifdef MOMENT
8471             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8472 #else
8473             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8474 #endif
8475             if (swap) then
8476               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8477             else
8478               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8479             endif
8480           enddo
8481         enddo
8482       enddo
8483       return
8484       end function eello6_graph2
8485 !-----------------------------------------------------------------------------
8486       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8487 !      implicit real*8 (a-h,o-z)
8488 !      include 'DIMENSIONS'
8489 !      include 'COMMON.IOUNITS'
8490 !      include 'COMMON.CHAIN'
8491 !      include 'COMMON.DERIV'
8492 !      include 'COMMON.INTERACT'
8493 !      include 'COMMON.CONTACTS'
8494 !      include 'COMMON.TORSION'
8495 !      include 'COMMON.VAR'
8496 !      include 'COMMON.GEO'
8497       real(kind=8),dimension(2) :: vv,auxvec
8498       real(kind=8),dimension(2,2) :: pizda,auxmat
8499       logical :: swap
8500       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8501       real(kind=8) :: s1,s2,s3,s4
8502 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8503 !                                                                              C
8504 !      Parallel       Antiparallel                                             C
8505 !                                                                              C
8506 !          o             o                                                     C
8507 !         /l\   /   \   /j\                                                    C
8508 !        /   \ /     \ /   \                                                   C
8509 !       /| o |o       o| o |\                                                  C
8510 !       j|/k\|  /      |/k\|l /                                                C
8511 !        /   \ /       /   \ /                                                 C
8512 !       /     o       /     o                                                  C
8513 !       i             i                                                        C
8514 !                                                                              C
8515 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8516 !
8517 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8518 !           energy moment and not to the cluster cumulant.
8519       iti=itortyp(itype(i))
8520       if (j.lt.nres-1) then
8521         itj1=itortyp(itype(j+1))
8522       else
8523         itj1=ntortyp+1
8524       endif
8525       itk=itortyp(itype(k))
8526       itk1=itortyp(itype(k+1))
8527       if (l.lt.nres-1) then
8528         itl1=itortyp(itype(l+1))
8529       else
8530         itl1=ntortyp+1
8531       endif
8532 #ifdef MOMENT
8533       s1=dip(4,jj,i)*dip(4,kk,k)
8534 #endif
8535       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8536       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8537       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8538       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8539       call transpose2(EE(1,1,itk),auxmat(1,1))
8540       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8541       vv(1)=pizda(1,1)+pizda(2,2)
8542       vv(2)=pizda(2,1)-pizda(1,2)
8543       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8544 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8545 !d     & "sum",-(s2+s3+s4)
8546 #ifdef MOMENT
8547       eello6_graph3=-(s1+s2+s3+s4)
8548 #else
8549       eello6_graph3=-(s2+s3+s4)
8550 #endif
8551 !      eello6_graph3=-s4
8552 ! Derivatives in gamma(k-1)
8553       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8554       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8555       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8556       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8557 ! Derivatives in gamma(l-1)
8558       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8559       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8560       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8561       vv(1)=pizda(1,1)+pizda(2,2)
8562       vv(2)=pizda(2,1)-pizda(1,2)
8563       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8564       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8565 ! Cartesian derivatives.
8566       do iii=1,2
8567         do kkk=1,5
8568           do lll=1,3
8569 #ifdef MOMENT
8570             if (iii.eq.1) then
8571               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8572             else
8573               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8574             endif
8575 #endif
8576             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8577               auxvec(1))
8578             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8579             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8580               auxvec(1))
8581             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8582             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8583               pizda(1,1))
8584             vv(1)=pizda(1,1)+pizda(2,2)
8585             vv(2)=pizda(2,1)-pizda(1,2)
8586             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8587 #ifdef MOMENT
8588             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8589 #else
8590             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8591 #endif
8592             if (swap) then
8593               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8594             else
8595               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8596             endif
8597 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8598           enddo
8599         enddo
8600       enddo
8601       return
8602       end function eello6_graph3
8603 !-----------------------------------------------------------------------------
8604       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8605 !      implicit real*8 (a-h,o-z)
8606 !      include 'DIMENSIONS'
8607 !      include 'COMMON.IOUNITS'
8608 !      include 'COMMON.CHAIN'
8609 !      include 'COMMON.DERIV'
8610 !      include 'COMMON.INTERACT'
8611 !      include 'COMMON.CONTACTS'
8612 !      include 'COMMON.TORSION'
8613 !      include 'COMMON.VAR'
8614 !      include 'COMMON.GEO'
8615 !      include 'COMMON.FFIELD'
8616       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8617       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8618       logical :: swap
8619       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8620               iii,kkk,lll
8621       real(kind=8) :: s1,s2,s3,s4
8622 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8623 !                                                                              C
8624 !      Parallel       Antiparallel                                             C
8625 !                                                                              C
8626 !          o             o                                                     C
8627 !         /l\   /   \   /j\                                                    C
8628 !        /   \ /     \ /   \                                                   C
8629 !       /| o |o       o| o |\                                                  C
8630 !     \ j|/k\|      \  |/k\|l                                                  C
8631 !      \ /   \       \ /   \                                                   C
8632 !       o     \       o     \                                                  C
8633 !       i             i                                                        C
8634 !                                                                              C
8635 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8636 !
8637 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8638 !           energy moment and not to the cluster cumulant.
8639 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8640       iti=itortyp(itype(i))
8641       itj=itortyp(itype(j))
8642       if (j.lt.nres-1) then
8643         itj1=itortyp(itype(j+1))
8644       else
8645         itj1=ntortyp+1
8646       endif
8647       itk=itortyp(itype(k))
8648       if (k.lt.nres-1) then
8649         itk1=itortyp(itype(k+1))
8650       else
8651         itk1=ntortyp+1
8652       endif
8653       itl=itortyp(itype(l))
8654       if (l.lt.nres-1) then
8655         itl1=itortyp(itype(l+1))
8656       else
8657         itl1=ntortyp+1
8658       endif
8659 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8660 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8661 !d     & ' itl',itl,' itl1',itl1
8662 #ifdef MOMENT
8663       if (imat.eq.1) then
8664         s1=dip(3,jj,i)*dip(3,kk,k)
8665       else
8666         s1=dip(2,jj,j)*dip(2,kk,l)
8667       endif
8668 #endif
8669       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8670       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8671       if (j.eq.l+1) then
8672         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8673         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8674       else
8675         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8676         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8677       endif
8678       call transpose2(EUg(1,1,k),auxmat(1,1))
8679       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8680       vv(1)=pizda(1,1)-pizda(2,2)
8681       vv(2)=pizda(2,1)+pizda(1,2)
8682       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8683 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8684 #ifdef MOMENT
8685       eello6_graph4=-(s1+s2+s3+s4)
8686 #else
8687       eello6_graph4=-(s2+s3+s4)
8688 #endif
8689 ! Derivatives in gamma(i-1)
8690       if (i.gt.1) then
8691 #ifdef MOMENT
8692         if (imat.eq.1) then
8693           s1=dipderg(2,jj,i)*dip(3,kk,k)
8694         else
8695           s1=dipderg(4,jj,j)*dip(2,kk,l)
8696         endif
8697 #endif
8698         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8699         if (j.eq.l+1) then
8700           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8701           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8702         else
8703           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8704           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8705         endif
8706         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8707         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8708 !d          write (2,*) 'turn6 derivatives'
8709 #ifdef MOMENT
8710           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8711 #else
8712           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8713 #endif
8714         else
8715 #ifdef MOMENT
8716           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8717 #else
8718           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8719 #endif
8720         endif
8721       endif
8722 ! Derivatives in gamma(k-1)
8723 #ifdef MOMENT
8724       if (imat.eq.1) then
8725         s1=dip(3,jj,i)*dipderg(2,kk,k)
8726       else
8727         s1=dip(2,jj,j)*dipderg(4,kk,l)
8728       endif
8729 #endif
8730       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8731       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8732       if (j.eq.l+1) then
8733         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8734         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8735       else
8736         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8737         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8738       endif
8739       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8740       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8741       vv(1)=pizda(1,1)-pizda(2,2)
8742       vv(2)=pizda(2,1)+pizda(1,2)
8743       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8744       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8745 #ifdef MOMENT
8746         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8747 #else
8748         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8749 #endif
8750       else
8751 #ifdef MOMENT
8752         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8753 #else
8754         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8755 #endif
8756       endif
8757 ! Derivatives in gamma(j-1) or gamma(l-1)
8758       if (l.eq.j+1 .and. l.gt.1) then
8759         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8760         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8761         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8762         vv(1)=pizda(1,1)-pizda(2,2)
8763         vv(2)=pizda(2,1)+pizda(1,2)
8764         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8765         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8766       else if (j.gt.1) then
8767         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8768         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8769         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8770         vv(1)=pizda(1,1)-pizda(2,2)
8771         vv(2)=pizda(2,1)+pizda(1,2)
8772         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8773         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8774           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8775         else
8776           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8777         endif
8778       endif
8779 ! Cartesian derivatives.
8780       do iii=1,2
8781         do kkk=1,5
8782           do lll=1,3
8783 #ifdef MOMENT
8784             if (iii.eq.1) then
8785               if (imat.eq.1) then
8786                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8787               else
8788                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8789               endif
8790             else
8791               if (imat.eq.1) then
8792                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8793               else
8794                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8795               endif
8796             endif
8797 #endif
8798             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8799               auxvec(1))
8800             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8801             if (j.eq.l+1) then
8802               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8803                 b1(1,itj1),auxvec(1))
8804               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8805             else
8806               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8807                 b1(1,itl1),auxvec(1))
8808               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8809             endif
8810             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8811               pizda(1,1))
8812             vv(1)=pizda(1,1)-pizda(2,2)
8813             vv(2)=pizda(2,1)+pizda(1,2)
8814             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8815             if (swap) then
8816               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8817 #ifdef MOMENT
8818                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8819                    -(s1+s2+s4)
8820 #else
8821                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8822                    -(s2+s4)
8823 #endif
8824                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8825               else
8826 #ifdef MOMENT
8827                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8828 #else
8829                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8830 #endif
8831                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8832               endif
8833             else
8834 #ifdef MOMENT
8835               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8836 #else
8837               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8838 #endif
8839               if (l.eq.j+1) then
8840                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8841               else
8842                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8843               endif
8844             endif
8845           enddo
8846         enddo
8847       enddo
8848       return
8849       end function eello6_graph4
8850 !-----------------------------------------------------------------------------
8851       real(kind=8) function eello_turn6(i,jj,kk)
8852 !      implicit real*8 (a-h,o-z)
8853 !      include 'DIMENSIONS'
8854 !      include 'COMMON.IOUNITS'
8855 !      include 'COMMON.CHAIN'
8856 !      include 'COMMON.DERIV'
8857 !      include 'COMMON.INTERACT'
8858 !      include 'COMMON.CONTACTS'
8859 !      include 'COMMON.TORSION'
8860 !      include 'COMMON.VAR'
8861 !      include 'COMMON.GEO'
8862       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8863       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8864       real(kind=8),dimension(3) :: ggg1,ggg2
8865       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8866       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8867 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8868 !           the respective energy moment and not to the cluster cumulant.
8869 !el local variables
8870       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8871       integer :: j1,j2,l1,l2,ll
8872       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8873       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8874       s1=0.0d0
8875       s8=0.0d0
8876       s13=0.0d0
8877 !
8878       eello_turn6=0.0d0
8879       j=i+4
8880       k=i+1
8881       l=i+3
8882       iti=itortyp(itype(i))
8883       itk=itortyp(itype(k))
8884       itk1=itortyp(itype(k+1))
8885       itl=itortyp(itype(l))
8886       itj=itortyp(itype(j))
8887 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8888 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8889 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8890 !d        eello6=0.0d0
8891 !d        return
8892 !d      endif
8893 !d      write (iout,*)
8894 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8895 !d     &   ' and',k,l
8896 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8897       do iii=1,2
8898         do kkk=1,5
8899           do lll=1,3
8900             derx_turn(lll,kkk,iii)=0.0d0
8901           enddo
8902         enddo
8903       enddo
8904 !d      eij=1.0d0
8905 !d      ekl=1.0d0
8906 !d      ekont=1.0d0
8907       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8908 !d      eello6_5=0.0d0
8909 !d      write (2,*) 'eello6_5',eello6_5
8910 #ifdef MOMENT
8911       call transpose2(AEA(1,1,1),auxmat(1,1))
8912       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8913       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8914       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8915 #endif
8916       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8917       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8918       s2 = scalar2(b1(1,itk),vtemp1(1))
8919 #ifdef MOMENT
8920       call transpose2(AEA(1,1,2),atemp(1,1))
8921       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8922       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8923       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8924 #endif
8925       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8926       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8927       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8928 #ifdef MOMENT
8929       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8930       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8931       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8932       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8933       ss13 = scalar2(b1(1,itk),vtemp4(1))
8934       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8935 #endif
8936 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8937 !      s1=0.0d0
8938 !      s2=0.0d0
8939 !      s8=0.0d0
8940 !      s12=0.0d0
8941 !      s13=0.0d0
8942       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8943 ! Derivatives in gamma(i+2)
8944       s1d =0.0d0
8945       s8d =0.0d0
8946 #ifdef MOMENT
8947       call transpose2(AEA(1,1,1),auxmatd(1,1))
8948       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8949       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8950       call transpose2(AEAderg(1,1,2),atempd(1,1))
8951       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8952       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8953 #endif
8954       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8955       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8956       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8957 !      s1d=0.0d0
8958 !      s2d=0.0d0
8959 !      s8d=0.0d0
8960 !      s12d=0.0d0
8961 !      s13d=0.0d0
8962       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8963 ! Derivatives in gamma(i+3)
8964 #ifdef MOMENT
8965       call transpose2(AEA(1,1,1),auxmatd(1,1))
8966       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8967       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8968       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8969 #endif
8970       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8971       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8972       s2d = scalar2(b1(1,itk),vtemp1d(1))
8973 #ifdef MOMENT
8974       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8975       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8976 #endif
8977       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8978 #ifdef MOMENT
8979       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8980       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8981       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8982 #endif
8983 !      s1d=0.0d0
8984 !      s2d=0.0d0
8985 !      s8d=0.0d0
8986 !      s12d=0.0d0
8987 !      s13d=0.0d0
8988 #ifdef MOMENT
8989       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8990                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8991 #else
8992       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8993                     -0.5d0*ekont*(s2d+s12d)
8994 #endif
8995 ! Derivatives in gamma(i+4)
8996       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8997       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8998       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8999 #ifdef MOMENT
9000       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9001       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9002       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9003 #endif
9004 !      s1d=0.0d0
9005 !      s2d=0.0d0
9006 !      s8d=0.0d0
9007 !      s12d=0.0d0
9008 !      s13d=0.0d0
9009 #ifdef MOMENT
9010       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9011 #else
9012       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9013 #endif
9014 ! Derivatives in gamma(i+5)
9015 #ifdef MOMENT
9016       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9017       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9018       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9019 #endif
9020       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9021       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9022       s2d = scalar2(b1(1,itk),vtemp1d(1))
9023 #ifdef MOMENT
9024       call transpose2(AEA(1,1,2),atempd(1,1))
9025       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9026       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9027 #endif
9028       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9029       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9030 #ifdef MOMENT
9031       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9032       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9033       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9034 #endif
9035 !      s1d=0.0d0
9036 !      s2d=0.0d0
9037 !      s8d=0.0d0
9038 !      s12d=0.0d0
9039 !      s13d=0.0d0
9040 #ifdef MOMENT
9041       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9042                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9043 #else
9044       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9045                     -0.5d0*ekont*(s2d+s12d)
9046 #endif
9047 ! Cartesian derivatives
9048       do iii=1,2
9049         do kkk=1,5
9050           do lll=1,3
9051 #ifdef MOMENT
9052             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9053             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9054             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9055 #endif
9056             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9057             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9058                 vtemp1d(1))
9059             s2d = scalar2(b1(1,itk),vtemp1d(1))
9060 #ifdef MOMENT
9061             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9062             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9063             s8d = -(atempd(1,1)+atempd(2,2))* &
9064                  scalar2(cc(1,1,itl),vtemp2(1))
9065 #endif
9066             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9067                  auxmatd(1,1))
9068             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9069             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9070 !      s1d=0.0d0
9071 !      s2d=0.0d0
9072 !      s8d=0.0d0
9073 !      s12d=0.0d0
9074 !      s13d=0.0d0
9075 #ifdef MOMENT
9076             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9077               - 0.5d0*(s1d+s2d)
9078 #else
9079             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9080               - 0.5d0*s2d
9081 #endif
9082 #ifdef MOMENT
9083             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9084               - 0.5d0*(s8d+s12d)
9085 #else
9086             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9087               - 0.5d0*s12d
9088 #endif
9089           enddo
9090         enddo
9091       enddo
9092 #ifdef MOMENT
9093       do kkk=1,5
9094         do lll=1,3
9095           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9096             achuj_tempd(1,1))
9097           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9098           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9099           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9100           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9101           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9102             vtemp4d(1))
9103           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9104           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9105           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9106         enddo
9107       enddo
9108 #endif
9109 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9110 !d     &  16*eel_turn6_num
9111 !d      goto 1112
9112       if (j.lt.nres-1) then
9113         j1=j+1
9114         j2=j-1
9115       else
9116         j1=j-1
9117         j2=j-2
9118       endif
9119       if (l.lt.nres-1) then
9120         l1=l+1
9121         l2=l-1
9122       else
9123         l1=l-1
9124         l2=l-2
9125       endif
9126       do ll=1,3
9127 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9128 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9129 !grad        ghalf=0.5d0*ggg1(ll)
9130 !d        ghalf=0.0d0
9131         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9132         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9133         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9134           +ekont*derx_turn(ll,2,1)
9135         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9136         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9137           +ekont*derx_turn(ll,4,1)
9138         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9139         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9140         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9141 !grad        ghalf=0.5d0*ggg2(ll)
9142 !d        ghalf=0.0d0
9143         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9144           +ekont*derx_turn(ll,2,2)
9145         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9146         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9147           +ekont*derx_turn(ll,4,2)
9148         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9149         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9150         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9151       enddo
9152 !d      goto 1112
9153 !grad      do m=i+1,j-1
9154 !grad        do ll=1,3
9155 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9156 !grad        enddo
9157 !grad      enddo
9158 !grad      do m=k+1,l-1
9159 !grad        do ll=1,3
9160 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9161 !grad        enddo
9162 !grad      enddo
9163 !grad1112  continue
9164 !grad      do m=i+2,j2
9165 !grad        do ll=1,3
9166 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9167 !grad        enddo
9168 !grad      enddo
9169 !grad      do m=k+2,l2
9170 !grad        do ll=1,3
9171 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9172 !grad        enddo
9173 !grad      enddo
9174 !d      do iii=1,nres-3
9175 !d        write (2,*) iii,g_corr6_loc(iii)
9176 !d      enddo
9177       eello_turn6=ekont*eel_turn6
9178 !d      write (2,*) 'ekont',ekont
9179 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9180       return
9181       end function eello_turn6
9182 !-----------------------------------------------------------------------------
9183       subroutine MATVEC2(A1,V1,V2)
9184 !DIR$ INLINEALWAYS MATVEC2
9185 #ifndef OSF
9186 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9187 #endif
9188 !      implicit real*8 (a-h,o-z)
9189 !      include 'DIMENSIONS'
9190       real(kind=8),dimension(2) :: V1,V2
9191       real(kind=8),dimension(2,2) :: A1
9192       real(kind=8) :: vaux1,vaux2
9193 !      DO 1 I=1,2
9194 !        VI=0.0
9195 !        DO 3 K=1,2
9196 !    3     VI=VI+A1(I,K)*V1(K)
9197 !        Vaux(I)=VI
9198 !    1 CONTINUE
9199
9200       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9201       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9202
9203       v2(1)=vaux1
9204       v2(2)=vaux2
9205       end subroutine MATVEC2
9206 !-----------------------------------------------------------------------------
9207       subroutine MATMAT2(A1,A2,A3)
9208 #ifndef OSF
9209 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9210 #endif
9211 !      implicit real*8 (a-h,o-z)
9212 !      include 'DIMENSIONS'
9213       real(kind=8),dimension(2,2) :: A1,A2,A3
9214       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9215 !      DIMENSION AI3(2,2)
9216 !        DO  J=1,2
9217 !          A3IJ=0.0
9218 !          DO K=1,2
9219 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9220 !          enddo
9221 !          A3(I,J)=A3IJ
9222 !       enddo
9223 !      enddo
9224
9225       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9226       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9227       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9228       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9229
9230       A3(1,1)=AI3_11
9231       A3(2,1)=AI3_21
9232       A3(1,2)=AI3_12
9233       A3(2,2)=AI3_22
9234       end subroutine MATMAT2
9235 !-----------------------------------------------------------------------------
9236       real(kind=8) function scalar2(u,v)
9237 !DIR$ INLINEALWAYS scalar2
9238       implicit none
9239       real(kind=8),dimension(2) :: u,v
9240       real(kind=8) :: sc
9241       integer :: i
9242       scalar2=u(1)*v(1)+u(2)*v(2)
9243       return
9244       end function scalar2
9245 !-----------------------------------------------------------------------------
9246       subroutine transpose2(a,at)
9247 !DIR$ INLINEALWAYS transpose2
9248 #ifndef OSF
9249 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9250 #endif
9251       implicit none
9252       real(kind=8),dimension(2,2) :: a,at
9253       at(1,1)=a(1,1)
9254       at(1,2)=a(2,1)
9255       at(2,1)=a(1,2)
9256       at(2,2)=a(2,2)
9257       return
9258       end subroutine transpose2
9259 !-----------------------------------------------------------------------------
9260       subroutine transpose(n,a,at)
9261       implicit none
9262       integer :: n,i,j
9263       real(kind=8),dimension(n,n) :: a,at
9264       do i=1,n
9265         do j=1,n
9266           at(j,i)=a(i,j)
9267         enddo
9268       enddo
9269       return
9270       end subroutine transpose
9271 !-----------------------------------------------------------------------------
9272       subroutine prodmat3(a1,a2,kk,transp,prod)
9273 !DIR$ INLINEALWAYS prodmat3
9274 #ifndef OSF
9275 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9276 #endif
9277       implicit none
9278       integer :: i,j
9279       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9280       logical :: transp
9281 !rc      double precision auxmat(2,2),prod_(2,2)
9282
9283       if (transp) then
9284 !rc        call transpose2(kk(1,1),auxmat(1,1))
9285 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9286 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9287
9288            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9289        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9290            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9291        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9292            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9293        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9294            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9295        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9296
9297       else
9298 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9299 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9300
9301            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9302         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9303            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9304         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9305            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9306         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9307            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9308         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9309
9310       endif
9311 !      call transpose2(a2(1,1),a2t(1,1))
9312
9313 !rc      print *,transp
9314 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9315 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9316
9317       return
9318       end subroutine prodmat3
9319 !-----------------------------------------------------------------------------
9320 ! energy_p_new_barrier.F
9321 !-----------------------------------------------------------------------------
9322       subroutine sum_gradient
9323 !      implicit real*8 (a-h,o-z)
9324       use io_base, only: pdbout
9325 !      include 'DIMENSIONS'
9326 #ifndef ISNAN
9327       external proc_proc
9328 #ifdef WINPGI
9329 !MS$ATTRIBUTES C ::  proc_proc
9330 #endif
9331 #endif
9332 #ifdef MPI
9333       include 'mpif.h'
9334 #endif
9335       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9336                    gloc_scbuf !(3,maxres)
9337
9338       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9339 !#endif
9340 !el local variables
9341       integer :: i,j,k,ierror,ierr
9342       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9343                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9344                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9345                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9346                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9347                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9348                    gsccorr_max,gsccorrx_max,time00
9349
9350 !      include 'COMMON.SETUP'
9351 !      include 'COMMON.IOUNITS'
9352 !      include 'COMMON.FFIELD'
9353 !      include 'COMMON.DERIV'
9354 !      include 'COMMON.INTERACT'
9355 !      include 'COMMON.SBRIDGE'
9356 !      include 'COMMON.CHAIN'
9357 !      include 'COMMON.VAR'
9358 !      include 'COMMON.CONTROL'
9359 !      include 'COMMON.TIME1'
9360 !      include 'COMMON.MAXGRAD'
9361 !      include 'COMMON.SCCOR'
9362 #ifdef TIMING
9363       time01=MPI_Wtime()
9364 #endif
9365 #ifdef DEBUG
9366       write (iout,*) "sum_gradient gvdwc, gvdwx"
9367       do i=1,nres
9368         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9369          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9370       enddo
9371       call flush(iout)
9372 #endif
9373 #ifdef MPI
9374         gradbufc=0.0d0
9375         gradbufx=0.0d0
9376         gradbufc_sum=0.0d0
9377         gloc_scbuf=0.0d0
9378         glocbuf=0.0d0
9379 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9380         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9381           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9382 #endif
9383 !
9384 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9385 !            in virtual-bond-vector coordinates
9386 !
9387 #ifdef DEBUG
9388 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9389 !      do i=1,nres-1
9390 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9391 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9392 !      enddo
9393 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9394 !      do i=1,nres-1
9395 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9396 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9397 !      enddo
9398       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9399       do i=1,nres
9400         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9401          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9402          (gvdwc_scpp(j,i),j=1,3)
9403       enddo
9404       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9405       do i=1,nres
9406         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9407          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9408          (gelc_loc_long(j,i),j=1,3)
9409       enddo
9410       call flush(iout)
9411 #endif
9412 #ifdef SPLITELE
9413       do i=1,nct
9414         do j=1,3
9415           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9416                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9417                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9418                       wel_loc*gel_loc_long(j,i)+ &
9419                       wcorr*gradcorr_long(j,i)+ &
9420                       wcorr5*gradcorr5_long(j,i)+ &
9421                       wcorr6*gradcorr6_long(j,i)+ &
9422                       wturn6*gcorr6_turn_long(j,i)+ &
9423                       wstrain*ghpbc(j,i)
9424         enddo
9425       enddo
9426 #else
9427       do i=1,nct
9428         do j=1,3
9429           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9430                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9431                       welec*gelc_long(j,i)+ &
9432                       wbond*gradb(j,i)+ &
9433                       wel_loc*gel_loc_long(j,i)+ &
9434                       wcorr*gradcorr_long(j,i)+ &
9435                       wcorr5*gradcorr5_long(j,i)+ &
9436                       wcorr6*gradcorr6_long(j,i)+ &
9437                       wturn6*gcorr6_turn_long(j,i)+ &
9438                       wstrain*ghpbc(j,i)
9439         enddo
9440       enddo
9441 #endif
9442 #ifdef MPI
9443       if (nfgtasks.gt.1) then
9444       time00=MPI_Wtime()
9445 #ifdef DEBUG
9446       write (iout,*) "gradbufc before allreduce"
9447       do i=1,nres
9448         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9449       enddo
9450       call flush(iout)
9451 #endif
9452       do i=1,nres
9453         do j=1,3
9454           gradbufc_sum(j,i)=gradbufc(j,i)
9455         enddo
9456       enddo
9457 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9458 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9459 !      time_reduce=time_reduce+MPI_Wtime()-time00
9460 #ifdef DEBUG
9461 !      write (iout,*) "gradbufc_sum after allreduce"
9462 !      do i=1,nres
9463 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9464 !      enddo
9465 !      call flush(iout)
9466 #endif
9467 #ifdef TIMING
9468 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9469 #endif
9470       do i=nnt,nres
9471         do k=1,3
9472           gradbufc(k,i)=0.0d0
9473         enddo
9474       enddo
9475 #ifdef DEBUG
9476       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9477       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9478                         " jgrad_end  ",jgrad_end(i),&
9479                         i=igrad_start,igrad_end)
9480 #endif
9481 !
9482 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9483 ! do not parallelize this part.
9484 !
9485 !      do i=igrad_start,igrad_end
9486 !        do j=jgrad_start(i),jgrad_end(i)
9487 !          do k=1,3
9488 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9489 !          enddo
9490 !        enddo
9491 !      enddo
9492       do j=1,3
9493         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9494       enddo
9495       do i=nres-2,nnt,-1
9496         do j=1,3
9497           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9498         enddo
9499       enddo
9500 #ifdef DEBUG
9501       write (iout,*) "gradbufc after summing"
9502       do i=1,nres
9503         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9504       enddo
9505       call flush(iout)
9506 #endif
9507       else
9508 #endif
9509 !el#define DEBUG
9510 #ifdef DEBUG
9511       write (iout,*) "gradbufc"
9512       do i=1,nres
9513         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9514       enddo
9515       call flush(iout)
9516 #endif
9517 !el#undef DEBUG
9518       do i=1,nres
9519         do j=1,3
9520           gradbufc_sum(j,i)=gradbufc(j,i)
9521           gradbufc(j,i)=0.0d0
9522         enddo
9523       enddo
9524       do j=1,3
9525         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9526       enddo
9527       do i=nres-2,nnt,-1
9528         do j=1,3
9529           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9530         enddo
9531       enddo
9532 !      do i=nnt,nres-1
9533 !        do k=1,3
9534 !          gradbufc(k,i)=0.0d0
9535 !        enddo
9536 !        do j=i+1,nres
9537 !          do k=1,3
9538 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9539 !          enddo
9540 !        enddo
9541 !      enddo
9542 !el#define DEBUG
9543 #ifdef DEBUG
9544       write (iout,*) "gradbufc after summing"
9545       do i=1,nres
9546         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9547       enddo
9548       call flush(iout)
9549 #endif
9550 !el#undef DEBUG
9551 #ifdef MPI
9552       endif
9553 #endif
9554       do k=1,3
9555         gradbufc(k,nres)=0.0d0
9556       enddo
9557 !el----------------
9558 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9559 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9560 !el-----------------
9561       do i=1,nct
9562         do j=1,3
9563 #ifdef SPLITELE
9564           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9565                       wel_loc*gel_loc(j,i)+ &
9566                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9567                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9568                       wel_loc*gel_loc_long(j,i)+ &
9569                       wcorr*gradcorr_long(j,i)+ &
9570                       wcorr5*gradcorr5_long(j,i)+ &
9571                       wcorr6*gradcorr6_long(j,i)+ &
9572                       wturn6*gcorr6_turn_long(j,i))+ &
9573                       wbond*gradb(j,i)+ &
9574                       wcorr*gradcorr(j,i)+ &
9575                       wturn3*gcorr3_turn(j,i)+ &
9576                       wturn4*gcorr4_turn(j,i)+ &
9577                       wcorr5*gradcorr5(j,i)+ &
9578                       wcorr6*gradcorr6(j,i)+ &
9579                       wturn6*gcorr6_turn(j,i)+ &
9580                       wsccor*gsccorc(j,i) &
9581                      +wscloc*gscloc(j,i)
9582 #else
9583           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9584                       wel_loc*gel_loc(j,i)+ &
9585                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9586                       welec*gelc_long(j,i)+ &
9587                       wel_loc*gel_loc_long(j,i)+ &
9588 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9589                       wcorr5*gradcorr5_long(j,i)+ &
9590                       wcorr6*gradcorr6_long(j,i)+ &
9591                       wturn6*gcorr6_turn_long(j,i))+ &
9592                       wbond*gradb(j,i)+ &
9593                       wcorr*gradcorr(j,i)+ &
9594                       wturn3*gcorr3_turn(j,i)+ &
9595                       wturn4*gcorr4_turn(j,i)+ &
9596                       wcorr5*gradcorr5(j,i)+ &
9597                       wcorr6*gradcorr6(j,i)+ &
9598                       wturn6*gcorr6_turn(j,i)+ &
9599                       wsccor*gsccorc(j,i) &
9600                      +wscloc*gscloc(j,i)
9601 #endif
9602           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9603                         wbond*gradbx(j,i)+ &
9604                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9605                         wsccor*gsccorx(j,i) &
9606                        +wscloc*gsclocx(j,i)
9607         enddo
9608       enddo
9609 #ifdef DEBUG
9610       write (iout,*) "gloc before adding corr"
9611       do i=1,4*nres
9612         write (iout,*) i,gloc(i,icg)
9613       enddo
9614 #endif
9615       do i=1,nres-3
9616         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9617          +wcorr5*g_corr5_loc(i) &
9618          +wcorr6*g_corr6_loc(i) &
9619          +wturn4*gel_loc_turn4(i) &
9620          +wturn3*gel_loc_turn3(i) &
9621          +wturn6*gel_loc_turn6(i) &
9622          +wel_loc*gel_loc_loc(i)
9623       enddo
9624 #ifdef DEBUG
9625       write (iout,*) "gloc after adding corr"
9626       do i=1,4*nres
9627         write (iout,*) i,gloc(i,icg)
9628       enddo
9629 #endif
9630 #ifdef MPI
9631       if (nfgtasks.gt.1) then
9632         do j=1,3
9633           do i=1,nres
9634             gradbufc(j,i)=gradc(j,i,icg)
9635             gradbufx(j,i)=gradx(j,i,icg)
9636           enddo
9637         enddo
9638         do i=1,4*nres
9639           glocbuf(i)=gloc(i,icg)
9640         enddo
9641 !#define DEBUG
9642 #ifdef DEBUG
9643       write (iout,*) "gloc_sc before reduce"
9644       do i=1,nres
9645        do j=1,1
9646         write (iout,*) i,j,gloc_sc(j,i,icg)
9647        enddo
9648       enddo
9649 #endif
9650 !#undef DEBUG
9651         do i=1,nres
9652          do j=1,3
9653           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9654          enddo
9655         enddo
9656         time00=MPI_Wtime()
9657         call MPI_Barrier(FG_COMM,IERR)
9658         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9659         time00=MPI_Wtime()
9660         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9661           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9662         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9663           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9664         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9665           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9666         time_reduce=time_reduce+MPI_Wtime()-time00
9667         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9668           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9669         time_reduce=time_reduce+MPI_Wtime()-time00
9670 !#define DEBUG
9671 #ifdef DEBUG
9672       write (iout,*) "gloc_sc after reduce"
9673       do i=1,nres
9674        do j=1,1
9675         write (iout,*) i,j,gloc_sc(j,i,icg)
9676        enddo
9677       enddo
9678 #endif
9679 !#undef DEBUG
9680 #ifdef DEBUG
9681       write (iout,*) "gloc after reduce"
9682       do i=1,4*nres
9683         write (iout,*) i,gloc(i,icg)
9684       enddo
9685 #endif
9686       endif
9687 #endif
9688       if (gnorm_check) then
9689 !
9690 ! Compute the maximum elements of the gradient
9691 !
9692       gvdwc_max=0.0d0
9693       gvdwc_scp_max=0.0d0
9694       gelc_max=0.0d0
9695       gvdwpp_max=0.0d0
9696       gradb_max=0.0d0
9697       ghpbc_max=0.0d0
9698       gradcorr_max=0.0d0
9699       gel_loc_max=0.0d0
9700       gcorr3_turn_max=0.0d0
9701       gcorr4_turn_max=0.0d0
9702       gradcorr5_max=0.0d0
9703       gradcorr6_max=0.0d0
9704       gcorr6_turn_max=0.0d0
9705       gsccorc_max=0.0d0
9706       gscloc_max=0.0d0
9707       gvdwx_max=0.0d0
9708       gradx_scp_max=0.0d0
9709       ghpbx_max=0.0d0
9710       gradxorr_max=0.0d0
9711       gsccorx_max=0.0d0
9712       gsclocx_max=0.0d0
9713       do i=1,nct
9714         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9715         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9716         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9717         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9718          gvdwc_scp_max=gvdwc_scp_norm
9719         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9720         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9721         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9722         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9723         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9724         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9725         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9726         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9727         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9728         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9729         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9730         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9731         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9732           gcorr3_turn(1,i)))
9733         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9734           gcorr3_turn_max=gcorr3_turn_norm
9735         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9736           gcorr4_turn(1,i)))
9737         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9738           gcorr4_turn_max=gcorr4_turn_norm
9739         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9740         if (gradcorr5_norm.gt.gradcorr5_max) &
9741           gradcorr5_max=gradcorr5_norm
9742         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9743         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9744         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9745           gcorr6_turn(1,i)))
9746         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9747           gcorr6_turn_max=gcorr6_turn_norm
9748         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9749         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9750         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9751         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9752         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9753         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9754         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9755         if (gradx_scp_norm.gt.gradx_scp_max) &
9756           gradx_scp_max=gradx_scp_norm
9757         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9758         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9759         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9760         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9761         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9762         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9763         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9764         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9765       enddo
9766       if (gradout) then
9767 #ifdef AIX
9768         open(istat,file=statname,position="append")
9769 #else
9770         open(istat,file=statname,access="append")
9771 #endif
9772         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9773            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9774            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9775            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9776            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9777            gsccorx_max,gsclocx_max
9778         close(istat)
9779         if (gvdwc_max.gt.1.0d4) then
9780           write (iout,*) "gvdwc gvdwx gradb gradbx"
9781           do i=nnt,nct
9782             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9783               gradb(j,i),gradbx(j,i),j=1,3)
9784           enddo
9785           call pdbout(0.0d0,'cipiszcze',iout)
9786           call flush(iout)
9787         endif
9788       endif
9789       endif
9790 !el#define DEBUG
9791 #ifdef DEBUG
9792       write (iout,*) "gradc gradx gloc"
9793       do i=1,nres
9794         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9795          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9796       enddo
9797 #endif
9798 !el#undef DEBUG
9799 #ifdef TIMING
9800       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9801 #endif
9802       return
9803       end subroutine sum_gradient
9804 !-----------------------------------------------------------------------------
9805       subroutine sc_grad
9806 !      implicit real*8 (a-h,o-z)
9807       use calc_data
9808 !      include 'DIMENSIONS'
9809 !      include 'COMMON.CHAIN'
9810 !      include 'COMMON.DERIV'
9811 !      include 'COMMON.CALC'
9812 !      include 'COMMON.IOUNITS'
9813       real(kind=8), dimension(3) :: dcosom1,dcosom2
9814
9815       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9816       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9817       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9818            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9819 ! diagnostics only
9820 !      eom1=0.0d0
9821 !      eom2=0.0d0
9822 !      eom12=evdwij*eps1_om12
9823 ! end diagnostics
9824 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9825 !       " sigder",sigder
9826 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9827 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9828 !C      print *,sss_ele_cut,'in sc_grad'
9829       do k=1,3
9830         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9831         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9832       enddo
9833       do k=1,3
9834         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9835 !C      print *,'gg',k,gg(k)
9836       enddo
9837 !      write (iout,*) "gg",(gg(k),k=1,3)
9838       do k=1,3
9839         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9840                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9841                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9842                   *sss_ele_cut
9843
9844         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9845                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9846                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9847                   *sss_ele_cut
9848
9849 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9850 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9851 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9852 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9853       enddo
9854 !
9855 ! Calculate the components of the gradient in DC and X
9856 !
9857 !grad      do k=i,j-1
9858 !grad        do l=1,3
9859 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9860 !grad        enddo
9861 !grad      enddo
9862       do l=1,3
9863         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9864         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9865       enddo
9866       return
9867       end subroutine sc_grad
9868 #ifdef CRYST_THETA
9869 !-----------------------------------------------------------------------------
9870       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9871
9872       use comm_calcthet
9873 !      implicit real*8 (a-h,o-z)
9874 !      include 'DIMENSIONS'
9875 !      include 'COMMON.LOCAL'
9876 !      include 'COMMON.IOUNITS'
9877 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9878 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9879 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9880       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9881       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9882 !el      integer :: it
9883 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9884 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9885 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9886 !el local variables
9887
9888       delthec=thetai-thet_pred_mean
9889       delthe0=thetai-theta0i
9890 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9891       t3 = thetai-thet_pred_mean
9892       t6 = t3**2
9893       t9 = term1
9894       t12 = t3*sigcsq
9895       t14 = t12+t6*sigsqtc
9896       t16 = 1.0d0
9897       t21 = thetai-theta0i
9898       t23 = t21**2
9899       t26 = term2
9900       t27 = t21*t26
9901       t32 = termexp
9902       t40 = t32**2
9903       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9904        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9905        *(-t12*t9-ak*sig0inv*t27)
9906       return
9907       end subroutine mixder
9908 #endif
9909 !-----------------------------------------------------------------------------
9910 ! cartder.F
9911 !-----------------------------------------------------------------------------
9912       subroutine cartder
9913 !-----------------------------------------------------------------------------
9914 ! This subroutine calculates the derivatives of the consecutive virtual
9915 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9916 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9917 ! in the angles alpha and omega, describing the location of a side chain
9918 ! in its local coordinate system.
9919 !
9920 ! The derivatives are stored in the following arrays:
9921 !
9922 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9923 ! The structure is as follows:
9924 !
9925 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9926 ! 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)
9927 !         . . . . . . . . . . . .  . . . . . .
9928 ! 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)
9929 !                          .
9930 !                          .
9931 !                          .
9932 ! 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)
9933 !
9934 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9935 ! The structure is same as above.
9936 !
9937 ! DCDS - the derivatives of the side chain vectors in the local spherical
9938 ! andgles alph and omega:
9939 !
9940 ! 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)
9941 ! 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)
9942 !                          .
9943 !                          .
9944 !                          .
9945 ! 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)
9946 !
9947 ! Version of March '95, based on an early version of November '91.
9948 !
9949 !**********************************************************************
9950 !      implicit real*8 (a-h,o-z)
9951 !      include 'DIMENSIONS'
9952 !      include 'COMMON.VAR'
9953 !      include 'COMMON.CHAIN'
9954 !      include 'COMMON.DERIV'
9955 !      include 'COMMON.GEO'
9956 !      include 'COMMON.LOCAL'
9957 !      include 'COMMON.INTERACT'
9958       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9959       real(kind=8),dimension(3,3) :: dp,temp
9960 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9961       real(kind=8),dimension(3) :: xx,xx1
9962 !el local variables
9963       integer :: i,k,l,j,m,ind,ind1,jjj
9964       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9965                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9966                  sint2,xp,yp,xxp,yyp,zzp,dj
9967
9968 !      common /przechowalnia/ fromto
9969       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9970 ! get the position of the jth ijth fragment of the chain coordinate system
9971 ! in the fromto array.
9972 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9973 !
9974 !      maxdim=(nres-1)*(nres-2)/2
9975 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9976 ! calculate the derivatives of transformation matrix elements in theta
9977 !
9978
9979 !el      call flush(iout) !el
9980       do i=1,nres-2
9981         rdt(1,1,i)=-rt(1,2,i)
9982         rdt(1,2,i)= rt(1,1,i)
9983         rdt(1,3,i)= 0.0d0
9984         rdt(2,1,i)=-rt(2,2,i)
9985         rdt(2,2,i)= rt(2,1,i)
9986         rdt(2,3,i)= 0.0d0
9987         rdt(3,1,i)=-rt(3,2,i)
9988         rdt(3,2,i)= rt(3,1,i)
9989         rdt(3,3,i)= 0.0d0
9990       enddo
9991 !
9992 ! derivatives in phi
9993 !
9994       do i=2,nres-2
9995         drt(1,1,i)= 0.0d0
9996         drt(1,2,i)= 0.0d0
9997         drt(1,3,i)= 0.0d0
9998         drt(2,1,i)= rt(3,1,i)
9999         drt(2,2,i)= rt(3,2,i)
10000         drt(2,3,i)= rt(3,3,i)
10001         drt(3,1,i)=-rt(2,1,i)
10002         drt(3,2,i)=-rt(2,2,i)
10003         drt(3,3,i)=-rt(2,3,i)
10004       enddo
10005 !
10006 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10007 !
10008       do i=2,nres-2
10009         ind=indmat(i,i+1)
10010         do k=1,3
10011           do l=1,3
10012             temp(k,l)=rt(k,l,i)
10013           enddo
10014         enddo
10015         do k=1,3
10016           do l=1,3
10017             fromto(k,l,ind)=temp(k,l)
10018           enddo
10019         enddo
10020         do j=i+1,nres-2
10021           ind=indmat(i,j+1)
10022           do k=1,3
10023             do l=1,3
10024               dpkl=0.0d0
10025               do m=1,3
10026                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10027               enddo
10028               dp(k,l)=dpkl
10029               fromto(k,l,ind)=dpkl
10030             enddo
10031           enddo
10032           do k=1,3
10033             do l=1,3
10034               temp(k,l)=dp(k,l)
10035             enddo
10036           enddo
10037         enddo
10038       enddo
10039 !
10040 ! Calculate derivatives.
10041 !
10042       ind1=0
10043       do i=1,nres-2
10044         ind1=ind1+1
10045 !
10046 ! Derivatives of DC(i+1) in theta(i+2)
10047 !
10048         do j=1,3
10049           do k=1,2
10050             dpjk=0.0D0
10051             do l=1,3
10052               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10053             enddo
10054             dp(j,k)=dpjk
10055             prordt(j,k,i)=dp(j,k)
10056           enddo
10057           dp(j,3)=0.0D0
10058           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10059         enddo
10060 !
10061 ! Derivatives of SC(i+1) in theta(i+2)
10062 !
10063         xx1(1)=-0.5D0*xloc(2,i+1)
10064         xx1(2)= 0.5D0*xloc(1,i+1)
10065         do j=1,3
10066           xj=0.0D0
10067           do k=1,2
10068             xj=xj+r(j,k,i)*xx1(k)
10069           enddo
10070           xx(j)=xj
10071         enddo
10072         do j=1,3
10073           rj=0.0D0
10074           do k=1,3
10075             rj=rj+prod(j,k,i)*xx(k)
10076           enddo
10077           dxdv(j,ind1)=rj
10078         enddo
10079 !
10080 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10081 ! than the other off-diagonal derivatives.
10082 !
10083         do j=1,3
10084           dxoiij=0.0D0
10085           do k=1,3
10086             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10087           enddo
10088           dxdv(j,ind1+1)=dxoiij
10089         enddo
10090 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10091 !
10092 ! Derivatives of DC(i+1) in phi(i+2)
10093 !
10094         do j=1,3
10095           do k=1,3
10096             dpjk=0.0
10097             do l=2,3
10098               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10099             enddo
10100             dp(j,k)=dpjk
10101             prodrt(j,k,i)=dp(j,k)
10102           enddo
10103           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10104         enddo
10105 !
10106 ! Derivatives of SC(i+1) in phi(i+2)
10107 !
10108         xx(1)= 0.0D0
10109         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10110         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10111         do j=1,3
10112           rj=0.0D0
10113           do k=2,3
10114             rj=rj+prod(j,k,i)*xx(k)
10115           enddo
10116           dxdv(j+3,ind1)=-rj
10117         enddo
10118 !
10119 ! Derivatives of SC(i+1) in phi(i+3).
10120 !
10121         do j=1,3
10122           dxoiij=0.0D0
10123           do k=1,3
10124             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10125           enddo
10126           dxdv(j+3,ind1+1)=dxoiij
10127         enddo
10128 !
10129 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10130 ! theta(nres) and phi(i+3) thru phi(nres).
10131 !
10132         do j=i+1,nres-2
10133           ind1=ind1+1
10134           ind=indmat(i+1,j+1)
10135 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10136           do k=1,3
10137             do l=1,3
10138               tempkl=0.0D0
10139               do m=1,2
10140                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10141               enddo
10142               temp(k,l)=tempkl
10143             enddo
10144           enddo
10145 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10146 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10147 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10148 ! Derivatives of virtual-bond vectors in theta
10149           do k=1,3
10150             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10151           enddo
10152 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10153 ! Derivatives of SC vectors in theta
10154           do k=1,3
10155             dxoijk=0.0D0
10156             do l=1,3
10157               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10158             enddo
10159             dxdv(k,ind1+1)=dxoijk
10160           enddo
10161 !
10162 !--- Calculate the derivatives in phi
10163 !
10164           do k=1,3
10165             do l=1,3
10166               tempkl=0.0D0
10167               do m=1,3
10168                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10169               enddo
10170               temp(k,l)=tempkl
10171             enddo
10172           enddo
10173           do k=1,3
10174             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10175           enddo
10176           do k=1,3
10177             dxoijk=0.0D0
10178             do l=1,3
10179               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10180             enddo
10181             dxdv(k+3,ind1+1)=dxoijk
10182           enddo
10183         enddo
10184       enddo
10185 !
10186 ! Derivatives in alpha and omega:
10187 !
10188       do i=2,nres-1
10189 !       dsci=dsc(itype(i))
10190         dsci=vbld(i+nres)
10191 #ifdef OSF
10192         alphi=alph(i)
10193         omegi=omeg(i)
10194         if(alphi.ne.alphi) alphi=100.0
10195         if(omegi.ne.omegi) omegi=-100.0
10196 #else
10197         alphi=alph(i)
10198         omegi=omeg(i)
10199 #endif
10200 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10201         cosalphi=dcos(alphi)
10202         sinalphi=dsin(alphi)
10203         cosomegi=dcos(omegi)
10204         sinomegi=dsin(omegi)
10205         temp(1,1)=-dsci*sinalphi
10206         temp(2,1)= dsci*cosalphi*cosomegi
10207         temp(3,1)=-dsci*cosalphi*sinomegi
10208         temp(1,2)=0.0D0
10209         temp(2,2)=-dsci*sinalphi*sinomegi
10210         temp(3,2)=-dsci*sinalphi*cosomegi
10211         theta2=pi-0.5D0*theta(i+1)
10212         cost2=dcos(theta2)
10213         sint2=dsin(theta2)
10214         jjj=0
10215 !d      print *,((temp(l,k),l=1,3),k=1,2)
10216         do j=1,2
10217           xp=temp(1,j)
10218           yp=temp(2,j)
10219           xxp= xp*cost2+yp*sint2
10220           yyp=-xp*sint2+yp*cost2
10221           zzp=temp(3,j)
10222           xx(1)=xxp
10223           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10224           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10225           do k=1,3
10226             dj=0.0D0
10227             do l=1,3
10228               dj=dj+prod(k,l,i-1)*xx(l)
10229             enddo
10230             dxds(jjj+k,i)=dj
10231           enddo
10232           jjj=jjj+3
10233         enddo
10234       enddo
10235       return
10236       end subroutine cartder
10237 !-----------------------------------------------------------------------------
10238 ! checkder_p.F
10239 !-----------------------------------------------------------------------------
10240       subroutine check_cartgrad
10241 ! Check the gradient of Cartesian coordinates in internal coordinates.
10242 !      implicit real*8 (a-h,o-z)
10243 !      include 'DIMENSIONS'
10244 !      include 'COMMON.IOUNITS'
10245 !      include 'COMMON.VAR'
10246 !      include 'COMMON.CHAIN'
10247 !      include 'COMMON.GEO'
10248 !      include 'COMMON.LOCAL'
10249 !      include 'COMMON.DERIV'
10250       real(kind=8),dimension(6,nres) :: temp
10251       real(kind=8),dimension(3) :: xx,gg
10252       integer :: i,k,j,ii
10253       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10254 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10255 !
10256 ! Check the gradient of the virtual-bond and SC vectors in the internal
10257 ! coordinates.
10258 !
10259       aincr=1.0d-6
10260       aincr2=5.0d-7
10261       call cartder
10262       write (iout,'(a)') '**************** dx/dalpha'
10263       write (iout,'(a)')
10264       do i=2,nres-1
10265         alphi=alph(i)
10266         alph(i)=alph(i)+aincr
10267         do k=1,3
10268           temp(k,i)=dc(k,nres+i)
10269         enddo
10270         call chainbuild
10271         do k=1,3
10272           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10273           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10274         enddo
10275         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10276         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10277         write (iout,'(a)')
10278         alph(i)=alphi
10279         call chainbuild
10280       enddo
10281       write (iout,'(a)')
10282       write (iout,'(a)') '**************** dx/domega'
10283       write (iout,'(a)')
10284       do i=2,nres-1
10285         omegi=omeg(i)
10286         omeg(i)=omeg(i)+aincr
10287         do k=1,3
10288           temp(k,i)=dc(k,nres+i)
10289         enddo
10290         call chainbuild
10291         do k=1,3
10292           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10293           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10294                 (aincr*dabs(dxds(k+3,i))+aincr))
10295         enddo
10296         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10297             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10298         write (iout,'(a)')
10299         omeg(i)=omegi
10300         call chainbuild
10301       enddo
10302       write (iout,'(a)')
10303       write (iout,'(a)') '**************** dx/dtheta'
10304       write (iout,'(a)')
10305       do i=3,nres
10306         theti=theta(i)
10307         theta(i)=theta(i)+aincr
10308         do j=i-1,nres-1
10309           do k=1,3
10310             temp(k,j)=dc(k,nres+j)
10311           enddo
10312         enddo
10313         call chainbuild
10314         do j=i-1,nres-1
10315           ii = indmat(i-2,j)
10316 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10317           do k=1,3
10318             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10319             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10320                   (aincr*dabs(dxdv(k,ii))+aincr))
10321           enddo
10322           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10323               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10324           write(iout,'(a)')
10325         enddo
10326         write (iout,'(a)')
10327         theta(i)=theti
10328         call chainbuild
10329       enddo
10330       write (iout,'(a)') '***************** dx/dphi'
10331       write (iout,'(a)')
10332       do i=4,nres
10333         phi(i)=phi(i)+aincr
10334         do j=i-1,nres-1
10335           do k=1,3
10336             temp(k,j)=dc(k,nres+j)
10337           enddo
10338         enddo
10339         call chainbuild
10340         do j=i-1,nres-1
10341           ii = indmat(i-2,j)
10342 !         print *,'ii=',ii
10343           do k=1,3
10344             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10345             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10346                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10347           enddo
10348           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10349               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10350           write(iout,'(a)')
10351         enddo
10352         phi(i)=phi(i)-aincr
10353         call chainbuild
10354       enddo
10355       write (iout,'(a)') '****************** ddc/dtheta'
10356       do i=1,nres-2
10357         thet=theta(i+2)
10358         theta(i+2)=thet+aincr
10359         do j=i,nres
10360           do k=1,3
10361             temp(k,j)=dc(k,j)
10362           enddo
10363         enddo
10364         call chainbuild
10365         do j=i+1,nres-1
10366           ii = indmat(i,j)
10367 !         print *,'ii=',ii
10368           do k=1,3
10369             gg(k)=(dc(k,j)-temp(k,j))/aincr
10370             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10371                  (aincr*dabs(dcdv(k,ii))+aincr))
10372           enddo
10373           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10374                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10375           write (iout,'(a)')
10376         enddo
10377         do j=1,nres
10378           do k=1,3
10379             dc(k,j)=temp(k,j)
10380           enddo
10381         enddo
10382         theta(i+2)=thet
10383       enddo
10384       write (iout,'(a)') '******************* ddc/dphi'
10385       do i=1,nres-3
10386         phii=phi(i+3)
10387         phi(i+3)=phii+aincr
10388         do j=1,nres
10389           do k=1,3
10390             temp(k,j)=dc(k,j)
10391           enddo
10392         enddo
10393         call chainbuild
10394         do j=i+2,nres-1
10395           ii = indmat(i+1,j)
10396 !         print *,'ii=',ii
10397           do k=1,3
10398             gg(k)=(dc(k,j)-temp(k,j))/aincr
10399             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10400                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10401           enddo
10402           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10403                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10404           write (iout,'(a)')
10405         enddo
10406         do j=1,nres
10407           do k=1,3
10408             dc(k,j)=temp(k,j)
10409           enddo
10410         enddo
10411         phi(i+3)=phii
10412       enddo
10413       return
10414       end subroutine check_cartgrad
10415 !-----------------------------------------------------------------------------
10416       subroutine check_ecart
10417 ! Check the gradient of the energy in Cartesian coordinates.
10418 !     implicit real*8 (a-h,o-z)
10419 !     include 'DIMENSIONS'
10420 !     include 'COMMON.CHAIN'
10421 !     include 'COMMON.DERIV'
10422 !     include 'COMMON.IOUNITS'
10423 !     include 'COMMON.VAR'
10424 !     include 'COMMON.CONTACTS'
10425       use comm_srutu
10426 !el      integer :: icall
10427 !el      common /srutu/ icall
10428       real(kind=8),dimension(6) :: ggg
10429       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10430       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10431       real(kind=8),dimension(6,nres) :: grad_s
10432       real(kind=8),dimension(0:n_ene) :: energia,energia1
10433       integer :: uiparm(1)
10434       real(kind=8) :: urparm(1)
10435 !EL      external fdum
10436       integer :: nf,i,j,k
10437       real(kind=8) :: aincr,etot,etot1
10438       icg=1
10439       nf=0
10440       nfl=0
10441       call zerograd
10442       aincr=1.0D-5
10443       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
10444       nf=0
10445       icall=0
10446       call geom_to_var(nvar,x)
10447       call etotal(energia)
10448       etot=energia(0)
10449 !el      call enerprint(energia)
10450       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10451       icall =1
10452       do i=1,nres
10453         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10454       enddo
10455       do i=1,nres
10456         do j=1,3
10457           grad_s(j,i)=gradc(j,i,icg)
10458           grad_s(j+3,i)=gradx(j,i,icg)
10459         enddo
10460       enddo
10461       call flush(iout)
10462       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10463       do i=1,nres
10464         do j=1,3
10465           xx(j)=c(j,i+nres)
10466           ddc(j)=dc(j,i)
10467           ddx(j)=dc(j,i+nres)
10468         enddo
10469         do j=1,3
10470           dc(j,i)=dc(j,i)+aincr
10471           do k=i+1,nres
10472             c(j,k)=c(j,k)+aincr
10473             c(j,k+nres)=c(j,k+nres)+aincr
10474           enddo
10475           call etotal(energia1)
10476           etot1=energia1(0)
10477           ggg(j)=(etot1-etot)/aincr
10478           dc(j,i)=ddc(j)
10479           do k=i+1,nres
10480             c(j,k)=c(j,k)-aincr
10481             c(j,k+nres)=c(j,k+nres)-aincr
10482           enddo
10483         enddo
10484         do j=1,3
10485           c(j,i+nres)=c(j,i+nres)+aincr
10486           dc(j,i+nres)=dc(j,i+nres)+aincr
10487           call etotal(energia1)
10488           etot1=energia1(0)
10489           ggg(j+3)=(etot1-etot)/aincr
10490           c(j,i+nres)=xx(j)
10491           dc(j,i+nres)=ddx(j)
10492         enddo
10493         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10494          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10495       enddo
10496       return
10497       end subroutine check_ecart
10498 #ifdef CARGRAD
10499 !-----------------------------------------------------------------------------
10500       subroutine check_ecartint
10501 ! Check the gradient of the energy in Cartesian coordinates.
10502       use io_base, only: intout
10503 !      implicit real*8 (a-h,o-z)
10504 !      include 'DIMENSIONS'
10505 !      include 'COMMON.CONTROL'
10506 !      include 'COMMON.CHAIN'
10507 !      include 'COMMON.DERIV'
10508 !      include 'COMMON.IOUNITS'
10509 !      include 'COMMON.VAR'
10510 !      include 'COMMON.CONTACTS'
10511 !      include 'COMMON.MD'
10512 !      include 'COMMON.LOCAL'
10513 !      include 'COMMON.SPLITELE'
10514       use comm_srutu
10515 !el      integer :: icall
10516 !el      common /srutu/ icall
10517       real(kind=8),dimension(6) :: ggg,ggg1
10518       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10519       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10520       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10521       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10522       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10523       real(kind=8),dimension(0:n_ene) :: energia,energia1
10524       integer :: uiparm(1)
10525       real(kind=8) :: urparm(1)
10526 !EL      external fdum
10527       integer :: i,j,k,nf
10528       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10529                    etot21,etot22
10530       r_cut=2.0d0
10531       rlambd=0.3d0
10532       icg=1
10533       nf=0
10534       nfl=0
10535       call intout
10536 !      call intcartderiv
10537 !      call checkintcartgrad
10538       call zerograd
10539       aincr=1.0D-5
10540       write(iout,*) 'Calling CHECK_ECARTINT.'
10541       nf=0
10542       icall=0
10543       write (iout,*) "Before geom_to_var"
10544       call geom_to_var(nvar,x)
10545       write (iout,*) "after geom_to_var"
10546       write (iout,*) "split_ene ",split_ene
10547       call flush(iout)
10548       if (.not.split_ene) then
10549         write(iout,*) 'Calling CHECK_ECARTINT if'
10550         call etotal(energia)
10551 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10552         etot=energia(0)
10553         write (iout,*) "etot",etot
10554         call flush(iout)
10555 !el        call enerprint(energia)
10556 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10557         call flush(iout)
10558         write (iout,*) "enter cartgrad"
10559         call flush(iout)
10560         call cartgrad
10561 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10562         write (iout,*) "exit cartgrad"
10563         call flush(iout)
10564         icall =1
10565         do i=1,nres
10566           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10567         enddo
10568         do j=1,3
10569           grad_s(j,0)=gcart(j,0)
10570         enddo
10571 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10572         do i=1,nres
10573           do j=1,3
10574             grad_s(j,i)=gcart(j,i)
10575             grad_s(j+3,i)=gxcart(j,i)
10576           enddo
10577         enddo
10578       else
10579 write(iout,*) 'Calling CHECK_ECARTIN else.'
10580 !- split gradient check
10581         call zerograd
10582         call etotal_long(energia)
10583 !el        call enerprint(energia)
10584         call flush(iout)
10585         write (iout,*) "enter cartgrad"
10586         call flush(iout)
10587         call cartgrad
10588         write (iout,*) "exit cartgrad"
10589         call flush(iout)
10590         icall =1
10591         write (iout,*) "longrange grad"
10592         do i=1,nres
10593           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10594           (gxcart(j,i),j=1,3)
10595         enddo
10596         do j=1,3
10597           grad_s(j,0)=gcart(j,0)
10598         enddo
10599         do i=1,nres
10600           do j=1,3
10601             grad_s(j,i)=gcart(j,i)
10602             grad_s(j+3,i)=gxcart(j,i)
10603           enddo
10604         enddo
10605         call zerograd
10606         call etotal_short(energia)
10607 !el        call enerprint(energia)
10608         call flush(iout)
10609         write (iout,*) "enter cartgrad"
10610         call flush(iout)
10611         call cartgrad
10612         write (iout,*) "exit cartgrad"
10613         call flush(iout)
10614         icall =1
10615         write (iout,*) "shortrange grad"
10616         do i=1,nres
10617           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10618           (gxcart(j,i),j=1,3)
10619         enddo
10620         do j=1,3
10621           grad_s1(j,0)=gcart(j,0)
10622         enddo
10623         do i=1,nres
10624           do j=1,3
10625             grad_s1(j,i)=gcart(j,i)
10626             grad_s1(j+3,i)=gxcart(j,i)
10627           enddo
10628         enddo
10629       endif
10630       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10631 !      do i=1,nres
10632       do i=nnt,nct
10633         do j=1,3
10634           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10635           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10636           ddc(j)=c(j,i)
10637           ddx(j)=c(j,i+nres)
10638           dcnorm_safe1(j)=dc_norm(j,i-1)
10639           dcnorm_safe2(j)=dc_norm(j,i)
10640           dxnorm_safe(j)=dc_norm(j,i+nres)
10641         enddo
10642         do j=1,3
10643           c(j,i)=ddc(j)+aincr
10644           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10645           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10646           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10647           dc(j,i)=c(j,i+1)-c(j,i)
10648           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10649           call int_from_cart1(.false.)
10650           if (.not.split_ene) then
10651             call etotal(energia1)
10652             etot1=energia1(0)
10653             write (iout,*) "ij",i,j," etot1",etot1
10654           else
10655 !- split gradient
10656             call etotal_long(energia1)
10657             etot11=energia1(0)
10658             call etotal_short(energia1)
10659             etot12=energia1(0)
10660           endif
10661 !- end split gradient
10662 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10663           c(j,i)=ddc(j)-aincr
10664           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10665           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10666           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10667           dc(j,i)=c(j,i+1)-c(j,i)
10668           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10669           call int_from_cart1(.false.)
10670           if (.not.split_ene) then
10671             call etotal(energia1)
10672             etot2=energia1(0)
10673             write (iout,*) "ij",i,j," etot2",etot2
10674             ggg(j)=(etot1-etot2)/(2*aincr)
10675           else
10676 !- split gradient
10677             call etotal_long(energia1)
10678             etot21=energia1(0)
10679             ggg(j)=(etot11-etot21)/(2*aincr)
10680             call etotal_short(energia1)
10681             etot22=energia1(0)
10682             ggg1(j)=(etot12-etot22)/(2*aincr)
10683 !- end split gradient
10684 !            write (iout,*) "etot21",etot21," etot22",etot22
10685           endif
10686 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10687           c(j,i)=ddc(j)
10688           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10689           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10690           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10691           dc(j,i)=c(j,i+1)-c(j,i)
10692           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10693           dc_norm(j,i-1)=dcnorm_safe1(j)
10694           dc_norm(j,i)=dcnorm_safe2(j)
10695           dc_norm(j,i+nres)=dxnorm_safe(j)
10696         enddo
10697         do j=1,3
10698           c(j,i+nres)=ddx(j)+aincr
10699           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10700           call int_from_cart1(.false.)
10701           if (.not.split_ene) then
10702             call etotal(energia1)
10703             etot1=energia1(0)
10704           else
10705 !- split gradient
10706             call etotal_long(energia1)
10707             etot11=energia1(0)
10708             call etotal_short(energia1)
10709             etot12=energia1(0)
10710           endif
10711 !- end split gradient
10712           c(j,i+nres)=ddx(j)-aincr
10713           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10714           call int_from_cart1(.false.)
10715           if (.not.split_ene) then
10716             call etotal(energia1)
10717             etot2=energia1(0)
10718             ggg(j+3)=(etot1-etot2)/(2*aincr)
10719           else
10720 !- split gradient
10721             call etotal_long(energia1)
10722             etot21=energia1(0)
10723             ggg(j+3)=(etot11-etot21)/(2*aincr)
10724             call etotal_short(energia1)
10725             etot22=energia1(0)
10726             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10727 !- end split gradient
10728           endif
10729 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10730           c(j,i+nres)=ddx(j)
10731           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10732           dc_norm(j,i+nres)=dxnorm_safe(j)
10733           call int_from_cart1(.false.)
10734         enddo
10735         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10736          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10737         if (split_ene) then
10738           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10739          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10740          k=1,6)
10741          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10742          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10743          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10744         endif
10745       enddo
10746       return
10747       end subroutine check_ecartint
10748 #else
10749 !-----------------------------------------------------------------------------
10750       subroutine check_ecartint
10751 ! Check the gradient of the energy in Cartesian coordinates.
10752       use io_base, only: intout
10753 !      implicit real*8 (a-h,o-z)
10754 !      include 'DIMENSIONS'
10755 !      include 'COMMON.CONTROL'
10756 !      include 'COMMON.CHAIN'
10757 !      include 'COMMON.DERIV'
10758 !      include 'COMMON.IOUNITS'
10759 !      include 'COMMON.VAR'
10760 !      include 'COMMON.CONTACTS'
10761 !      include 'COMMON.MD'
10762 !      include 'COMMON.LOCAL'
10763 !      include 'COMMON.SPLITELE'
10764       use comm_srutu
10765 !el      integer :: icall
10766 !el      common /srutu/ icall
10767       real(kind=8),dimension(6) :: ggg,ggg1
10768       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10769       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10770       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10771       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10772       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10773       real(kind=8),dimension(0:n_ene) :: energia,energia1
10774       integer :: uiparm(1)
10775       real(kind=8) :: urparm(1)
10776 !EL      external fdum
10777       integer :: i,j,k,nf
10778       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10779                    etot21,etot22
10780       r_cut=2.0d0
10781       rlambd=0.3d0
10782       icg=1
10783       nf=0
10784       nfl=0
10785       call intout
10786 !      call intcartderiv
10787 !      call checkintcartgrad
10788       call zerograd
10789       aincr=2.0D-5
10790       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
10791       nf=0
10792       icall=0
10793       call geom_to_var(nvar,x)
10794       if (.not.split_ene) then
10795         call etotal(energia)
10796         etot=energia(0)
10797 !el        call enerprint(energia)
10798         call flush(iout)
10799         write (iout,*) "enter cartgrad"
10800         call flush(iout)
10801         call cartgrad
10802         write (iout,*) "exit cartgrad"
10803         call flush(iout)
10804         icall =1
10805         do i=1,nres
10806           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10807         enddo
10808         do j=1,3
10809           grad_s(j,0)=gcart(j,0)
10810         enddo
10811         do i=1,nres
10812           do j=1,3
10813             grad_s(j,i)=gcart(j,i)
10814             grad_s(j+3,i)=gxcart(j,i)
10815           enddo
10816         enddo
10817       else
10818 !- split gradient check
10819         call zerograd
10820         call etotal_long(energia)
10821 !el        call enerprint(energia)
10822         call flush(iout)
10823         write (iout,*) "enter cartgrad"
10824         call flush(iout)
10825         call cartgrad
10826         write (iout,*) "exit cartgrad"
10827         call flush(iout)
10828         icall =1
10829         write (iout,*) "longrange grad"
10830         do i=1,nres
10831           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10832           (gxcart(j,i),j=1,3)
10833         enddo
10834         do j=1,3
10835           grad_s(j,0)=gcart(j,0)
10836         enddo
10837         do i=1,nres
10838           do j=1,3
10839             grad_s(j,i)=gcart(j,i)
10840             grad_s(j+3,i)=gxcart(j,i)
10841           enddo
10842         enddo
10843         call zerograd
10844         call etotal_short(energia)
10845 !el        call enerprint(energia)
10846         call flush(iout)
10847         write (iout,*) "enter cartgrad"
10848         call flush(iout)
10849         call cartgrad
10850         write (iout,*) "exit cartgrad"
10851         call flush(iout)
10852         icall =1
10853         write (iout,*) "shortrange grad"
10854         do i=1,nres
10855           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10856           (gxcart(j,i),j=1,3)
10857         enddo
10858         do j=1,3
10859           grad_s1(j,0)=gcart(j,0)
10860         enddo
10861         do i=1,nres
10862           do j=1,3
10863             grad_s1(j,i)=gcart(j,i)
10864             grad_s1(j+3,i)=gxcart(j,i)
10865           enddo
10866         enddo
10867       endif
10868       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10869       do i=0,nres
10870         do j=1,3
10871           xx(j)=c(j,i+nres)
10872           ddc(j)=dc(j,i)
10873           ddx(j)=dc(j,i+nres)
10874           do k=1,3
10875             dcnorm_safe(k)=dc_norm(k,i)
10876             dxnorm_safe(k)=dc_norm(k,i+nres)
10877           enddo
10878         enddo
10879         do j=1,3
10880           dc(j,i)=ddc(j)+aincr
10881           call chainbuild_cart
10882 #ifdef MPI
10883 ! Broadcast the order to compute internal coordinates to the slaves.
10884 !          if (nfgtasks.gt.1)
10885 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10886 #endif
10887 !          call int_from_cart1(.false.)
10888           if (.not.split_ene) then
10889             call etotal(energia1)
10890             etot1=energia1(0)
10891           else
10892 !- split gradient
10893             call etotal_long(energia1)
10894             etot11=energia1(0)
10895             call etotal_short(energia1)
10896             etot12=energia1(0)
10897 !            write (iout,*) "etot11",etot11," etot12",etot12
10898           endif
10899 !- end split gradient
10900 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10901           dc(j,i)=ddc(j)-aincr
10902           call chainbuild_cart
10903 !          call int_from_cart1(.false.)
10904           if (.not.split_ene) then
10905             call etotal(energia1)
10906             etot2=energia1(0)
10907             ggg(j)=(etot1-etot2)/(2*aincr)
10908           else
10909 !- split gradient
10910             call etotal_long(energia1)
10911             etot21=energia1(0)
10912             ggg(j)=(etot11-etot21)/(2*aincr)
10913             call etotal_short(energia1)
10914             etot22=energia1(0)
10915             ggg1(j)=(etot12-etot22)/(2*aincr)
10916 !- end split gradient
10917 !            write (iout,*) "etot21",etot21," etot22",etot22
10918           endif
10919 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10920           dc(j,i)=ddc(j)
10921           call chainbuild_cart
10922         enddo
10923         do j=1,3
10924           dc(j,i+nres)=ddx(j)+aincr
10925           call chainbuild_cart
10926 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10927 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10928 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10929 !          write (iout,*) "dxnormnorm",dsqrt(
10930 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10931 !          write (iout,*) "dxnormnormsafe",dsqrt(
10932 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10933 !          write (iout,*)
10934           if (.not.split_ene) then
10935             call etotal(energia1)
10936             etot1=energia1(0)
10937           else
10938 !- split gradient
10939             call etotal_long(energia1)
10940             etot11=energia1(0)
10941             call etotal_short(energia1)
10942             etot12=energia1(0)
10943           endif
10944 !- end split gradient
10945 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10946           dc(j,i+nres)=ddx(j)-aincr
10947           call chainbuild_cart
10948 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10949 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10950 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10951 !          write (iout,*)
10952 !          write (iout,*) "dxnormnorm",dsqrt(
10953 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10954 !          write (iout,*) "dxnormnormsafe",dsqrt(
10955 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10956           if (.not.split_ene) then
10957             call etotal(energia1)
10958             etot2=energia1(0)
10959             ggg(j+3)=(etot1-etot2)/(2*aincr)
10960           else
10961 !- split gradient
10962             call etotal_long(energia1)
10963             etot21=energia1(0)
10964             ggg(j+3)=(etot11-etot21)/(2*aincr)
10965             call etotal_short(energia1)
10966             etot22=energia1(0)
10967             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10968 !- end split gradient
10969           endif
10970 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10971           dc(j,i+nres)=ddx(j)
10972           call chainbuild_cart
10973         enddo
10974         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10975          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10976         if (split_ene) then
10977           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10978          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10979          k=1,6)
10980          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10981          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10982          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10983         endif
10984       enddo
10985       return
10986       end subroutine check_ecartint
10987 #endif
10988 !-----------------------------------------------------------------------------
10989       subroutine check_eint
10990 ! Check the gradient of energy in internal coordinates.
10991 !      implicit real*8 (a-h,o-z)
10992 !      include 'DIMENSIONS'
10993 !      include 'COMMON.CHAIN'
10994 !      include 'COMMON.DERIV'
10995 !      include 'COMMON.IOUNITS'
10996 !      include 'COMMON.VAR'
10997 !      include 'COMMON.GEO'
10998       use comm_srutu
10999 !el      integer :: icall
11000 !el      common /srutu/ icall
11001       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11002       integer :: uiparm(1)
11003       real(kind=8) :: urparm(1)
11004       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11005       character(len=6) :: key
11006 !EL      external fdum
11007       integer :: i,ii,nf
11008       real(kind=8) :: xi,aincr,etot,etot1,etot2
11009       call zerograd
11010       aincr=1.0D-7
11011       print '(a)','Calling CHECK_INT.'
11012       nf=0
11013       nfl=0
11014       icg=1
11015       call geom_to_var(nvar,x)
11016       call var_to_geom(nvar,x)
11017       call chainbuild
11018       icall=1
11019       print *,'ICG=',ICG
11020       call etotal(energia)
11021       etot = energia(0)
11022 !el      call enerprint(energia)
11023       print *,'ICG=',ICG
11024 #ifdef MPL
11025       if (MyID.ne.BossID) then
11026         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11027         nf=x(nvar+1)
11028         nfl=x(nvar+2)
11029         icg=x(nvar+3)
11030       endif
11031 #endif
11032       nf=1
11033       nfl=3
11034 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11035       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11036 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11037       icall=1
11038       do i=1,nvar
11039         xi=x(i)
11040         x(i)=xi-0.5D0*aincr
11041         call var_to_geom(nvar,x)
11042         call chainbuild
11043         call etotal(energia1)
11044         etot1=energia1(0)
11045         x(i)=xi+0.5D0*aincr
11046         call var_to_geom(nvar,x)
11047         call chainbuild
11048         call etotal(energia2)
11049         etot2=energia2(0)
11050         gg(i)=(etot2-etot1)/aincr
11051         write (iout,*) i,etot1,etot2
11052         x(i)=xi
11053       enddo
11054       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11055           '     RelDiff*100% '
11056       do i=1,nvar
11057         if (i.le.nphi) then
11058           ii=i
11059           key = ' phi'
11060         else if (i.le.nphi+ntheta) then
11061           ii=i-nphi
11062           key=' theta'
11063         else if (i.le.nphi+ntheta+nside) then
11064            ii=i-(nphi+ntheta)
11065            key=' alpha'
11066         else
11067            ii=i-(nphi+ntheta+nside)
11068            key=' omega'
11069         endif
11070         write (iout,'(i3,a,i3,3(1pd16.6))') &
11071        i,key,ii,gg(i),gana(i),&
11072        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11073       enddo
11074       return
11075       end subroutine check_eint
11076 !-----------------------------------------------------------------------------
11077 ! econstr_local.F
11078 !-----------------------------------------------------------------------------
11079       subroutine Econstr_back
11080 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11081 !      implicit real*8 (a-h,o-z)
11082 !      include 'DIMENSIONS'
11083 !      include 'COMMON.CONTROL'
11084 !      include 'COMMON.VAR'
11085 !      include 'COMMON.MD'
11086       use MD_data
11087 !#ifndef LANG0
11088 !      include 'COMMON.LANGEVIN'
11089 !#else
11090 !      include 'COMMON.LANGEVIN.lang0'
11091 !#endif
11092 !      include 'COMMON.CHAIN'
11093 !      include 'COMMON.DERIV'
11094 !      include 'COMMON.GEO'
11095 !      include 'COMMON.LOCAL'
11096 !      include 'COMMON.INTERACT'
11097 !      include 'COMMON.IOUNITS'
11098 !      include 'COMMON.NAMES'
11099 !      include 'COMMON.TIME1'
11100       integer :: i,j,ii,k
11101       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11102
11103       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11104       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11105       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11106
11107       Uconst_back=0.0d0
11108       do i=1,nres
11109         dutheta(i)=0.0d0
11110         dugamma(i)=0.0d0
11111         do j=1,3
11112           duscdiff(j,i)=0.0d0
11113           duscdiffx(j,i)=0.0d0
11114         enddo
11115       enddo
11116       do i=1,nfrag_back
11117         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11118 !
11119 ! Deviations from theta angles
11120 !
11121         utheta_i=0.0d0
11122         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11123           dtheta_i=theta(j)-thetaref(j)
11124           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11125           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11126         enddo
11127         utheta(i)=utheta_i/(ii-1)
11128 !
11129 ! Deviations from gamma angles
11130 !
11131         ugamma_i=0.0d0
11132         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11133           dgamma_i=pinorm(phi(j)-phiref(j))
11134 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11135           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11136           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11137 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11138         enddo
11139         ugamma(i)=ugamma_i/(ii-2)
11140 !
11141 ! Deviations from local SC geometry
11142 !
11143         uscdiff(i)=0.0d0
11144         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11145           dxx=xxtab(j)-xxref(j)
11146           dyy=yytab(j)-yyref(j)
11147           dzz=zztab(j)-zzref(j)
11148           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11149           do k=1,3
11150             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11151              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11152              (ii-1)
11153             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11154              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11155              (ii-1)
11156             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11157            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11158             /(ii-1)
11159           enddo
11160 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11161 !     &      xxref(j),yyref(j),zzref(j)
11162         enddo
11163         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11164 !        write (iout,*) i," uscdiff",uscdiff(i)
11165 !
11166 ! Put together deviations from local geometry
11167 !
11168         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11169           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11170 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11171 !     &   " uconst_back",uconst_back
11172         utheta(i)=dsqrt(utheta(i))
11173         ugamma(i)=dsqrt(ugamma(i))
11174         uscdiff(i)=dsqrt(uscdiff(i))
11175       enddo
11176       return
11177       end subroutine Econstr_back
11178 !-----------------------------------------------------------------------------
11179 ! energy_p_new-sep_barrier.F
11180 !-----------------------------------------------------------------------------
11181       real(kind=8) function sscale(r)
11182 !      include "COMMON.SPLITELE"
11183       real(kind=8) :: r,gamm
11184       if(r.lt.r_cut-rlamb) then
11185         sscale=1.0d0
11186       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11187         gamm=(r-(r_cut-rlamb))/rlamb
11188         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11189       else
11190         sscale=0d0
11191       endif
11192       return
11193       end function sscale
11194       real(kind=8) function sscale_grad(r)
11195 !      include "COMMON.SPLITELE"
11196       real(kind=8) :: r,gamm
11197       if(r.lt.r_cut-rlamb) then
11198         sscale_grad=0.0d0
11199       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11200         gamm=(r-(r_cut-rlamb))/rlamb
11201         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11202       else
11203         sscale_grad=0d0
11204       endif
11205       return
11206       end function sscale_grad
11207
11208 !!!!!!!!!! PBCSCALE
11209       real(kind=8) function sscale_ele(r)
11210 !      include "COMMON.SPLITELE"
11211       real(kind=8) :: r,gamm
11212       if(r.lt.r_cut_ele-rlamb_ele) then
11213         sscale_ele=1.0d0
11214       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11215         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11216         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11217       else
11218         sscale_ele=0d0
11219       endif
11220       return
11221       end function sscale_ele
11222
11223       real(kind=8)  function sscagrad_ele(r)
11224       real(kind=8) :: r,gamm
11225 !      include "COMMON.SPLITELE"
11226       if(r.lt.r_cut_ele-rlamb_ele) then
11227         sscagrad_ele=0.0d0
11228       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11229         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11230         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11231       else
11232         sscagrad_ele=0.0d0
11233       endif
11234       return
11235       end function sscagrad_ele
11236 !!!!!!!!!!!!!!!
11237 !-----------------------------------------------------------------------------
11238       subroutine elj_long(evdw)
11239 !
11240 ! This subroutine calculates the interaction energy of nonbonded side chains
11241 ! assuming the LJ potential of interaction.
11242 !
11243 !      implicit real*8 (a-h,o-z)
11244 !      include 'DIMENSIONS'
11245 !      include 'COMMON.GEO'
11246 !      include 'COMMON.VAR'
11247 !      include 'COMMON.LOCAL'
11248 !      include 'COMMON.CHAIN'
11249 !      include 'COMMON.DERIV'
11250 !      include 'COMMON.INTERACT'
11251 !      include 'COMMON.TORSION'
11252 !      include 'COMMON.SBRIDGE'
11253 !      include 'COMMON.NAMES'
11254 !      include 'COMMON.IOUNITS'
11255 !      include 'COMMON.CONTACTS'
11256       real(kind=8),parameter :: accur=1.0d-10
11257       real(kind=8),dimension(3) :: gg
11258 !el local variables
11259       integer :: i,iint,j,k,itypi,itypi1,itypj
11260       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11261       real(kind=8) :: e1,e2,evdwij,evdw
11262 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11263       evdw=0.0D0
11264       do i=iatsc_s,iatsc_e
11265         itypi=itype(i)
11266         if (itypi.eq.ntyp1) cycle
11267         itypi1=itype(i+1)
11268         xi=c(1,nres+i)
11269         yi=c(2,nres+i)
11270         zi=c(3,nres+i)
11271 !
11272 ! Calculate SC interaction energy.
11273 !
11274         do iint=1,nint_gr(i)
11275 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11276 !d   &                  'iend=',iend(i,iint)
11277           do j=istart(i,iint),iend(i,iint)
11278             itypj=itype(j)
11279             if (itypj.eq.ntyp1) cycle
11280             xj=c(1,nres+j)-xi
11281             yj=c(2,nres+j)-yi
11282             zj=c(3,nres+j)-zi
11283             rij=xj*xj+yj*yj+zj*zj
11284             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11285             if (sss.lt.1.0d0) then
11286               rrij=1.0D0/rij
11287               eps0ij=eps(itypi,itypj)
11288               fac=rrij**expon2
11289               e1=fac*fac*aa(itypi,itypj)
11290               e2=fac*bb(itypi,itypj)
11291               evdwij=e1+e2
11292               evdw=evdw+(1.0d0-sss)*evdwij
11293 !
11294 ! Calculate the components of the gradient in DC and X
11295 !
11296               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11297               gg(1)=xj*fac
11298               gg(2)=yj*fac
11299               gg(3)=zj*fac
11300               do k=1,3
11301                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11302                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11303                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11304                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11305               enddo
11306             endif
11307           enddo      ! j
11308         enddo        ! iint
11309       enddo          ! i
11310       do i=1,nct
11311         do j=1,3
11312           gvdwc(j,i)=expon*gvdwc(j,i)
11313           gvdwx(j,i)=expon*gvdwx(j,i)
11314         enddo
11315       enddo
11316 !******************************************************************************
11317 !
11318 !                              N O T E !!!
11319 !
11320 ! To save time, the factor of EXPON has been extracted from ALL components
11321 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11322 ! use!
11323 !
11324 !******************************************************************************
11325       return
11326       end subroutine elj_long
11327 !-----------------------------------------------------------------------------
11328       subroutine elj_short(evdw)
11329 !
11330 ! This subroutine calculates the interaction energy of nonbonded side chains
11331 ! assuming the LJ potential of interaction.
11332 !
11333 !      implicit real*8 (a-h,o-z)
11334 !      include 'DIMENSIONS'
11335 !      include 'COMMON.GEO'
11336 !      include 'COMMON.VAR'
11337 !      include 'COMMON.LOCAL'
11338 !      include 'COMMON.CHAIN'
11339 !      include 'COMMON.DERIV'
11340 !      include 'COMMON.INTERACT'
11341 !      include 'COMMON.TORSION'
11342 !      include 'COMMON.SBRIDGE'
11343 !      include 'COMMON.NAMES'
11344 !      include 'COMMON.IOUNITS'
11345 !      include 'COMMON.CONTACTS'
11346       real(kind=8),parameter :: accur=1.0d-10
11347       real(kind=8),dimension(3) :: gg
11348 !el local variables
11349       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11350       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11351       real(kind=8) :: e1,e2,evdwij,evdw
11352 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11353       evdw=0.0D0
11354       do i=iatsc_s,iatsc_e
11355         itypi=itype(i)
11356         if (itypi.eq.ntyp1) cycle
11357         itypi1=itype(i+1)
11358         xi=c(1,nres+i)
11359         yi=c(2,nres+i)
11360         zi=c(3,nres+i)
11361 ! Change 12/1/95
11362         num_conti=0
11363 !
11364 ! Calculate SC interaction energy.
11365 !
11366         do iint=1,nint_gr(i)
11367 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11368 !d   &                  'iend=',iend(i,iint)
11369           do j=istart(i,iint),iend(i,iint)
11370             itypj=itype(j)
11371             if (itypj.eq.ntyp1) cycle
11372             xj=c(1,nres+j)-xi
11373             yj=c(2,nres+j)-yi
11374             zj=c(3,nres+j)-zi
11375 ! Change 12/1/95 to calculate four-body interactions
11376             rij=xj*xj+yj*yj+zj*zj
11377             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11378             if (sss.gt.0.0d0) then
11379               rrij=1.0D0/rij
11380               eps0ij=eps(itypi,itypj)
11381               fac=rrij**expon2
11382               e1=fac*fac*aa(itypi,itypj)
11383               e2=fac*bb(itypi,itypj)
11384               evdwij=e1+e2
11385               evdw=evdw+sss*evdwij
11386 !
11387 ! Calculate the components of the gradient in DC and X
11388 !
11389               fac=-rrij*(e1+evdwij)*sss
11390               gg(1)=xj*fac
11391               gg(2)=yj*fac
11392               gg(3)=zj*fac
11393               do k=1,3
11394                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11395                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11396                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11397                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11398               enddo
11399             endif
11400           enddo      ! j
11401         enddo        ! iint
11402       enddo          ! i
11403       do i=1,nct
11404         do j=1,3
11405           gvdwc(j,i)=expon*gvdwc(j,i)
11406           gvdwx(j,i)=expon*gvdwx(j,i)
11407         enddo
11408       enddo
11409 !******************************************************************************
11410 !
11411 !                              N O T E !!!
11412 !
11413 ! To save time, the factor of EXPON has been extracted from ALL components
11414 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11415 ! use!
11416 !
11417 !******************************************************************************
11418       return
11419       end subroutine elj_short
11420 !-----------------------------------------------------------------------------
11421       subroutine eljk_long(evdw)
11422 !
11423 ! This subroutine calculates the interaction energy of nonbonded side chains
11424 ! assuming the LJK potential of interaction.
11425 !
11426 !      implicit real*8 (a-h,o-z)
11427 !      include 'DIMENSIONS'
11428 !      include 'COMMON.GEO'
11429 !      include 'COMMON.VAR'
11430 !      include 'COMMON.LOCAL'
11431 !      include 'COMMON.CHAIN'
11432 !      include 'COMMON.DERIV'
11433 !      include 'COMMON.INTERACT'
11434 !      include 'COMMON.IOUNITS'
11435 !      include 'COMMON.NAMES'
11436       real(kind=8),dimension(3) :: gg
11437       logical :: scheck
11438 !el local variables
11439       integer :: i,iint,j,k,itypi,itypi1,itypj
11440       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11441                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11442 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11443       evdw=0.0D0
11444       do i=iatsc_s,iatsc_e
11445         itypi=itype(i)
11446         if (itypi.eq.ntyp1) cycle
11447         itypi1=itype(i+1)
11448         xi=c(1,nres+i)
11449         yi=c(2,nres+i)
11450         zi=c(3,nres+i)
11451 !
11452 ! Calculate SC interaction energy.
11453 !
11454         do iint=1,nint_gr(i)
11455           do j=istart(i,iint),iend(i,iint)
11456             itypj=itype(j)
11457             if (itypj.eq.ntyp1) cycle
11458             xj=c(1,nres+j)-xi
11459             yj=c(2,nres+j)-yi
11460             zj=c(3,nres+j)-zi
11461             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11462             fac_augm=rrij**expon
11463             e_augm=augm(itypi,itypj)*fac_augm
11464             r_inv_ij=dsqrt(rrij)
11465             rij=1.0D0/r_inv_ij
11466             sss=sscale(rij/sigma(itypi,itypj))
11467             if (sss.lt.1.0d0) then
11468               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11469               fac=r_shift_inv**expon
11470               e1=fac*fac*aa(itypi,itypj)
11471               e2=fac*bb(itypi,itypj)
11472               evdwij=e_augm+e1+e2
11473 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11474 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11475 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11476 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11477 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11478 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11479 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11480               evdw=evdw+(1.0d0-sss)*evdwij
11481 !
11482 ! Calculate the components of the gradient in DC and X
11483 !
11484               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11485               fac=fac*(1.0d0-sss)
11486               gg(1)=xj*fac
11487               gg(2)=yj*fac
11488               gg(3)=zj*fac
11489               do k=1,3
11490                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11491                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11492                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11493                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11494               enddo
11495             endif
11496           enddo      ! j
11497         enddo        ! iint
11498       enddo          ! i
11499       do i=1,nct
11500         do j=1,3
11501           gvdwc(j,i)=expon*gvdwc(j,i)
11502           gvdwx(j,i)=expon*gvdwx(j,i)
11503         enddo
11504       enddo
11505       return
11506       end subroutine eljk_long
11507 !-----------------------------------------------------------------------------
11508       subroutine eljk_short(evdw)
11509 !
11510 ! This subroutine calculates the interaction energy of nonbonded side chains
11511 ! assuming the LJK potential of interaction.
11512 !
11513 !      implicit real*8 (a-h,o-z)
11514 !      include 'DIMENSIONS'
11515 !      include 'COMMON.GEO'
11516 !      include 'COMMON.VAR'
11517 !      include 'COMMON.LOCAL'
11518 !      include 'COMMON.CHAIN'
11519 !      include 'COMMON.DERIV'
11520 !      include 'COMMON.INTERACT'
11521 !      include 'COMMON.IOUNITS'
11522 !      include 'COMMON.NAMES'
11523       real(kind=8),dimension(3) :: gg
11524       logical :: scheck
11525 !el local variables
11526       integer :: i,iint,j,k,itypi,itypi1,itypj
11527       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11528                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11529 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11530       evdw=0.0D0
11531       do i=iatsc_s,iatsc_e
11532         itypi=itype(i)
11533         if (itypi.eq.ntyp1) cycle
11534         itypi1=itype(i+1)
11535         xi=c(1,nres+i)
11536         yi=c(2,nres+i)
11537         zi=c(3,nres+i)
11538 !
11539 ! Calculate SC interaction energy.
11540 !
11541         do iint=1,nint_gr(i)
11542           do j=istart(i,iint),iend(i,iint)
11543             itypj=itype(j)
11544             if (itypj.eq.ntyp1) cycle
11545             xj=c(1,nres+j)-xi
11546             yj=c(2,nres+j)-yi
11547             zj=c(3,nres+j)-zi
11548             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11549             fac_augm=rrij**expon
11550             e_augm=augm(itypi,itypj)*fac_augm
11551             r_inv_ij=dsqrt(rrij)
11552             rij=1.0D0/r_inv_ij
11553             sss=sscale(rij/sigma(itypi,itypj))
11554             if (sss.gt.0.0d0) then
11555               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11556               fac=r_shift_inv**expon
11557               e1=fac*fac*aa(itypi,itypj)
11558               e2=fac*bb(itypi,itypj)
11559               evdwij=e_augm+e1+e2
11560 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11561 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11562 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11563 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11564 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11565 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11566 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11567               evdw=evdw+sss*evdwij
11568 !
11569 ! Calculate the components of the gradient in DC and X
11570 !
11571               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11572               fac=fac*sss
11573               gg(1)=xj*fac
11574               gg(2)=yj*fac
11575               gg(3)=zj*fac
11576               do k=1,3
11577                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11578                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11579                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11580                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11581               enddo
11582             endif
11583           enddo      ! j
11584         enddo        ! iint
11585       enddo          ! i
11586       do i=1,nct
11587         do j=1,3
11588           gvdwc(j,i)=expon*gvdwc(j,i)
11589           gvdwx(j,i)=expon*gvdwx(j,i)
11590         enddo
11591       enddo
11592       return
11593       end subroutine eljk_short
11594 !-----------------------------------------------------------------------------
11595       subroutine ebp_long(evdw)
11596 !
11597 ! This subroutine calculates the interaction energy of nonbonded side chains
11598 ! assuming the Berne-Pechukas potential of interaction.
11599 !
11600       use calc_data
11601 !      implicit real*8 (a-h,o-z)
11602 !      include 'DIMENSIONS'
11603 !      include 'COMMON.GEO'
11604 !      include 'COMMON.VAR'
11605 !      include 'COMMON.LOCAL'
11606 !      include 'COMMON.CHAIN'
11607 !      include 'COMMON.DERIV'
11608 !      include 'COMMON.NAMES'
11609 !      include 'COMMON.INTERACT'
11610 !      include 'COMMON.IOUNITS'
11611 !      include 'COMMON.CALC'
11612       use comm_srutu
11613 !el      integer :: icall
11614 !el      common /srutu/ icall
11615 !     double precision rrsave(maxdim)
11616       logical :: lprn
11617 !el local variables
11618       integer :: iint,itypi,itypi1,itypj
11619       real(kind=8) :: rrij,xi,yi,zi,fac
11620       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11621       evdw=0.0D0
11622 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11623       evdw=0.0D0
11624 !     if (icall.eq.0) then
11625 !       lprn=.true.
11626 !     else
11627         lprn=.false.
11628 !     endif
11629 !el      ind=0
11630       do i=iatsc_s,iatsc_e
11631         itypi=itype(i)
11632         if (itypi.eq.ntyp1) cycle
11633         itypi1=itype(i+1)
11634         xi=c(1,nres+i)
11635         yi=c(2,nres+i)
11636         zi=c(3,nres+i)
11637         dxi=dc_norm(1,nres+i)
11638         dyi=dc_norm(2,nres+i)
11639         dzi=dc_norm(3,nres+i)
11640 !        dsci_inv=dsc_inv(itypi)
11641         dsci_inv=vbld_inv(i+nres)
11642 !
11643 ! Calculate SC interaction energy.
11644 !
11645         do iint=1,nint_gr(i)
11646           do j=istart(i,iint),iend(i,iint)
11647 !el            ind=ind+1
11648             itypj=itype(j)
11649             if (itypj.eq.ntyp1) cycle
11650 !            dscj_inv=dsc_inv(itypj)
11651             dscj_inv=vbld_inv(j+nres)
11652             chi1=chi(itypi,itypj)
11653             chi2=chi(itypj,itypi)
11654             chi12=chi1*chi2
11655             chip1=chip(itypi)
11656             chip2=chip(itypj)
11657             chip12=chip1*chip2
11658             alf1=alp(itypi)
11659             alf2=alp(itypj)
11660             alf12=0.5D0*(alf1+alf2)
11661             xj=c(1,nres+j)-xi
11662             yj=c(2,nres+j)-yi
11663             zj=c(3,nres+j)-zi
11664             dxj=dc_norm(1,nres+j)
11665             dyj=dc_norm(2,nres+j)
11666             dzj=dc_norm(3,nres+j)
11667             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11668             rij=dsqrt(rrij)
11669             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11670
11671             if (sss.lt.1.0d0) then
11672
11673 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11674               call sc_angular
11675 ! Calculate whole angle-dependent part of epsilon and contributions
11676 ! to its derivatives
11677               fac=(rrij*sigsq)**expon2
11678               e1=fac*fac*aa(itypi,itypj)
11679               e2=fac*bb(itypi,itypj)
11680               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11681               eps2der=evdwij*eps3rt
11682               eps3der=evdwij*eps2rt
11683               evdwij=evdwij*eps2rt*eps3rt
11684               evdw=evdw+evdwij*(1.0d0-sss)
11685               if (lprn) then
11686               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11687               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11688 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11689 !d     &          restyp(itypi),i,restyp(itypj),j,
11690 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11691 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11692 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11693 !d     &          evdwij
11694               endif
11695 ! Calculate gradient components.
11696               e1=e1*eps1*eps2rt**2*eps3rt**2
11697               fac=-expon*(e1+evdwij)
11698               sigder=fac/sigsq
11699               fac=rrij*fac
11700 ! Calculate radial part of the gradient
11701               gg(1)=xj*fac
11702               gg(2)=yj*fac
11703               gg(3)=zj*fac
11704 ! Calculate the angular part of the gradient and sum add the contributions
11705 ! to the appropriate components of the Cartesian gradient.
11706               call sc_grad_scale(1.0d0-sss)
11707             endif
11708           enddo      ! j
11709         enddo        ! iint
11710       enddo          ! i
11711 !     stop
11712       return
11713       end subroutine ebp_long
11714 !-----------------------------------------------------------------------------
11715       subroutine ebp_short(evdw)
11716 !
11717 ! This subroutine calculates the interaction energy of nonbonded side chains
11718 ! assuming the Berne-Pechukas potential of interaction.
11719 !
11720       use calc_data
11721 !      implicit real*8 (a-h,o-z)
11722 !      include 'DIMENSIONS'
11723 !      include 'COMMON.GEO'
11724 !      include 'COMMON.VAR'
11725 !      include 'COMMON.LOCAL'
11726 !      include 'COMMON.CHAIN'
11727 !      include 'COMMON.DERIV'
11728 !      include 'COMMON.NAMES'
11729 !      include 'COMMON.INTERACT'
11730 !      include 'COMMON.IOUNITS'
11731 !      include 'COMMON.CALC'
11732       use comm_srutu
11733 !el      integer :: icall
11734 !el      common /srutu/ icall
11735 !     double precision rrsave(maxdim)
11736       logical :: lprn
11737 !el local variables
11738       integer :: iint,itypi,itypi1,itypj
11739       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11740       real(kind=8) :: sss,e1,e2,evdw
11741       evdw=0.0D0
11742 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11743       evdw=0.0D0
11744 !     if (icall.eq.0) then
11745 !       lprn=.true.
11746 !     else
11747         lprn=.false.
11748 !     endif
11749 !el      ind=0
11750       do i=iatsc_s,iatsc_e
11751         itypi=itype(i)
11752         if (itypi.eq.ntyp1) cycle
11753         itypi1=itype(i+1)
11754         xi=c(1,nres+i)
11755         yi=c(2,nres+i)
11756         zi=c(3,nres+i)
11757         dxi=dc_norm(1,nres+i)
11758         dyi=dc_norm(2,nres+i)
11759         dzi=dc_norm(3,nres+i)
11760 !        dsci_inv=dsc_inv(itypi)
11761         dsci_inv=vbld_inv(i+nres)
11762 !
11763 ! Calculate SC interaction energy.
11764 !
11765         do iint=1,nint_gr(i)
11766           do j=istart(i,iint),iend(i,iint)
11767 !el            ind=ind+1
11768             itypj=itype(j)
11769             if (itypj.eq.ntyp1) cycle
11770 !            dscj_inv=dsc_inv(itypj)
11771             dscj_inv=vbld_inv(j+nres)
11772             chi1=chi(itypi,itypj)
11773             chi2=chi(itypj,itypi)
11774             chi12=chi1*chi2
11775             chip1=chip(itypi)
11776             chip2=chip(itypj)
11777             chip12=chip1*chip2
11778             alf1=alp(itypi)
11779             alf2=alp(itypj)
11780             alf12=0.5D0*(alf1+alf2)
11781             xj=c(1,nres+j)-xi
11782             yj=c(2,nres+j)-yi
11783             zj=c(3,nres+j)-zi
11784             dxj=dc_norm(1,nres+j)
11785             dyj=dc_norm(2,nres+j)
11786             dzj=dc_norm(3,nres+j)
11787             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11788             rij=dsqrt(rrij)
11789             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11790
11791             if (sss.gt.0.0d0) then
11792
11793 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11794               call sc_angular
11795 ! Calculate whole angle-dependent part of epsilon and contributions
11796 ! to its derivatives
11797               fac=(rrij*sigsq)**expon2
11798               e1=fac*fac*aa(itypi,itypj)
11799               e2=fac*bb(itypi,itypj)
11800               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11801               eps2der=evdwij*eps3rt
11802               eps3der=evdwij*eps2rt
11803               evdwij=evdwij*eps2rt*eps3rt
11804               evdw=evdw+evdwij*sss
11805               if (lprn) then
11806               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11807               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11808 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11809 !d     &          restyp(itypi),i,restyp(itypj),j,
11810 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11811 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11812 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11813 !d     &          evdwij
11814               endif
11815 ! Calculate gradient components.
11816               e1=e1*eps1*eps2rt**2*eps3rt**2
11817               fac=-expon*(e1+evdwij)
11818               sigder=fac/sigsq
11819               fac=rrij*fac
11820 ! Calculate radial part of the gradient
11821               gg(1)=xj*fac
11822               gg(2)=yj*fac
11823               gg(3)=zj*fac
11824 ! Calculate the angular part of the gradient and sum add the contributions
11825 ! to the appropriate components of the Cartesian gradient.
11826               call sc_grad_scale(sss)
11827             endif
11828           enddo      ! j
11829         enddo        ! iint
11830       enddo          ! i
11831 !     stop
11832       return
11833       end subroutine ebp_short
11834 !-----------------------------------------------------------------------------
11835       subroutine egb_long(evdw)
11836 !
11837 ! This subroutine calculates the interaction energy of nonbonded side chains
11838 ! assuming the Gay-Berne potential of interaction.
11839 !
11840       use calc_data
11841 !      implicit real*8 (a-h,o-z)
11842 !      include 'DIMENSIONS'
11843 !      include 'COMMON.GEO'
11844 !      include 'COMMON.VAR'
11845 !      include 'COMMON.LOCAL'
11846 !      include 'COMMON.CHAIN'
11847 !      include 'COMMON.DERIV'
11848 !      include 'COMMON.NAMES'
11849 !      include 'COMMON.INTERACT'
11850 !      include 'COMMON.IOUNITS'
11851 !      include 'COMMON.CALC'
11852 !      include 'COMMON.CONTROL'
11853       logical :: lprn
11854 !el local variables
11855       integer :: iint,itypi,itypi1,itypj,subchap
11856       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11857       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11858       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11859                     dist_temp, dist_init
11860
11861       evdw=0.0D0
11862 !cccc      energy_dec=.false.
11863 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11864       evdw=0.0D0
11865       lprn=.false.
11866 !     if (icall.eq.0) lprn=.false.
11867 !el      ind=0
11868       do i=iatsc_s,iatsc_e
11869         itypi=itype(i)
11870         if (itypi.eq.ntyp1) cycle
11871         itypi1=itype(i+1)
11872         xi=c(1,nres+i)
11873         yi=c(2,nres+i)
11874         zi=c(3,nres+i)
11875           xi=mod(xi,boxxsize)
11876           if (xi.lt.0) xi=xi+boxxsize
11877           yi=mod(yi,boxysize)
11878           if (yi.lt.0) yi=yi+boxysize
11879           zi=mod(zi,boxzsize)
11880           if (zi.lt.0) zi=zi+boxzsize
11881         dxi=dc_norm(1,nres+i)
11882         dyi=dc_norm(2,nres+i)
11883         dzi=dc_norm(3,nres+i)
11884 !        dsci_inv=dsc_inv(itypi)
11885         dsci_inv=vbld_inv(i+nres)
11886 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11887 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11888 !
11889 ! Calculate SC interaction energy.
11890 !
11891         do iint=1,nint_gr(i)
11892           do j=istart(i,iint),iend(i,iint)
11893 !el            ind=ind+1
11894             itypj=itype(j)
11895             if (itypj.eq.ntyp1) cycle
11896 !            dscj_inv=dsc_inv(itypj)
11897             dscj_inv=vbld_inv(j+nres)
11898 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11899 !     &       1.0d0/vbld(j+nres)
11900 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11901             sig0ij=sigma(itypi,itypj)
11902             chi1=chi(itypi,itypj)
11903             chi2=chi(itypj,itypi)
11904             chi12=chi1*chi2
11905             chip1=chip(itypi)
11906             chip2=chip(itypj)
11907             chip12=chip1*chip2
11908             alf1=alp(itypi)
11909             alf2=alp(itypj)
11910             alf12=0.5D0*(alf1+alf2)
11911             xj=c(1,nres+j)
11912             yj=c(2,nres+j)
11913             zj=c(3,nres+j)
11914 ! Searching for nearest neighbour
11915           xj=mod(xj,boxxsize)
11916           if (xj.lt.0) xj=xj+boxxsize
11917           yj=mod(yj,boxysize)
11918           if (yj.lt.0) yj=yj+boxysize
11919           zj=mod(zj,boxzsize)
11920           if (zj.lt.0) zj=zj+boxzsize
11921           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11922           xj_safe=xj
11923           yj_safe=yj
11924           zj_safe=zj
11925           subchap=0
11926           do xshift=-1,1
11927           do yshift=-1,1
11928           do zshift=-1,1
11929           xj=xj_safe+xshift*boxxsize
11930           yj=yj_safe+yshift*boxysize
11931           zj=zj_safe+zshift*boxzsize
11932           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11933           if(dist_temp.lt.dist_init) then
11934             dist_init=dist_temp
11935             xj_temp=xj
11936             yj_temp=yj
11937             zj_temp=zj
11938             subchap=1
11939           endif
11940           enddo
11941           enddo
11942           enddo
11943           if (subchap.eq.1) then
11944           xj=xj_temp-xi
11945           yj=yj_temp-yi
11946           zj=zj_temp-zi
11947           else
11948           xj=xj_safe-xi
11949           yj=yj_safe-yi
11950           zj=zj_safe-zi
11951           endif
11952
11953             dxj=dc_norm(1,nres+j)
11954             dyj=dc_norm(2,nres+j)
11955             dzj=dc_norm(3,nres+j)
11956             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11957             rij=dsqrt(rrij)
11958             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11959             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11960             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11961             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11962             if (sss_ele_cut.le.0.0) cycle
11963             if (sss.lt.1.0d0) then
11964
11965 ! Calculate angle-dependent terms of energy and contributions to their
11966 ! derivatives.
11967               call sc_angular
11968               sigsq=1.0D0/sigsq
11969               sig=sig0ij*dsqrt(sigsq)
11970               rij_shift=1.0D0/rij-sig+sig0ij
11971 ! for diagnostics; uncomment
11972 !              rij_shift=1.2*sig0ij
11973 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11974               if (rij_shift.le.0.0D0) then
11975                 evdw=1.0D20
11976 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11977 !d     &          restyp(itypi),i,restyp(itypj),j,
11978 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11979                 return
11980               endif
11981               sigder=-sig*sigsq
11982 !---------------------------------------------------------------
11983               rij_shift=1.0D0/rij_shift
11984               fac=rij_shift**expon
11985               e1=fac*fac*aa(itypi,itypj)
11986               e2=fac*bb(itypi,itypj)
11987               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11988               eps2der=evdwij*eps3rt
11989               eps3der=evdwij*eps2rt
11990 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11991 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11992               evdwij=evdwij*eps2rt*eps3rt
11993               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11994               if (lprn) then
11995               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11996               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11997               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11998                 restyp(itypi),i,restyp(itypj),j,&
11999                 epsi,sigm,chi1,chi2,chip1,chip2,&
12000                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12001                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12002                 evdwij
12003               endif
12004
12005               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12006                               'evdw',i,j,evdwij
12007 !              if (energy_dec) write (iout,*) &
12008 !                              'evdw',i,j,evdwij,"egb_long"
12009
12010 ! Calculate gradient components.
12011               e1=e1*eps1*eps2rt**2*eps3rt**2
12012               fac=-expon*(e1+evdwij)*rij_shift
12013               sigder=fac*sigder
12014               fac=rij*fac
12015               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12016             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
12017             /sigmaii(itypi,itypj))
12018 !              fac=0.0d0
12019 ! Calculate the radial part of the gradient
12020               gg(1)=xj*fac
12021               gg(2)=yj*fac
12022               gg(3)=zj*fac
12023 ! Calculate angular part of the gradient.
12024               call sc_grad_scale(1.0d0-sss)
12025             endif
12026           enddo      ! j
12027         enddo        ! iint
12028       enddo          ! i
12029 !      write (iout,*) "Number of loop steps in EGB:",ind
12030 !ccc      energy_dec=.false.
12031       return
12032       end subroutine egb_long
12033 !-----------------------------------------------------------------------------
12034       subroutine egb_short(evdw)
12035 !
12036 ! This subroutine calculates the interaction energy of nonbonded side chains
12037 ! assuming the Gay-Berne potential of interaction.
12038 !
12039       use calc_data
12040 !      implicit real*8 (a-h,o-z)
12041 !      include 'DIMENSIONS'
12042 !      include 'COMMON.GEO'
12043 !      include 'COMMON.VAR'
12044 !      include 'COMMON.LOCAL'
12045 !      include 'COMMON.CHAIN'
12046 !      include 'COMMON.DERIV'
12047 !      include 'COMMON.NAMES'
12048 !      include 'COMMON.INTERACT'
12049 !      include 'COMMON.IOUNITS'
12050 !      include 'COMMON.CALC'
12051 !      include 'COMMON.CONTROL'
12052       logical :: lprn
12053 !el local variables
12054       integer :: iint,itypi,itypi1,itypj,subchap
12055       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
12056       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
12057       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12058                     dist_temp, dist_init
12059       evdw=0.0D0
12060 !cccc      energy_dec=.false.
12061 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12062       evdw=0.0D0
12063       lprn=.false.
12064 !     if (icall.eq.0) lprn=.false.
12065 !el      ind=0
12066       do i=iatsc_s,iatsc_e
12067         itypi=itype(i)
12068         if (itypi.eq.ntyp1) cycle
12069         itypi1=itype(i+1)
12070         xi=c(1,nres+i)
12071         yi=c(2,nres+i)
12072         zi=c(3,nres+i)
12073           xi=mod(xi,boxxsize)
12074           if (xi.lt.0) xi=xi+boxxsize
12075           yi=mod(yi,boxysize)
12076           if (yi.lt.0) yi=yi+boxysize
12077           zi=mod(zi,boxzsize)
12078           if (zi.lt.0) zi=zi+boxzsize
12079         dxi=dc_norm(1,nres+i)
12080         dyi=dc_norm(2,nres+i)
12081         dzi=dc_norm(3,nres+i)
12082 !        dsci_inv=dsc_inv(itypi)
12083         dsci_inv=vbld_inv(i+nres)
12084
12085         dxi=dc_norm(1,nres+i)
12086         dyi=dc_norm(2,nres+i)
12087         dzi=dc_norm(3,nres+i)
12088 !        dsci_inv=dsc_inv(itypi)
12089         dsci_inv=vbld_inv(i+nres)
12090 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12091 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12092 !
12093 ! Calculate SC interaction energy.
12094 !
12095         do iint=1,nint_gr(i)
12096           do j=istart(i,iint),iend(i,iint)
12097 !el            ind=ind+1
12098             itypj=itype(j)
12099             if (itypj.eq.ntyp1) cycle
12100 !            dscj_inv=dsc_inv(itypj)
12101             dscj_inv=vbld_inv(j+nres)
12102 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12103 !     &       1.0d0/vbld(j+nres)
12104 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12105             sig0ij=sigma(itypi,itypj)
12106             chi1=chi(itypi,itypj)
12107             chi2=chi(itypj,itypi)
12108             chi12=chi1*chi2
12109             chip1=chip(itypi)
12110             chip2=chip(itypj)
12111             chip12=chip1*chip2
12112             alf1=alp(itypi)
12113             alf2=alp(itypj)
12114             alf12=0.5D0*(alf1+alf2)
12115 !            xj=c(1,nres+j)-xi
12116 !            yj=c(2,nres+j)-yi
12117 !            zj=c(3,nres+j)-zi
12118             xj=c(1,nres+j)
12119             yj=c(2,nres+j)
12120             zj=c(3,nres+j)
12121 ! Searching for nearest neighbour
12122           xj=mod(xj,boxxsize)
12123           if (xj.lt.0) xj=xj+boxxsize
12124           yj=mod(yj,boxysize)
12125           if (yj.lt.0) yj=yj+boxysize
12126           zj=mod(zj,boxzsize)
12127           if (zj.lt.0) zj=zj+boxzsize
12128           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12129           xj_safe=xj
12130           yj_safe=yj
12131           zj_safe=zj
12132           subchap=0
12133           do xshift=-1,1
12134           do yshift=-1,1
12135           do zshift=-1,1
12136           xj=xj_safe+xshift*boxxsize
12137           yj=yj_safe+yshift*boxysize
12138           zj=zj_safe+zshift*boxzsize
12139           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12140           if(dist_temp.lt.dist_init) then
12141             dist_init=dist_temp
12142             xj_temp=xj
12143             yj_temp=yj
12144             zj_temp=zj
12145             subchap=1
12146           endif
12147           enddo
12148           enddo
12149           enddo
12150           if (subchap.eq.1) then
12151           xj=xj_temp-xi
12152           yj=yj_temp-yi
12153           zj=zj_temp-zi
12154           else
12155           xj=xj_safe-xi
12156           yj=yj_safe-yi
12157           zj=zj_safe-zi
12158           endif
12159
12160             dxj=dc_norm(1,nres+j)
12161             dyj=dc_norm(2,nres+j)
12162             dzj=dc_norm(3,nres+j)
12163             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12164             rij=dsqrt(rrij)
12165             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12166             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12167             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12168             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12169             if (sss_ele_cut.le.0.0) cycle
12170
12171             if (sss.gt.0.0d0) then
12172
12173 ! Calculate angle-dependent terms of energy and contributions to their
12174 ! derivatives.
12175               call sc_angular
12176               sigsq=1.0D0/sigsq
12177               sig=sig0ij*dsqrt(sigsq)
12178               rij_shift=1.0D0/rij-sig+sig0ij
12179 ! for diagnostics; uncomment
12180 !              rij_shift=1.2*sig0ij
12181 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12182               if (rij_shift.le.0.0D0) then
12183                 evdw=1.0D20
12184 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12185 !d     &          restyp(itypi),i,restyp(itypj),j,
12186 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12187                 return
12188               endif
12189               sigder=-sig*sigsq
12190 !---------------------------------------------------------------
12191               rij_shift=1.0D0/rij_shift
12192               fac=rij_shift**expon
12193               e1=fac*fac*aa(itypi,itypj)
12194               e2=fac*bb(itypi,itypj)
12195               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12196               eps2der=evdwij*eps3rt
12197               eps3der=evdwij*eps2rt
12198 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12199 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12200               evdwij=evdwij*eps2rt*eps3rt
12201               evdw=evdw+evdwij*sss*sss_ele_cut
12202               if (lprn) then
12203               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12204               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12205               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12206                 restyp(itypi),i,restyp(itypj),j,&
12207                 epsi,sigm,chi1,chi2,chip1,chip2,&
12208                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12209                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12210                 evdwij
12211               endif
12212
12213               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12214                               'evdw',i,j,evdwij
12215 !              if (energy_dec) write (iout,*) &
12216 !                              'evdw',i,j,evdwij,"egb_short"
12217
12218 ! Calculate gradient components.
12219               e1=e1*eps1*eps2rt**2*eps3rt**2
12220               fac=-expon*(e1+evdwij)*rij_shift
12221               sigder=fac*sigder
12222               fac=rij*fac
12223               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12224             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12225             /sigmaii(itypi,itypj))
12226
12227 !              fac=0.0d0
12228 ! Calculate the radial part of the gradient
12229               gg(1)=xj*fac
12230               gg(2)=yj*fac
12231               gg(3)=zj*fac
12232 ! Calculate angular part of the gradient.
12233               call sc_grad_scale(sss)
12234             endif
12235           enddo      ! j
12236         enddo        ! iint
12237       enddo          ! i
12238 !      write (iout,*) "Number of loop steps in EGB:",ind
12239 !ccc      energy_dec=.false.
12240       return
12241       end subroutine egb_short
12242 !-----------------------------------------------------------------------------
12243       subroutine egbv_long(evdw)
12244 !
12245 ! This subroutine calculates the interaction energy of nonbonded side chains
12246 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12247 !
12248       use calc_data
12249 !      implicit real*8 (a-h,o-z)
12250 !      include 'DIMENSIONS'
12251 !      include 'COMMON.GEO'
12252 !      include 'COMMON.VAR'
12253 !      include 'COMMON.LOCAL'
12254 !      include 'COMMON.CHAIN'
12255 !      include 'COMMON.DERIV'
12256 !      include 'COMMON.NAMES'
12257 !      include 'COMMON.INTERACT'
12258 !      include 'COMMON.IOUNITS'
12259 !      include 'COMMON.CALC'
12260       use comm_srutu
12261 !el      integer :: icall
12262 !el      common /srutu/ icall
12263       logical :: lprn
12264 !el local variables
12265       integer :: iint,itypi,itypi1,itypj
12266       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12267       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12268       evdw=0.0D0
12269 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12270       evdw=0.0D0
12271       lprn=.false.
12272 !     if (icall.eq.0) lprn=.true.
12273 !el      ind=0
12274       do i=iatsc_s,iatsc_e
12275         itypi=itype(i)
12276         if (itypi.eq.ntyp1) cycle
12277         itypi1=itype(i+1)
12278         xi=c(1,nres+i)
12279         yi=c(2,nres+i)
12280         zi=c(3,nres+i)
12281         dxi=dc_norm(1,nres+i)
12282         dyi=dc_norm(2,nres+i)
12283         dzi=dc_norm(3,nres+i)
12284 !        dsci_inv=dsc_inv(itypi)
12285         dsci_inv=vbld_inv(i+nres)
12286 !
12287 ! Calculate SC interaction energy.
12288 !
12289         do iint=1,nint_gr(i)
12290           do j=istart(i,iint),iend(i,iint)
12291 !el            ind=ind+1
12292             itypj=itype(j)
12293             if (itypj.eq.ntyp1) cycle
12294 !            dscj_inv=dsc_inv(itypj)
12295             dscj_inv=vbld_inv(j+nres)
12296             sig0ij=sigma(itypi,itypj)
12297             r0ij=r0(itypi,itypj)
12298             chi1=chi(itypi,itypj)
12299             chi2=chi(itypj,itypi)
12300             chi12=chi1*chi2
12301             chip1=chip(itypi)
12302             chip2=chip(itypj)
12303             chip12=chip1*chip2
12304             alf1=alp(itypi)
12305             alf2=alp(itypj)
12306             alf12=0.5D0*(alf1+alf2)
12307             xj=c(1,nres+j)-xi
12308             yj=c(2,nres+j)-yi
12309             zj=c(3,nres+j)-zi
12310             dxj=dc_norm(1,nres+j)
12311             dyj=dc_norm(2,nres+j)
12312             dzj=dc_norm(3,nres+j)
12313             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12314             rij=dsqrt(rrij)
12315
12316             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12317
12318             if (sss.lt.1.0d0) then
12319
12320 ! Calculate angle-dependent terms of energy and contributions to their
12321 ! derivatives.
12322               call sc_angular
12323               sigsq=1.0D0/sigsq
12324               sig=sig0ij*dsqrt(sigsq)
12325               rij_shift=1.0D0/rij-sig+r0ij
12326 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12327               if (rij_shift.le.0.0D0) then
12328                 evdw=1.0D20
12329                 return
12330               endif
12331               sigder=-sig*sigsq
12332 !---------------------------------------------------------------
12333               rij_shift=1.0D0/rij_shift
12334               fac=rij_shift**expon
12335               e1=fac*fac*aa(itypi,itypj)
12336               e2=fac*bb(itypi,itypj)
12337               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12338               eps2der=evdwij*eps3rt
12339               eps3der=evdwij*eps2rt
12340               fac_augm=rrij**expon
12341               e_augm=augm(itypi,itypj)*fac_augm
12342               evdwij=evdwij*eps2rt*eps3rt
12343               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12344               if (lprn) then
12345               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12346               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12347               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12348                 restyp(itypi),i,restyp(itypj),j,&
12349                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12350                 chi1,chi2,chip1,chip2,&
12351                 eps1,eps2rt**2,eps3rt**2,&
12352                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12353                 evdwij+e_augm
12354               endif
12355 ! Calculate gradient components.
12356               e1=e1*eps1*eps2rt**2*eps3rt**2
12357               fac=-expon*(e1+evdwij)*rij_shift
12358               sigder=fac*sigder
12359               fac=rij*fac-2*expon*rrij*e_augm
12360 ! Calculate the radial part of the gradient
12361               gg(1)=xj*fac
12362               gg(2)=yj*fac
12363               gg(3)=zj*fac
12364 ! Calculate angular part of the gradient.
12365               call sc_grad_scale(1.0d0-sss)
12366             endif
12367           enddo      ! j
12368         enddo        ! iint
12369       enddo          ! i
12370       end subroutine egbv_long
12371 !-----------------------------------------------------------------------------
12372       subroutine egbv_short(evdw)
12373 !
12374 ! This subroutine calculates the interaction energy of nonbonded side chains
12375 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12376 !
12377       use calc_data
12378 !      implicit real*8 (a-h,o-z)
12379 !      include 'DIMENSIONS'
12380 !      include 'COMMON.GEO'
12381 !      include 'COMMON.VAR'
12382 !      include 'COMMON.LOCAL'
12383 !      include 'COMMON.CHAIN'
12384 !      include 'COMMON.DERIV'
12385 !      include 'COMMON.NAMES'
12386 !      include 'COMMON.INTERACT'
12387 !      include 'COMMON.IOUNITS'
12388 !      include 'COMMON.CALC'
12389       use comm_srutu
12390 !el      integer :: icall
12391 !el      common /srutu/ icall
12392       logical :: lprn
12393 !el local variables
12394       integer :: iint,itypi,itypi1,itypj
12395       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12396       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12397       evdw=0.0D0
12398 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12399       evdw=0.0D0
12400       lprn=.false.
12401 !     if (icall.eq.0) lprn=.true.
12402 !el      ind=0
12403       do i=iatsc_s,iatsc_e
12404         itypi=itype(i)
12405         if (itypi.eq.ntyp1) cycle
12406         itypi1=itype(i+1)
12407         xi=c(1,nres+i)
12408         yi=c(2,nres+i)
12409         zi=c(3,nres+i)
12410         dxi=dc_norm(1,nres+i)
12411         dyi=dc_norm(2,nres+i)
12412         dzi=dc_norm(3,nres+i)
12413 !        dsci_inv=dsc_inv(itypi)
12414         dsci_inv=vbld_inv(i+nres)
12415 !
12416 ! Calculate SC interaction energy.
12417 !
12418         do iint=1,nint_gr(i)
12419           do j=istart(i,iint),iend(i,iint)
12420 !el            ind=ind+1
12421             itypj=itype(j)
12422             if (itypj.eq.ntyp1) cycle
12423 !            dscj_inv=dsc_inv(itypj)
12424             dscj_inv=vbld_inv(j+nres)
12425             sig0ij=sigma(itypi,itypj)
12426             r0ij=r0(itypi,itypj)
12427             chi1=chi(itypi,itypj)
12428             chi2=chi(itypj,itypi)
12429             chi12=chi1*chi2
12430             chip1=chip(itypi)
12431             chip2=chip(itypj)
12432             chip12=chip1*chip2
12433             alf1=alp(itypi)
12434             alf2=alp(itypj)
12435             alf12=0.5D0*(alf1+alf2)
12436             xj=c(1,nres+j)-xi
12437             yj=c(2,nres+j)-yi
12438             zj=c(3,nres+j)-zi
12439             dxj=dc_norm(1,nres+j)
12440             dyj=dc_norm(2,nres+j)
12441             dzj=dc_norm(3,nres+j)
12442             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12443             rij=dsqrt(rrij)
12444
12445             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12446
12447             if (sss.gt.0.0d0) then
12448
12449 ! Calculate angle-dependent terms of energy and contributions to their
12450 ! derivatives.
12451               call sc_angular
12452               sigsq=1.0D0/sigsq
12453               sig=sig0ij*dsqrt(sigsq)
12454               rij_shift=1.0D0/rij-sig+r0ij
12455 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12456               if (rij_shift.le.0.0D0) then
12457                 evdw=1.0D20
12458                 return
12459               endif
12460               sigder=-sig*sigsq
12461 !---------------------------------------------------------------
12462               rij_shift=1.0D0/rij_shift
12463               fac=rij_shift**expon
12464               e1=fac*fac*aa(itypi,itypj)
12465               e2=fac*bb(itypi,itypj)
12466               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12467               eps2der=evdwij*eps3rt
12468               eps3der=evdwij*eps2rt
12469               fac_augm=rrij**expon
12470               e_augm=augm(itypi,itypj)*fac_augm
12471               evdwij=evdwij*eps2rt*eps3rt
12472               evdw=evdw+(evdwij+e_augm)*sss
12473               if (lprn) then
12474               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12475               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12476               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12477                 restyp(itypi),i,restyp(itypj),j,&
12478                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12479                 chi1,chi2,chip1,chip2,&
12480                 eps1,eps2rt**2,eps3rt**2,&
12481                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12482                 evdwij+e_augm
12483               endif
12484 ! Calculate gradient components.
12485               e1=e1*eps1*eps2rt**2*eps3rt**2
12486               fac=-expon*(e1+evdwij)*rij_shift
12487               sigder=fac*sigder
12488               fac=rij*fac-2*expon*rrij*e_augm
12489 ! Calculate the radial part of the gradient
12490               gg(1)=xj*fac
12491               gg(2)=yj*fac
12492               gg(3)=zj*fac
12493 ! Calculate angular part of the gradient.
12494               call sc_grad_scale(sss)
12495             endif
12496           enddo      ! j
12497         enddo        ! iint
12498       enddo          ! i
12499       end subroutine egbv_short
12500 !-----------------------------------------------------------------------------
12501       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12502 !
12503 ! This subroutine calculates the average interaction energy and its gradient
12504 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12505 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12506 ! The potential depends both on the distance of peptide-group centers and on
12507 ! the orientation of the CA-CA virtual bonds.
12508 !
12509 !      implicit real*8 (a-h,o-z)
12510
12511       use comm_locel
12512 #ifdef MPI
12513       include 'mpif.h'
12514 #endif
12515 !      include 'DIMENSIONS'
12516 !      include 'COMMON.CONTROL'
12517 !      include 'COMMON.SETUP'
12518 !      include 'COMMON.IOUNITS'
12519 !      include 'COMMON.GEO'
12520 !      include 'COMMON.VAR'
12521 !      include 'COMMON.LOCAL'
12522 !      include 'COMMON.CHAIN'
12523 !      include 'COMMON.DERIV'
12524 !      include 'COMMON.INTERACT'
12525 !      include 'COMMON.CONTACTS'
12526 !      include 'COMMON.TORSION'
12527 !      include 'COMMON.VECTORS'
12528 !      include 'COMMON.FFIELD'
12529 !      include 'COMMON.TIME1'
12530       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12531       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12532       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12533 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12534       real(kind=8),dimension(4) :: muij
12535 !el      integer :: num_conti,j1,j2
12536 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12537 !el                   dz_normi,xmedi,ymedi,zmedi
12538 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12539 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12540 !el          num_conti,j1,j2
12541 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12542 #ifdef MOMENT
12543       real(kind=8) :: scal_el=1.0d0
12544 #else
12545       real(kind=8) :: scal_el=0.5d0
12546 #endif
12547 ! 12/13/98
12548 ! 13-go grudnia roku pamietnego...
12549       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12550                                              0.0d0,1.0d0,0.0d0,&
12551                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12552 !el local variables
12553       integer :: i,j,k
12554       real(kind=8) :: fac
12555       real(kind=8) :: dxj,dyj,dzj
12556       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12557
12558 !      allocate(num_cont_hb(nres)) !(maxres)
12559 !d      write(iout,*) 'In EELEC'
12560 !d      do i=1,nloctyp
12561 !d        write(iout,*) 'Type',i
12562 !d        write(iout,*) 'B1',B1(:,i)
12563 !d        write(iout,*) 'B2',B2(:,i)
12564 !d        write(iout,*) 'CC',CC(:,:,i)
12565 !d        write(iout,*) 'DD',DD(:,:,i)
12566 !d        write(iout,*) 'EE',EE(:,:,i)
12567 !d      enddo
12568 !d      call check_vecgrad
12569 !d      stop
12570       if (icheckgrad.eq.1) then
12571         do i=1,nres-1
12572           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12573           do k=1,3
12574             dc_norm(k,i)=dc(k,i)*fac
12575           enddo
12576 !          write (iout,*) 'i',i,' fac',fac
12577         enddo
12578       endif
12579       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12580           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12581           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12582 !        call vec_and_deriv
12583 #ifdef TIMING
12584         time01=MPI_Wtime()
12585 #endif
12586         call set_matrices
12587 #ifdef TIMING
12588         time_mat=time_mat+MPI_Wtime()-time01
12589 #endif
12590       endif
12591 !d      do i=1,nres-1
12592 !d        write (iout,*) 'i=',i
12593 !d        do k=1,3
12594 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12595 !d        enddo
12596 !d        do k=1,3
12597 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12598 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12599 !d        enddo
12600 !d      enddo
12601       t_eelecij=0.0d0
12602       ees=0.0D0
12603       evdw1=0.0D0
12604       eel_loc=0.0d0
12605       eello_turn3=0.0d0
12606       eello_turn4=0.0d0
12607 !el      ind=0
12608       do i=1,nres
12609         num_cont_hb(i)=0
12610       enddo
12611 !d      print '(a)','Enter EELEC'
12612 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12613 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12614 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12615       do i=1,nres
12616         gel_loc_loc(i)=0.0d0
12617         gcorr_loc(i)=0.0d0
12618       enddo
12619 !
12620 !
12621 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12622 !
12623 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12624 !
12625       do i=iturn3_start,iturn3_end
12626         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12627         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12628         dxi=dc(1,i)
12629         dyi=dc(2,i)
12630         dzi=dc(3,i)
12631         dx_normi=dc_norm(1,i)
12632         dy_normi=dc_norm(2,i)
12633         dz_normi=dc_norm(3,i)
12634         xmedi=c(1,i)+0.5d0*dxi
12635         ymedi=c(2,i)+0.5d0*dyi
12636         zmedi=c(3,i)+0.5d0*dzi
12637         num_conti=0
12638         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12639         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12640         num_cont_hb(i)=num_conti
12641       enddo
12642       do i=iturn4_start,iturn4_end
12643         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12644           .or. itype(i+3).eq.ntyp1 &
12645           .or. itype(i+4).eq.ntyp1) cycle
12646         dxi=dc(1,i)
12647         dyi=dc(2,i)
12648         dzi=dc(3,i)
12649         dx_normi=dc_norm(1,i)
12650         dy_normi=dc_norm(2,i)
12651         dz_normi=dc_norm(3,i)
12652         xmedi=c(1,i)+0.5d0*dxi
12653         ymedi=c(2,i)+0.5d0*dyi
12654         zmedi=c(3,i)+0.5d0*dzi
12655         num_conti=num_cont_hb(i)
12656         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12657         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12658           call eturn4(i,eello_turn4)
12659         num_cont_hb(i)=num_conti
12660       enddo   ! i
12661 !
12662 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12663 !
12664       do i=iatel_s,iatel_e
12665         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12666         dxi=dc(1,i)
12667         dyi=dc(2,i)
12668         dzi=dc(3,i)
12669         dx_normi=dc_norm(1,i)
12670         dy_normi=dc_norm(2,i)
12671         dz_normi=dc_norm(3,i)
12672         xmedi=c(1,i)+0.5d0*dxi
12673         ymedi=c(2,i)+0.5d0*dyi
12674         zmedi=c(3,i)+0.5d0*dzi
12675 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12676         num_conti=num_cont_hb(i)
12677         do j=ielstart(i),ielend(i)
12678           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12679           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12680         enddo ! j
12681         num_cont_hb(i)=num_conti
12682       enddo   ! i
12683 !      write (iout,*) "Number of loop steps in EELEC:",ind
12684 !d      do i=1,nres
12685 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12686 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12687 !d      enddo
12688 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12689 !cc      eel_loc=eel_loc+eello_turn3
12690 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12691       return
12692       end subroutine eelec_scale
12693 !-----------------------------------------------------------------------------
12694       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12695 !      implicit real*8 (a-h,o-z)
12696
12697       use comm_locel
12698 !      include 'DIMENSIONS'
12699 #ifdef MPI
12700       include "mpif.h"
12701 #endif
12702 !      include 'COMMON.CONTROL'
12703 !      include 'COMMON.IOUNITS'
12704 !      include 'COMMON.GEO'
12705 !      include 'COMMON.VAR'
12706 !      include 'COMMON.LOCAL'
12707 !      include 'COMMON.CHAIN'
12708 !      include 'COMMON.DERIV'
12709 !      include 'COMMON.INTERACT'
12710 !      include 'COMMON.CONTACTS'
12711 !      include 'COMMON.TORSION'
12712 !      include 'COMMON.VECTORS'
12713 !      include 'COMMON.FFIELD'
12714 !      include 'COMMON.TIME1'
12715       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12716       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12717       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12718 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12719       real(kind=8),dimension(4) :: muij
12720 !el      integer :: num_conti,j1,j2
12721 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12722 !el                   dz_normi,xmedi,ymedi,zmedi
12723 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12724 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12725 !el          num_conti,j1,j2
12726 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12727 #ifdef MOMENT
12728       real(kind=8) :: scal_el=1.0d0
12729 #else
12730       real(kind=8) :: scal_el=0.5d0
12731 #endif
12732 ! 12/13/98
12733 ! 13-go grudnia roku pamietnego...
12734       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12735                                              0.0d0,1.0d0,0.0d0,&
12736                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12737 !el local variables
12738       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12739       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12740       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12741       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12742       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12743       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12744       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12745                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12746                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12747                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12748                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12749                   ecosam,ecosbm,ecosgm,ghalf,time00
12750 !      integer :: maxconts
12751 !      maxconts = nres/4
12752 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12753 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12754 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12755 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12756 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12757 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12758 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12759 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12760 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12761 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12762 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12763 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12764 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12765
12766 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12767 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12768
12769 #ifdef MPI
12770           time00=MPI_Wtime()
12771 #endif
12772 !d      write (iout,*) "eelecij",i,j
12773 !el          ind=ind+1
12774           iteli=itel(i)
12775           itelj=itel(j)
12776           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12777           aaa=app(iteli,itelj)
12778           bbb=bpp(iteli,itelj)
12779           ael6i=ael6(iteli,itelj)
12780           ael3i=ael3(iteli,itelj)
12781           dxj=dc(1,j)
12782           dyj=dc(2,j)
12783           dzj=dc(3,j)
12784           dx_normj=dc_norm(1,j)
12785           dy_normj=dc_norm(2,j)
12786           dz_normj=dc_norm(3,j)
12787           xj=c(1,j)+0.5D0*dxj-xmedi
12788           yj=c(2,j)+0.5D0*dyj-ymedi
12789           zj=c(3,j)+0.5D0*dzj-zmedi
12790           rij=xj*xj+yj*yj+zj*zj
12791           rrmij=1.0D0/rij
12792           rij=dsqrt(rij)
12793           rmij=1.0D0/rij
12794 ! For extracting the short-range part of Evdwpp
12795           sss=sscale(rij/rpp(iteli,itelj))
12796
12797           r3ij=rrmij*rmij
12798           r6ij=r3ij*r3ij
12799           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12800           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12801           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12802           fac=cosa-3.0D0*cosb*cosg
12803           ev1=aaa*r6ij*r6ij
12804 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12805           if (j.eq.i+2) ev1=scal_el*ev1
12806           ev2=bbb*r6ij
12807           fac3=ael6i*r6ij
12808           fac4=ael3i*r3ij
12809           evdwij=ev1+ev2
12810           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12811           el2=fac4*fac
12812           eesij=el1+el2
12813 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12814           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12815           ees=ees+eesij
12816           evdw1=evdw1+evdwij*(1.0d0-sss)
12817 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12818 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12819 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12820 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12821
12822           if (energy_dec) then
12823               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12824               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12825           endif
12826
12827 !
12828 ! Calculate contributions to the Cartesian gradient.
12829 !
12830 #ifdef SPLITELE
12831           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12832           facel=-3*rrmij*(el1+eesij)
12833           fac1=fac
12834           erij(1)=xj*rmij
12835           erij(2)=yj*rmij
12836           erij(3)=zj*rmij
12837 !
12838 ! Radial derivatives. First process both termini of the fragment (i,j)
12839 !
12840           ggg(1)=facel*xj
12841           ggg(2)=facel*yj
12842           ggg(3)=facel*zj
12843 !          do k=1,3
12844 !            ghalf=0.5D0*ggg(k)
12845 !            gelc(k,i)=gelc(k,i)+ghalf
12846 !            gelc(k,j)=gelc(k,j)+ghalf
12847 !          enddo
12848 ! 9/28/08 AL Gradient compotents will be summed only at the end
12849           do k=1,3
12850             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12851             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12852           enddo
12853 !
12854 ! Loop over residues i+1 thru j-1.
12855 !
12856 !grad          do k=i+1,j-1
12857 !grad            do l=1,3
12858 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12859 !grad            enddo
12860 !grad          enddo
12861           ggg(1)=facvdw*xj
12862           ggg(2)=facvdw*yj
12863           ggg(3)=facvdw*zj
12864 !          do k=1,3
12865 !            ghalf=0.5D0*ggg(k)
12866 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12867 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12868 !          enddo
12869 ! 9/28/08 AL Gradient compotents will be summed only at the end
12870           do k=1,3
12871             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12872             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12873           enddo
12874 !
12875 ! Loop over residues i+1 thru j-1.
12876 !
12877 !grad          do k=i+1,j-1
12878 !grad            do l=1,3
12879 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12880 !grad            enddo
12881 !grad          enddo
12882 #else
12883           facvdw=ev1+evdwij*(1.0d0-sss)
12884           facel=el1+eesij
12885           fac1=fac
12886           fac=-3*rrmij*(facvdw+facvdw+facel)
12887           erij(1)=xj*rmij
12888           erij(2)=yj*rmij
12889           erij(3)=zj*rmij
12890 !
12891 ! Radial derivatives. First process both termini of the fragment (i,j)
12892 !
12893           ggg(1)=fac*xj
12894           ggg(2)=fac*yj
12895           ggg(3)=fac*zj
12896 !          do k=1,3
12897 !            ghalf=0.5D0*ggg(k)
12898 !            gelc(k,i)=gelc(k,i)+ghalf
12899 !            gelc(k,j)=gelc(k,j)+ghalf
12900 !          enddo
12901 ! 9/28/08 AL Gradient compotents will be summed only at the end
12902           do k=1,3
12903             gelc_long(k,j)=gelc(k,j)+ggg(k)
12904             gelc_long(k,i)=gelc(k,i)-ggg(k)
12905           enddo
12906 !
12907 ! Loop over residues i+1 thru j-1.
12908 !
12909 !grad          do k=i+1,j-1
12910 !grad            do l=1,3
12911 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12912 !grad            enddo
12913 !grad          enddo
12914 ! 9/28/08 AL Gradient compotents will be summed only at the end
12915           ggg(1)=facvdw*xj
12916           ggg(2)=facvdw*yj
12917           ggg(3)=facvdw*zj
12918           do k=1,3
12919             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12920             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12921           enddo
12922 #endif
12923 !
12924 ! Angular part
12925 !
12926           ecosa=2.0D0*fac3*fac1+fac4
12927           fac4=-3.0D0*fac4
12928           fac3=-6.0D0*fac3
12929           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12930           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12931           do k=1,3
12932             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12933             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12934           enddo
12935 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12936 !d   &          (dcosg(k),k=1,3)
12937           do k=1,3
12938             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12939           enddo
12940 !          do k=1,3
12941 !            ghalf=0.5D0*ggg(k)
12942 !            gelc(k,i)=gelc(k,i)+ghalf
12943 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12944 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12945 !            gelc(k,j)=gelc(k,j)+ghalf
12946 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12947 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12948 !          enddo
12949 !grad          do k=i+1,j-1
12950 !grad            do l=1,3
12951 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12952 !grad            enddo
12953 !grad          enddo
12954           do k=1,3
12955             gelc(k,i)=gelc(k,i) &
12956                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12957                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12958             gelc(k,j)=gelc(k,j) &
12959                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12960                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12961             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12962             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12963           enddo
12964           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12965               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12966               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12967 !
12968 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12969 !   energy of a peptide unit is assumed in the form of a second-order
12970 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12971 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12972 !   are computed for EVERY pair of non-contiguous peptide groups.
12973 !
12974           if (j.lt.nres-1) then
12975             j1=j+1
12976             j2=j-1
12977           else
12978             j1=j-1
12979             j2=j-2
12980           endif
12981           kkk=0
12982           do k=1,2
12983             do l=1,2
12984               kkk=kkk+1
12985               muij(kkk)=mu(k,i)*mu(l,j)
12986             enddo
12987           enddo
12988 !d         write (iout,*) 'EELEC: i',i,' j',j
12989 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12990 !d          write(iout,*) 'muij',muij
12991           ury=scalar(uy(1,i),erij)
12992           urz=scalar(uz(1,i),erij)
12993           vry=scalar(uy(1,j),erij)
12994           vrz=scalar(uz(1,j),erij)
12995           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12996           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12997           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12998           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12999           fac=dsqrt(-ael6i)*r3ij
13000           a22=a22*fac
13001           a23=a23*fac
13002           a32=a32*fac
13003           a33=a33*fac
13004 !d          write (iout,'(4i5,4f10.5)')
13005 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
13006 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
13007 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
13008 !d     &      uy(:,j),uz(:,j)
13009 !d          write (iout,'(4f10.5)')
13010 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
13011 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
13012 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
13013 !d           write (iout,'(9f10.5/)')
13014 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
13015 ! Derivatives of the elements of A in virtual-bond vectors
13016           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
13017           do k=1,3
13018             uryg(k,1)=scalar(erder(1,k),uy(1,i))
13019             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
13020             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
13021             urzg(k,1)=scalar(erder(1,k),uz(1,i))
13022             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
13023             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
13024             vryg(k,1)=scalar(erder(1,k),uy(1,j))
13025             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
13026             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
13027             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
13028             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
13029             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
13030           enddo
13031 ! Compute radial contributions to the gradient
13032           facr=-3.0d0*rrmij
13033           a22der=a22*facr
13034           a23der=a23*facr
13035           a32der=a32*facr
13036           a33der=a33*facr
13037           agg(1,1)=a22der*xj
13038           agg(2,1)=a22der*yj
13039           agg(3,1)=a22der*zj
13040           agg(1,2)=a23der*xj
13041           agg(2,2)=a23der*yj
13042           agg(3,2)=a23der*zj
13043           agg(1,3)=a32der*xj
13044           agg(2,3)=a32der*yj
13045           agg(3,3)=a32der*zj
13046           agg(1,4)=a33der*xj
13047           agg(2,4)=a33der*yj
13048           agg(3,4)=a33der*zj
13049 ! Add the contributions coming from er
13050           fac3=-3.0d0*fac
13051           do k=1,3
13052             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
13053             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
13054             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
13055             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
13056           enddo
13057           do k=1,3
13058 ! Derivatives in DC(i)
13059 !grad            ghalf1=0.5d0*agg(k,1)
13060 !grad            ghalf2=0.5d0*agg(k,2)
13061 !grad            ghalf3=0.5d0*agg(k,3)
13062 !grad            ghalf4=0.5d0*agg(k,4)
13063             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
13064             -3.0d0*uryg(k,2)*vry)!+ghalf1
13065             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
13066             -3.0d0*uryg(k,2)*vrz)!+ghalf2
13067             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
13068             -3.0d0*urzg(k,2)*vry)!+ghalf3
13069             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
13070             -3.0d0*urzg(k,2)*vrz)!+ghalf4
13071 ! Derivatives in DC(i+1)
13072             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
13073             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
13074             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
13075             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
13076             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
13077             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
13078             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
13079             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
13080 ! Derivatives in DC(j)
13081             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
13082             -3.0d0*vryg(k,2)*ury)!+ghalf1
13083             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
13084             -3.0d0*vrzg(k,2)*ury)!+ghalf2
13085             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
13086             -3.0d0*vryg(k,2)*urz)!+ghalf3
13087             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
13088             -3.0d0*vrzg(k,2)*urz)!+ghalf4
13089 ! Derivatives in DC(j+1) or DC(nres-1)
13090             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
13091             -3.0d0*vryg(k,3)*ury)
13092             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
13093             -3.0d0*vrzg(k,3)*ury)
13094             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
13095             -3.0d0*vryg(k,3)*urz)
13096             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
13097             -3.0d0*vrzg(k,3)*urz)
13098 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
13099 !grad              do l=1,4
13100 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
13101 !grad              enddo
13102 !grad            endif
13103           enddo
13104           acipa(1,1)=a22
13105           acipa(1,2)=a23
13106           acipa(2,1)=a32
13107           acipa(2,2)=a33
13108           a22=-a22
13109           a23=-a23
13110           do l=1,2
13111             do k=1,3
13112               agg(k,l)=-agg(k,l)
13113               aggi(k,l)=-aggi(k,l)
13114               aggi1(k,l)=-aggi1(k,l)
13115               aggj(k,l)=-aggj(k,l)
13116               aggj1(k,l)=-aggj1(k,l)
13117             enddo
13118           enddo
13119           if (j.lt.nres-1) then
13120             a22=-a22
13121             a32=-a32
13122             do l=1,3,2
13123               do k=1,3
13124                 agg(k,l)=-agg(k,l)
13125                 aggi(k,l)=-aggi(k,l)
13126                 aggi1(k,l)=-aggi1(k,l)
13127                 aggj(k,l)=-aggj(k,l)
13128                 aggj1(k,l)=-aggj1(k,l)
13129               enddo
13130             enddo
13131           else
13132             a22=-a22
13133             a23=-a23
13134             a32=-a32
13135             a33=-a33
13136             do l=1,4
13137               do k=1,3
13138                 agg(k,l)=-agg(k,l)
13139                 aggi(k,l)=-aggi(k,l)
13140                 aggi1(k,l)=-aggi1(k,l)
13141                 aggj(k,l)=-aggj(k,l)
13142                 aggj1(k,l)=-aggj1(k,l)
13143               enddo
13144             enddo
13145           endif
13146           ENDIF ! WCORR
13147           IF (wel_loc.gt.0.0d0) THEN
13148 ! Contribution to the local-electrostatic energy coming from the i-j pair
13149           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
13150            +a33*muij(4)
13151 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
13152
13153           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13154                   'eelloc',i,j,eel_loc_ij
13155 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
13156
13157           eel_loc=eel_loc+eel_loc_ij
13158 ! Partial derivatives in virtual-bond dihedral angles gamma
13159           if (i.gt.1) &
13160           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
13161                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
13162                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
13163           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
13164                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
13165                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
13166 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
13167           do l=1,3
13168             ggg(l)=agg(l,1)*muij(1)+ &
13169                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
13170             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
13171             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
13172 !grad            ghalf=0.5d0*ggg(l)
13173 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
13174 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
13175           enddo
13176 !grad          do k=i+1,j2
13177 !grad            do l=1,3
13178 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
13179 !grad            enddo
13180 !grad          enddo
13181 ! Remaining derivatives of eello
13182           do l=1,3
13183             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
13184                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
13185             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
13186                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
13187             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
13188                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
13189             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
13190                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
13191           enddo
13192           ENDIF
13193 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13194 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13195           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13196              .and. num_conti.le.maxconts) then
13197 !            write (iout,*) i,j," entered corr"
13198 !
13199 ! Calculate the contact function. The ith column of the array JCONT will
13200 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13201 ! greater than I). The arrays FACONT and GACONT will contain the values of
13202 ! the contact function and its derivative.
13203 !           r0ij=1.02D0*rpp(iteli,itelj)
13204 !           r0ij=1.11D0*rpp(iteli,itelj)
13205             r0ij=2.20D0*rpp(iteli,itelj)
13206 !           r0ij=1.55D0*rpp(iteli,itelj)
13207             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13208 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13209             if (fcont.gt.0.0D0) then
13210               num_conti=num_conti+1
13211               if (num_conti.gt.maxconts) then
13212 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13213                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13214                                ' will skip next contacts for this conf.',num_conti
13215               else
13216                 jcont_hb(num_conti,i)=j
13217 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13218 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13219                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13220                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13221 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13222 !  terms.
13223                 d_cont(num_conti,i)=rij
13224 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13225 !     --- Electrostatic-interaction matrix ---
13226                 a_chuj(1,1,num_conti,i)=a22
13227                 a_chuj(1,2,num_conti,i)=a23
13228                 a_chuj(2,1,num_conti,i)=a32
13229                 a_chuj(2,2,num_conti,i)=a33
13230 !     --- Gradient of rij
13231                 do kkk=1,3
13232                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13233                 enddo
13234                 kkll=0
13235                 do k=1,2
13236                   do l=1,2
13237                     kkll=kkll+1
13238                     do m=1,3
13239                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13240                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13241                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13242                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13243                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13244                     enddo
13245                   enddo
13246                 enddo
13247                 ENDIF
13248                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13249 ! Calculate contact energies
13250                 cosa4=4.0D0*cosa
13251                 wij=cosa-3.0D0*cosb*cosg
13252                 cosbg1=cosb+cosg
13253                 cosbg2=cosb-cosg
13254 !               fac3=dsqrt(-ael6i)/r0ij**3
13255                 fac3=dsqrt(-ael6i)*r3ij
13256 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13257                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13258                 if (ees0tmp.gt.0) then
13259                   ees0pij=dsqrt(ees0tmp)
13260                 else
13261                   ees0pij=0
13262                 endif
13263 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13264                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13265                 if (ees0tmp.gt.0) then
13266                   ees0mij=dsqrt(ees0tmp)
13267                 else
13268                   ees0mij=0
13269                 endif
13270 !               ees0mij=0.0D0
13271                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13272                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13273 ! Diagnostics. Comment out or remove after debugging!
13274 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13275 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13276 !               ees0m(num_conti,i)=0.0D0
13277 ! End diagnostics.
13278 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13279 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13280 ! Angular derivatives of the contact function
13281                 ees0pij1=fac3/ees0pij
13282                 ees0mij1=fac3/ees0mij
13283                 fac3p=-3.0D0*fac3*rrmij
13284                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13285                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13286 !               ees0mij1=0.0D0
13287                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13288                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13289                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13290                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13291                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13292                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13293                 ecosap=ecosa1+ecosa2
13294                 ecosbp=ecosb1+ecosb2
13295                 ecosgp=ecosg1+ecosg2
13296                 ecosam=ecosa1-ecosa2
13297                 ecosbm=ecosb1-ecosb2
13298                 ecosgm=ecosg1-ecosg2
13299 ! Diagnostics
13300 !               ecosap=ecosa1
13301 !               ecosbp=ecosb1
13302 !               ecosgp=ecosg1
13303 !               ecosam=0.0D0
13304 !               ecosbm=0.0D0
13305 !               ecosgm=0.0D0
13306 ! End diagnostics
13307                 facont_hb(num_conti,i)=fcont
13308                 fprimcont=fprimcont/rij
13309 !d              facont_hb(num_conti,i)=1.0D0
13310 ! Following line is for diagnostics.
13311 !d              fprimcont=0.0D0
13312                 do k=1,3
13313                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13314                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13315                 enddo
13316                 do k=1,3
13317                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13318                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13319                 enddo
13320                 gggp(1)=gggp(1)+ees0pijp*xj
13321                 gggp(2)=gggp(2)+ees0pijp*yj
13322                 gggp(3)=gggp(3)+ees0pijp*zj
13323                 gggm(1)=gggm(1)+ees0mijp*xj
13324                 gggm(2)=gggm(2)+ees0mijp*yj
13325                 gggm(3)=gggm(3)+ees0mijp*zj
13326 ! Derivatives due to the contact function
13327                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13328                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13329                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13330                 do k=1,3
13331 !
13332 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13333 !          following the change of gradient-summation algorithm.
13334 !
13335 !grad                  ghalfp=0.5D0*gggp(k)
13336 !grad                  ghalfm=0.5D0*gggm(k)
13337                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13338                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13339                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13340                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13341                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13342                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13343                   gacontp_hb3(k,num_conti,i)=gggp(k)
13344                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13345                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13346                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13347                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13348                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13349                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13350                   gacontm_hb3(k,num_conti,i)=gggm(k)
13351                 enddo
13352               ENDIF ! wcorr
13353               endif  ! num_conti.le.maxconts
13354             endif  ! fcont.gt.0
13355           endif    ! j.gt.i+1
13356           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13357             do k=1,4
13358               do l=1,3
13359                 ghalf=0.5d0*agg(l,k)
13360                 aggi(l,k)=aggi(l,k)+ghalf
13361                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13362                 aggj(l,k)=aggj(l,k)+ghalf
13363               enddo
13364             enddo
13365             if (j.eq.nres-1 .and. i.lt.j-2) then
13366               do k=1,4
13367                 do l=1,3
13368                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13369                 enddo
13370               enddo
13371             endif
13372           endif
13373 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13374       return
13375       end subroutine eelecij_scale
13376 !-----------------------------------------------------------------------------
13377       subroutine evdwpp_short(evdw1)
13378 !
13379 ! Compute Evdwpp
13380 !
13381 !      implicit real*8 (a-h,o-z)
13382 !      include 'DIMENSIONS'
13383 !      include 'COMMON.CONTROL'
13384 !      include 'COMMON.IOUNITS'
13385 !      include 'COMMON.GEO'
13386 !      include 'COMMON.VAR'
13387 !      include 'COMMON.LOCAL'
13388 !      include 'COMMON.CHAIN'
13389 !      include 'COMMON.DERIV'
13390 !      include 'COMMON.INTERACT'
13391 !      include 'COMMON.CONTACTS'
13392 !      include 'COMMON.TORSION'
13393 !      include 'COMMON.VECTORS'
13394 !      include 'COMMON.FFIELD'
13395       real(kind=8),dimension(3) :: ggg
13396 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13397 #ifdef MOMENT
13398       real(kind=8) :: scal_el=1.0d0
13399 #else
13400       real(kind=8) :: scal_el=0.5d0
13401 #endif
13402 !el local variables
13403       integer :: i,j,k,iteli,itelj,num_conti
13404       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13405       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13406                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13407                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13408
13409       evdw1=0.0D0
13410 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13411 !     & " iatel_e_vdw",iatel_e_vdw
13412       call flush(iout)
13413       do i=iatel_s_vdw,iatel_e_vdw
13414         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13415         dxi=dc(1,i)
13416         dyi=dc(2,i)
13417         dzi=dc(3,i)
13418         dx_normi=dc_norm(1,i)
13419         dy_normi=dc_norm(2,i)
13420         dz_normi=dc_norm(3,i)
13421         xmedi=c(1,i)+0.5d0*dxi
13422         ymedi=c(2,i)+0.5d0*dyi
13423         zmedi=c(3,i)+0.5d0*dzi
13424         num_conti=0
13425 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13426 !     &   ' ielend',ielend_vdw(i)
13427         call flush(iout)
13428         do j=ielstart_vdw(i),ielend_vdw(i)
13429           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13430 !el          ind=ind+1
13431           iteli=itel(i)
13432           itelj=itel(j)
13433           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13434           aaa=app(iteli,itelj)
13435           bbb=bpp(iteli,itelj)
13436           dxj=dc(1,j)
13437           dyj=dc(2,j)
13438           dzj=dc(3,j)
13439           dx_normj=dc_norm(1,j)
13440           dy_normj=dc_norm(2,j)
13441           dz_normj=dc_norm(3,j)
13442           xj=c(1,j)+0.5D0*dxj-xmedi
13443           yj=c(2,j)+0.5D0*dyj-ymedi
13444           zj=c(3,j)+0.5D0*dzj-zmedi
13445           rij=xj*xj+yj*yj+zj*zj
13446           rrmij=1.0D0/rij
13447           rij=dsqrt(rij)
13448           sss=sscale(rij/rpp(iteli,itelj))
13449           if (sss.gt.0.0d0) then
13450             rmij=1.0D0/rij
13451             r3ij=rrmij*rmij
13452             r6ij=r3ij*r3ij
13453             ev1=aaa*r6ij*r6ij
13454 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13455             if (j.eq.i+2) ev1=scal_el*ev1
13456             ev2=bbb*r6ij
13457             evdwij=ev1+ev2
13458             if (energy_dec) then
13459               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13460             endif
13461             evdw1=evdw1+evdwij*sss
13462 !
13463 ! Calculate contributions to the Cartesian gradient.
13464 !
13465             facvdw=-6*rrmij*(ev1+evdwij)*sss
13466             ggg(1)=facvdw*xj
13467             ggg(2)=facvdw*yj
13468             ggg(3)=facvdw*zj
13469             do k=1,3
13470               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13471               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13472             enddo
13473           endif
13474         enddo ! j
13475       enddo   ! i
13476       return
13477       end subroutine evdwpp_short
13478 !-----------------------------------------------------------------------------
13479       subroutine escp_long(evdw2,evdw2_14)
13480 !
13481 ! This subroutine calculates the excluded-volume interaction energy between
13482 ! peptide-group centers and side chains and its gradient in virtual-bond and
13483 ! side-chain vectors.
13484 !
13485 !      implicit real*8 (a-h,o-z)
13486 !      include 'DIMENSIONS'
13487 !      include 'COMMON.GEO'
13488 !      include 'COMMON.VAR'
13489 !      include 'COMMON.LOCAL'
13490 !      include 'COMMON.CHAIN'
13491 !      include 'COMMON.DERIV'
13492 !      include 'COMMON.INTERACT'
13493 !      include 'COMMON.FFIELD'
13494 !      include 'COMMON.IOUNITS'
13495 !      include 'COMMON.CONTROL'
13496       real(kind=8),dimension(3) :: ggg
13497 !el local variables
13498       integer :: i,iint,j,k,iteli,itypj
13499       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13500       real(kind=8) :: evdw2,evdw2_14,evdwij
13501       evdw2=0.0D0
13502       evdw2_14=0.0d0
13503 !d    print '(a)','Enter ESCP'
13504 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13505       do i=iatscp_s,iatscp_e
13506         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13507         iteli=itel(i)
13508         xi=0.5D0*(c(1,i)+c(1,i+1))
13509         yi=0.5D0*(c(2,i)+c(2,i+1))
13510         zi=0.5D0*(c(3,i)+c(3,i+1))
13511
13512         do iint=1,nscp_gr(i)
13513
13514         do j=iscpstart(i,iint),iscpend(i,iint)
13515           itypj=itype(j)
13516           if (itypj.eq.ntyp1) cycle
13517 ! Uncomment following three lines for SC-p interactions
13518 !         xj=c(1,nres+j)-xi
13519 !         yj=c(2,nres+j)-yi
13520 !         zj=c(3,nres+j)-zi
13521 ! Uncomment following three lines for Ca-p interactions
13522           xj=c(1,j)-xi
13523           yj=c(2,j)-yi
13524           zj=c(3,j)-zi
13525           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13526
13527           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13528
13529           if (sss.lt.1.0d0) then
13530
13531             fac=rrij**expon2
13532             e1=fac*fac*aad(itypj,iteli)
13533             e2=fac*bad(itypj,iteli)
13534             if (iabs(j-i) .le. 2) then
13535               e1=scal14*e1
13536               e2=scal14*e2
13537               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13538             endif
13539             evdwij=e1+e2
13540             evdw2=evdw2+evdwij*(1.0d0-sss)
13541             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13542                 'evdw2',i,j,sss,evdwij
13543 !
13544 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13545 !
13546             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13547             ggg(1)=xj*fac
13548             ggg(2)=yj*fac
13549             ggg(3)=zj*fac
13550 ! Uncomment following three lines for SC-p interactions
13551 !           do k=1,3
13552 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13553 !           enddo
13554 ! Uncomment following line for SC-p interactions
13555 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13556             do k=1,3
13557               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13558               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13559             enddo
13560           endif
13561         enddo
13562
13563         enddo ! iint
13564       enddo ! i
13565       do i=1,nct
13566         do j=1,3
13567           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13568           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13569           gradx_scp(j,i)=expon*gradx_scp(j,i)
13570         enddo
13571       enddo
13572 !******************************************************************************
13573 !
13574 !                              N O T E !!!
13575 !
13576 ! To save time the factor EXPON has been extracted from ALL components
13577 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13578 ! use!
13579 !
13580 !******************************************************************************
13581       return
13582       end subroutine escp_long
13583 !-----------------------------------------------------------------------------
13584       subroutine escp_short(evdw2,evdw2_14)
13585 !
13586 ! This subroutine calculates the excluded-volume interaction energy between
13587 ! peptide-group centers and side chains and its gradient in virtual-bond and
13588 ! side-chain vectors.
13589 !
13590 !      implicit real*8 (a-h,o-z)
13591 !      include 'DIMENSIONS'
13592 !      include 'COMMON.GEO'
13593 !      include 'COMMON.VAR'
13594 !      include 'COMMON.LOCAL'
13595 !      include 'COMMON.CHAIN'
13596 !      include 'COMMON.DERIV'
13597 !      include 'COMMON.INTERACT'
13598 !      include 'COMMON.FFIELD'
13599 !      include 'COMMON.IOUNITS'
13600 !      include 'COMMON.CONTROL'
13601       real(kind=8),dimension(3) :: ggg
13602 !el local variables
13603       integer :: i,iint,j,k,iteli,itypj
13604       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13605       real(kind=8) :: evdw2,evdw2_14,evdwij
13606       evdw2=0.0D0
13607       evdw2_14=0.0d0
13608 !d    print '(a)','Enter ESCP'
13609 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13610       do i=iatscp_s,iatscp_e
13611         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13612         iteli=itel(i)
13613         xi=0.5D0*(c(1,i)+c(1,i+1))
13614         yi=0.5D0*(c(2,i)+c(2,i+1))
13615         zi=0.5D0*(c(3,i)+c(3,i+1))
13616
13617         do iint=1,nscp_gr(i)
13618
13619         do j=iscpstart(i,iint),iscpend(i,iint)
13620           itypj=itype(j)
13621           if (itypj.eq.ntyp1) cycle
13622 ! Uncomment following three lines for SC-p interactions
13623 !         xj=c(1,nres+j)-xi
13624 !         yj=c(2,nres+j)-yi
13625 !         zj=c(3,nres+j)-zi
13626 ! Uncomment following three lines for Ca-p interactions
13627           xj=c(1,j)-xi
13628           yj=c(2,j)-yi
13629           zj=c(3,j)-zi
13630           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13631
13632           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13633
13634           if (sss.gt.0.0d0) then
13635
13636             fac=rrij**expon2
13637             e1=fac*fac*aad(itypj,iteli)
13638             e2=fac*bad(itypj,iteli)
13639             if (iabs(j-i) .le. 2) then
13640               e1=scal14*e1
13641               e2=scal14*e2
13642               evdw2_14=evdw2_14+(e1+e2)*sss
13643             endif
13644             evdwij=e1+e2
13645             evdw2=evdw2+evdwij*sss
13646             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13647                 'evdw2',i,j,sss,evdwij
13648 !
13649 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13650 !
13651             fac=-(evdwij+e1)*rrij*sss
13652             ggg(1)=xj*fac
13653             ggg(2)=yj*fac
13654             ggg(3)=zj*fac
13655 ! Uncomment following three lines for SC-p interactions
13656 !           do k=1,3
13657 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13658 !           enddo
13659 ! Uncomment following line for SC-p interactions
13660 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13661             do k=1,3
13662               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13663               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13664             enddo
13665           endif
13666         enddo
13667
13668         enddo ! iint
13669       enddo ! i
13670       do i=1,nct
13671         do j=1,3
13672           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13673           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13674           gradx_scp(j,i)=expon*gradx_scp(j,i)
13675         enddo
13676       enddo
13677 !******************************************************************************
13678 !
13679 !                              N O T E !!!
13680 !
13681 ! To save time the factor EXPON has been extracted from ALL components
13682 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13683 ! use!
13684 !
13685 !******************************************************************************
13686       return
13687       end subroutine escp_short
13688 !-----------------------------------------------------------------------------
13689 ! energy_p_new-sep_barrier.F
13690 !-----------------------------------------------------------------------------
13691       subroutine sc_grad_scale(scalfac)
13692 !      implicit real*8 (a-h,o-z)
13693       use calc_data
13694 !      include 'DIMENSIONS'
13695 !      include 'COMMON.CHAIN'
13696 !      include 'COMMON.DERIV'
13697 !      include 'COMMON.CALC'
13698 !      include 'COMMON.IOUNITS'
13699       real(kind=8),dimension(3) :: dcosom1,dcosom2
13700       real(kind=8) :: scalfac
13701 !el local variables
13702 !      integer :: i,j,k,l
13703
13704       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13705       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13706       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13707            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13708 ! diagnostics only
13709 !      eom1=0.0d0
13710 !      eom2=0.0d0
13711 !      eom12=evdwij*eps1_om12
13712 ! end diagnostics
13713 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13714 !     &  " sigder",sigder
13715 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13716 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13717       do k=1,3
13718         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13719         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13720       enddo
13721       do k=1,3
13722         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13723          *sss_ele_cut
13724       enddo
13725 !      write (iout,*) "gg",(gg(k),k=1,3)
13726       do k=1,3
13727         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13728                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13729                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13730                  *sss_ele_cut
13731         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13732                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13733                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13734          *sss_ele_cut
13735 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13736 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13737 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13738 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13739       enddo
13740 !
13741 ! Calculate the components of the gradient in DC and X
13742 !
13743       do l=1,3
13744         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13745         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13746       enddo
13747       return
13748       end subroutine sc_grad_scale
13749 !-----------------------------------------------------------------------------
13750 ! energy_split-sep.F
13751 !-----------------------------------------------------------------------------
13752       subroutine etotal_long(energia)
13753 !
13754 ! Compute the long-range slow-varying contributions to the energy
13755 !
13756 !      implicit real*8 (a-h,o-z)
13757 !      include 'DIMENSIONS'
13758       use MD_data, only: totT,usampl,eq_time
13759 #ifndef ISNAN
13760       external proc_proc
13761 #ifdef WINPGI
13762 !MS$ATTRIBUTES C ::  proc_proc
13763 #endif
13764 #endif
13765 #ifdef MPI
13766       include "mpif.h"
13767       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13768 #endif
13769 !      include 'COMMON.SETUP'
13770 !      include 'COMMON.IOUNITS'
13771 !      include 'COMMON.FFIELD'
13772 !      include 'COMMON.DERIV'
13773 !      include 'COMMON.INTERACT'
13774 !      include 'COMMON.SBRIDGE'
13775 !      include 'COMMON.CHAIN'
13776 !      include 'COMMON.VAR'
13777 !      include 'COMMON.LOCAL'
13778 !      include 'COMMON.MD'
13779       real(kind=8),dimension(0:n_ene) :: energia
13780 !el local variables
13781       integer :: i,n_corr,n_corr1,ierror,ierr
13782       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13783                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13784                   ecorr,ecorr5,ecorr6,eturn6,time00
13785 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13786 !elwrite(iout,*)"in etotal long"
13787
13788       if (modecalc.eq.12.or.modecalc.eq.14) then
13789 #ifdef MPI
13790 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13791 #else
13792         call int_from_cart1(.false.)
13793 #endif
13794       endif
13795 !elwrite(iout,*)"in etotal long"
13796
13797 #ifdef MPI
13798 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13799 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13800       call flush(iout)
13801       if (nfgtasks.gt.1) then
13802         time00=MPI_Wtime()
13803 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13804         if (fg_rank.eq.0) then
13805           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13806 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13807 !          call flush(iout)
13808 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13809 ! FG slaves as WEIGHTS array.
13810           weights_(1)=wsc
13811           weights_(2)=wscp
13812           weights_(3)=welec
13813           weights_(4)=wcorr
13814           weights_(5)=wcorr5
13815           weights_(6)=wcorr6
13816           weights_(7)=wel_loc
13817           weights_(8)=wturn3
13818           weights_(9)=wturn4
13819           weights_(10)=wturn6
13820           weights_(11)=wang
13821           weights_(12)=wscloc
13822           weights_(13)=wtor
13823           weights_(14)=wtor_d
13824           weights_(15)=wstrain
13825           weights_(16)=wvdwpp
13826           weights_(17)=wbond
13827           weights_(18)=scal14
13828           weights_(21)=wsccor
13829 ! FG Master broadcasts the WEIGHTS_ array
13830           call MPI_Bcast(weights_(1),n_ene,&
13831               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13832         else
13833 ! FG slaves receive the WEIGHTS array
13834           call MPI_Bcast(weights(1),n_ene,&
13835               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13836           wsc=weights(1)
13837           wscp=weights(2)
13838           welec=weights(3)
13839           wcorr=weights(4)
13840           wcorr5=weights(5)
13841           wcorr6=weights(6)
13842           wel_loc=weights(7)
13843           wturn3=weights(8)
13844           wturn4=weights(9)
13845           wturn6=weights(10)
13846           wang=weights(11)
13847           wscloc=weights(12)
13848           wtor=weights(13)
13849           wtor_d=weights(14)
13850           wstrain=weights(15)
13851           wvdwpp=weights(16)
13852           wbond=weights(17)
13853           scal14=weights(18)
13854           wsccor=weights(21)
13855         endif
13856         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13857           king,FG_COMM,IERR)
13858          time_Bcast=time_Bcast+MPI_Wtime()-time00
13859          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13860 !        call chainbuild_cart
13861 !        call int_from_cart1(.false.)
13862       endif
13863 !      write (iout,*) 'Processor',myrank,
13864 !     &  ' calling etotal_short ipot=',ipot
13865 !      call flush(iout)
13866 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13867 #endif
13868 !d    print *,'nnt=',nnt,' nct=',nct
13869 !
13870 !elwrite(iout,*)"in etotal long"
13871 ! Compute the side-chain and electrostatic interaction energy
13872 !
13873       goto (101,102,103,104,105,106) ipot
13874 ! Lennard-Jones potential.
13875   101 call elj_long(evdw)
13876 !d    print '(a)','Exit ELJ'
13877       goto 107
13878 ! Lennard-Jones-Kihara potential (shifted).
13879   102 call eljk_long(evdw)
13880       goto 107
13881 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13882   103 call ebp_long(evdw)
13883       goto 107
13884 ! Gay-Berne potential (shifted LJ, angular dependence).
13885   104 call egb_long(evdw)
13886       goto 107
13887 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13888   105 call egbv_long(evdw)
13889       goto 107
13890 ! Soft-sphere potential
13891   106 call e_softsphere(evdw)
13892 !
13893 ! Calculate electrostatic (H-bonding) energy of the main chain.
13894 !
13895   107 continue
13896       call vec_and_deriv
13897       if (ipot.lt.6) then
13898 #ifdef SPLITELE
13899          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13900              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13901              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13902              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13903 #else
13904          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13905              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13906              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13907              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13908 #endif
13909            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13910          else
13911             ees=0
13912             evdw1=0
13913             eel_loc=0
13914             eello_turn3=0
13915             eello_turn4=0
13916          endif
13917       else
13918 !        write (iout,*) "Soft-spheer ELEC potential"
13919         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13920          eello_turn4)
13921       endif
13922 !
13923 ! Calculate excluded-volume interaction energy between peptide groups
13924 ! and side chains.
13925 !
13926       if (ipot.lt.6) then
13927        if(wscp.gt.0d0) then
13928         call escp_long(evdw2,evdw2_14)
13929        else
13930         evdw2=0
13931         evdw2_14=0
13932        endif
13933       else
13934         call escp_soft_sphere(evdw2,evdw2_14)
13935       endif
13936 !
13937 ! 12/1/95 Multi-body terms
13938 !
13939       n_corr=0
13940       n_corr1=0
13941       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13942           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13943          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13944 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13945 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13946       else
13947          ecorr=0.0d0
13948          ecorr5=0.0d0
13949          ecorr6=0.0d0
13950          eturn6=0.0d0
13951       endif
13952       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13953          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13954       endif
13955 !
13956 ! If performing constraint dynamics, call the constraint energy
13957 !  after the equilibration time
13958       if(usampl.and.totT.gt.eq_time) then
13959          call EconstrQ
13960          call Econstr_back
13961       else
13962          Uconst=0.0d0
13963          Uconst_back=0.0d0
13964       endif
13965 !
13966 ! Sum the energies
13967 !
13968       do i=1,n_ene
13969         energia(i)=0.0d0
13970       enddo
13971       energia(1)=evdw
13972 #ifdef SCP14
13973       energia(2)=evdw2-evdw2_14
13974       energia(18)=evdw2_14
13975 #else
13976       energia(2)=evdw2
13977       energia(18)=0.0d0
13978 #endif
13979 #ifdef SPLITELE
13980       energia(3)=ees
13981       energia(16)=evdw1
13982 #else
13983       energia(3)=ees+evdw1
13984       energia(16)=0.0d0
13985 #endif
13986       energia(4)=ecorr
13987       energia(5)=ecorr5
13988       energia(6)=ecorr6
13989       energia(7)=eel_loc
13990       energia(8)=eello_turn3
13991       energia(9)=eello_turn4
13992       energia(10)=eturn6
13993       energia(20)=Uconst+Uconst_back
13994       call sum_energy(energia,.true.)
13995 !      write (iout,*) "Exit ETOTAL_LONG"
13996       call flush(iout)
13997       return
13998       end subroutine etotal_long
13999 !-----------------------------------------------------------------------------
14000       subroutine etotal_short(energia)
14001 !
14002 ! Compute the short-range fast-varying contributions to the energy
14003 !
14004 !      implicit real*8 (a-h,o-z)
14005 !      include 'DIMENSIONS'
14006 #ifndef ISNAN
14007       external proc_proc
14008 #ifdef WINPGI
14009 !MS$ATTRIBUTES C ::  proc_proc
14010 #endif
14011 #endif
14012 #ifdef MPI
14013       include "mpif.h"
14014       integer :: ierror,ierr
14015       real(kind=8),dimension(n_ene) :: weights_
14016       real(kind=8) :: time00
14017 #endif
14018 !      include 'COMMON.SETUP'
14019 !      include 'COMMON.IOUNITS'
14020 !      include 'COMMON.FFIELD'
14021 !      include 'COMMON.DERIV'
14022 !      include 'COMMON.INTERACT'
14023 !      include 'COMMON.SBRIDGE'
14024 !      include 'COMMON.CHAIN'
14025 !      include 'COMMON.VAR'
14026 !      include 'COMMON.LOCAL'
14027       real(kind=8),dimension(0:n_ene) :: energia
14028 !el local variables
14029       integer :: i,nres6
14030       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
14031       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
14032       nres6=6*nres
14033
14034 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
14035 !      call flush(iout)
14036       if (modecalc.eq.12.or.modecalc.eq.14) then
14037 #ifdef MPI
14038         if (fg_rank.eq.0) call int_from_cart1(.false.)
14039 #else
14040         call int_from_cart1(.false.)
14041 #endif
14042       endif
14043 #ifdef MPI
14044 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
14045 !     & " absolute rank",myrank," nfgtasks",nfgtasks
14046 !      call flush(iout)
14047       if (nfgtasks.gt.1) then
14048         time00=MPI_Wtime()
14049 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
14050         if (fg_rank.eq.0) then
14051           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
14052 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
14053 !          call flush(iout)
14054 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
14055 ! FG slaves as WEIGHTS array.
14056           weights_(1)=wsc
14057           weights_(2)=wscp
14058           weights_(3)=welec
14059           weights_(4)=wcorr
14060           weights_(5)=wcorr5
14061           weights_(6)=wcorr6
14062           weights_(7)=wel_loc
14063           weights_(8)=wturn3
14064           weights_(9)=wturn4
14065           weights_(10)=wturn6
14066           weights_(11)=wang
14067           weights_(12)=wscloc
14068           weights_(13)=wtor
14069           weights_(14)=wtor_d
14070           weights_(15)=wstrain
14071           weights_(16)=wvdwpp
14072           weights_(17)=wbond
14073           weights_(18)=scal14
14074           weights_(21)=wsccor
14075 ! FG Master broadcasts the WEIGHTS_ array
14076           call MPI_Bcast(weights_(1),n_ene,&
14077               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14078         else
14079 ! FG slaves receive the WEIGHTS array
14080           call MPI_Bcast(weights(1),n_ene,&
14081               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14082           wsc=weights(1)
14083           wscp=weights(2)
14084           welec=weights(3)
14085           wcorr=weights(4)
14086           wcorr5=weights(5)
14087           wcorr6=weights(6)
14088           wel_loc=weights(7)
14089           wturn3=weights(8)
14090           wturn4=weights(9)
14091           wturn6=weights(10)
14092           wang=weights(11)
14093           wscloc=weights(12)
14094           wtor=weights(13)
14095           wtor_d=weights(14)
14096           wstrain=weights(15)
14097           wvdwpp=weights(16)
14098           wbond=weights(17)
14099           scal14=weights(18)
14100           wsccor=weights(21)
14101         endif
14102 !        write (iout,*),"Processor",myrank," BROADCAST weights"
14103         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
14104           king,FG_COMM,IERR)
14105 !        write (iout,*) "Processor",myrank," BROADCAST c"
14106         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
14107           king,FG_COMM,IERR)
14108 !        write (iout,*) "Processor",myrank," BROADCAST dc"
14109         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
14110           king,FG_COMM,IERR)
14111 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
14112         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
14113           king,FG_COMM,IERR)
14114 !        write (iout,*) "Processor",myrank," BROADCAST theta"
14115         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
14116           king,FG_COMM,IERR)
14117 !        write (iout,*) "Processor",myrank," BROADCAST phi"
14118         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
14119           king,FG_COMM,IERR)
14120 !        write (iout,*) "Processor",myrank," BROADCAST alph"
14121         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
14122           king,FG_COMM,IERR)
14123 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
14124         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
14125           king,FG_COMM,IERR)
14126 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
14127         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
14128           king,FG_COMM,IERR)
14129          time_Bcast=time_Bcast+MPI_Wtime()-time00
14130 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
14131       endif
14132 !      write (iout,*) 'Processor',myrank,
14133 !     &  ' calling etotal_short ipot=',ipot
14134 !      call flush(iout)
14135 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14136 #endif
14137 !      call int_from_cart1(.false.)
14138 !
14139 ! Compute the side-chain and electrostatic interaction energy
14140 !
14141       goto (101,102,103,104,105,106) ipot
14142 ! Lennard-Jones potential.
14143   101 call elj_short(evdw)
14144 !d    print '(a)','Exit ELJ'
14145       goto 107
14146 ! Lennard-Jones-Kihara potential (shifted).
14147   102 call eljk_short(evdw)
14148       goto 107
14149 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14150   103 call ebp_short(evdw)
14151       goto 107
14152 ! Gay-Berne potential (shifted LJ, angular dependence).
14153   104 call egb_short(evdw)
14154       goto 107
14155 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14156   105 call egbv_short(evdw)
14157       goto 107
14158 ! Soft-sphere potential - already dealt with in the long-range part
14159   106 evdw=0.0d0
14160 !  106 call e_softsphere_short(evdw)
14161 !
14162 ! Calculate electrostatic (H-bonding) energy of the main chain.
14163 !
14164   107 continue
14165 !
14166 ! Calculate the short-range part of Evdwpp
14167 !
14168       call evdwpp_short(evdw1)
14169 !
14170 ! Calculate the short-range part of ESCp
14171 !
14172       if (ipot.lt.6) then
14173         call escp_short(evdw2,evdw2_14)
14174       endif
14175 !
14176 ! Calculate the bond-stretching energy
14177 !
14178       call ebond(estr)
14179 !
14180 ! Calculate the disulfide-bridge and other energy and the contributions
14181 ! from other distance constraints.
14182       call edis(ehpb)
14183 !
14184 ! Calculate the virtual-bond-angle energy.
14185 !
14186       call ebend(ebe)
14187 !
14188 ! Calculate the SC local energy.
14189 !
14190       call vec_and_deriv
14191       call esc(escloc)
14192 !
14193 ! Calculate the virtual-bond torsional energy.
14194 !
14195       call etor(etors,edihcnstr)
14196 !
14197 ! 6/23/01 Calculate double-torsional energy
14198 !
14199       call etor_d(etors_d)
14200 !
14201 ! 21/5/07 Calculate local sicdechain correlation energy
14202 !
14203       if (wsccor.gt.0.0d0) then
14204         call eback_sc_corr(esccor)
14205       else
14206         esccor=0.0d0
14207       endif
14208 !
14209 ! Put energy components into an array
14210 !
14211       do i=1,n_ene
14212         energia(i)=0.0d0
14213       enddo
14214       energia(1)=evdw
14215 #ifdef SCP14
14216       energia(2)=evdw2-evdw2_14
14217       energia(18)=evdw2_14
14218 #else
14219       energia(2)=evdw2
14220       energia(18)=0.0d0
14221 #endif
14222 #ifdef SPLITELE
14223       energia(16)=evdw1
14224 #else
14225       energia(3)=evdw1
14226 #endif
14227       energia(11)=ebe
14228       energia(12)=escloc
14229       energia(13)=etors
14230       energia(14)=etors_d
14231       energia(15)=ehpb
14232       energia(17)=estr
14233       energia(19)=edihcnstr
14234       energia(21)=esccor
14235 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14236       call flush(iout)
14237       call sum_energy(energia,.true.)
14238 !      write (iout,*) "Exit ETOTAL_SHORT"
14239       call flush(iout)
14240       return
14241       end subroutine etotal_short
14242 !-----------------------------------------------------------------------------
14243 ! gnmr1.f
14244 !-----------------------------------------------------------------------------
14245       real(kind=8) function gnmr1(y,ymin,ymax)
14246 !      implicit none
14247       real(kind=8) :: y,ymin,ymax
14248       real(kind=8) :: wykl=4.0d0
14249       if (y.lt.ymin) then
14250         gnmr1=(ymin-y)**wykl/wykl
14251       else if (y.gt.ymax) then
14252         gnmr1=(y-ymax)**wykl/wykl
14253       else
14254         gnmr1=0.0d0
14255       endif
14256       return
14257       end function gnmr1
14258 !-----------------------------------------------------------------------------
14259       real(kind=8) function gnmr1prim(y,ymin,ymax)
14260 !      implicit none
14261       real(kind=8) :: y,ymin,ymax
14262       real(kind=8) :: wykl=4.0d0
14263       if (y.lt.ymin) then
14264         gnmr1prim=-(ymin-y)**(wykl-1)
14265       else if (y.gt.ymax) then
14266         gnmr1prim=(y-ymax)**(wykl-1)
14267       else
14268         gnmr1prim=0.0d0
14269       endif
14270       return
14271       end function gnmr1prim
14272 !-----------------------------------------------------------------------------
14273       real(kind=8) function harmonic(y,ymax)
14274 !      implicit none
14275       real(kind=8) :: y,ymax
14276       real(kind=8) :: wykl=2.0d0
14277       harmonic=(y-ymax)**wykl
14278       return
14279       end function harmonic
14280 !-----------------------------------------------------------------------------
14281       real(kind=8) function harmonicprim(y,ymax)
14282       real(kind=8) :: y,ymin,ymax
14283       real(kind=8) :: wykl=2.0d0
14284       harmonicprim=(y-ymax)*wykl
14285       return
14286       end function harmonicprim
14287 !-----------------------------------------------------------------------------
14288 ! gradient_p.F
14289 !-----------------------------------------------------------------------------
14290       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14291
14292       use io_base, only:intout,briefout
14293 !      implicit real*8 (a-h,o-z)
14294 !      include 'DIMENSIONS'
14295 !      include 'COMMON.CHAIN'
14296 !      include 'COMMON.DERIV'
14297 !      include 'COMMON.VAR'
14298 !      include 'COMMON.INTERACT'
14299 !      include 'COMMON.FFIELD'
14300 !      include 'COMMON.MD'
14301 !      include 'COMMON.IOUNITS'
14302       real(kind=8),external :: ufparm
14303       integer :: uiparm(1)
14304       real(kind=8) :: urparm(1)
14305       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14306       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14307       integer :: n,nf,ind,ind1,i,k,j
14308 !
14309 ! This subroutine calculates total internal coordinate gradient.
14310 ! Depending on the number of function evaluations, either whole energy
14311 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14312 ! internal coordinates are reevaluated or only the cartesian-in-internal
14313 ! coordinate derivatives are evaluated. The subroutine was designed to work
14314 ! with SUMSL.
14315 !
14316 !
14317       icg=mod(nf,2)+1
14318
14319 !d      print *,'grad',nf,icg
14320       if (nf-nfl+1) 20,30,40
14321    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14322 !    write (iout,*) 'grad 20'
14323       if (nf.eq.0) return
14324       goto 40
14325    30 call var_to_geom(n,x)
14326       call chainbuild
14327 !    write (iout,*) 'grad 30'
14328 !
14329 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14330 !
14331    40 call cartder
14332 !     write (iout,*) 'grad 40'
14333 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14334 !
14335 ! Convert the Cartesian gradient into internal-coordinate gradient.
14336 !
14337       ind=0
14338       ind1=0
14339       do i=1,nres-2
14340         gthetai=0.0D0
14341         gphii=0.0D0
14342         do j=i+1,nres-1
14343           ind=ind+1
14344 !         ind=indmat(i,j)
14345 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14346           do k=1,3
14347             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14348           enddo
14349           do k=1,3
14350             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14351           enddo
14352         enddo
14353         do j=i+1,nres-1
14354           ind1=ind1+1
14355 !         ind1=indmat(i,j)
14356 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14357           do k=1,3
14358             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14359             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14360           enddo
14361         enddo
14362         if (i.gt.1) g(i-1)=gphii
14363         if (n.gt.nphi) g(nphi+i)=gthetai
14364       enddo
14365       if (n.le.nphi+ntheta) goto 10
14366       do i=2,nres-1
14367         if (itype(i).ne.10) then
14368           galphai=0.0D0
14369           gomegai=0.0D0
14370           do k=1,3
14371             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14372           enddo
14373           do k=1,3
14374             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14375           enddo
14376           g(ialph(i,1))=galphai
14377           g(ialph(i,1)+nside)=gomegai
14378         endif
14379       enddo
14380 !
14381 ! Add the components corresponding to local energy terms.
14382 !
14383    10 continue
14384       do i=1,nvar
14385 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14386         g(i)=g(i)+gloc(i,icg)
14387       enddo
14388 ! Uncomment following three lines for diagnostics.
14389 !d    call intout
14390 !elwrite(iout,*) "in gradient after calling intout"
14391 !d    call briefout(0,0.0d0)
14392 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14393       return
14394       end subroutine gradient
14395 !-----------------------------------------------------------------------------
14396       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14397
14398       use comm_chu
14399 !      implicit real*8 (a-h,o-z)
14400 !      include 'DIMENSIONS'
14401 !      include 'COMMON.DERIV'
14402 !      include 'COMMON.IOUNITS'
14403 !      include 'COMMON.GEO'
14404       integer :: n,nf
14405 !el      integer :: jjj
14406 !el      common /chuju/ jjj
14407       real(kind=8) :: energia(0:n_ene)
14408       integer :: uiparm(1)
14409       real(kind=8) :: urparm(1)
14410       real(kind=8) :: f
14411       real(kind=8),external :: ufparm
14412       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14413 !     if (jjj.gt.0) then
14414 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14415 !     endif
14416       nfl=nf
14417       icg=mod(nf,2)+1
14418 !d      print *,'func',nf,nfl,icg
14419       call var_to_geom(n,x)
14420       call zerograd
14421       call chainbuild
14422 !d    write (iout,*) 'ETOTAL called from FUNC'
14423       call etotal(energia)
14424       call sum_gradient
14425       f=energia(0)
14426 !     if (jjj.gt.0) then
14427 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14428 !       write (iout,*) 'f=',etot
14429 !       jjj=0
14430 !     endif
14431       return
14432       end subroutine func
14433 !-----------------------------------------------------------------------------
14434       subroutine cartgrad
14435 !      implicit real*8 (a-h,o-z)
14436 !      include 'DIMENSIONS'
14437       use energy_data
14438       use MD_data, only: totT,usampl,eq_time
14439 #ifdef MPI
14440       include 'mpif.h'
14441 #endif
14442 !      include 'COMMON.CHAIN'
14443 !      include 'COMMON.DERIV'
14444 !      include 'COMMON.VAR'
14445 !      include 'COMMON.INTERACT'
14446 !      include 'COMMON.FFIELD'
14447 !      include 'COMMON.MD'
14448 !      include 'COMMON.IOUNITS'
14449 !      include 'COMMON.TIME1'
14450 !
14451       integer :: i,j
14452
14453 ! This subrouting calculates total Cartesian coordinate gradient.
14454 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14455 !
14456 !el#define DEBUG
14457 #ifdef TIMING
14458       time00=MPI_Wtime()
14459 #endif
14460       icg=1
14461       call sum_gradient
14462 #ifdef TIMING
14463 #endif
14464 !el      write (iout,*) "After sum_gradient"
14465 #ifdef DEBUG
14466 !el      write (iout,*) "After sum_gradient"
14467       do i=1,nres-1
14468         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14469         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14470       enddo
14471 #endif
14472 ! If performing constraint dynamics, add the gradients of the constraint energy
14473       if(usampl.and.totT.gt.eq_time) then
14474          do i=1,nct
14475            do j=1,3
14476              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14477              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14478            enddo
14479          enddo
14480          do i=1,nres-3
14481            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14482          enddo
14483          do i=1,nres-2
14484            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14485          enddo
14486       endif
14487 !elwrite (iout,*) "After sum_gradient"
14488 #ifdef TIMING
14489       time01=MPI_Wtime()
14490 #endif
14491       call intcartderiv
14492 !elwrite (iout,*) "After sum_gradient"
14493 #ifdef TIMING
14494       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14495 #endif
14496 !     call checkintcartgrad
14497 !     write(iout,*) 'calling int_to_cart'
14498 #ifdef DEBUG
14499       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14500 #endif
14501       do i=1,nct
14502         do j=1,3
14503           gcart(j,i)=gradc(j,i,icg)
14504           gxcart(j,i)=gradx(j,i,icg)
14505         enddo
14506 #ifdef DEBUG
14507         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14508           (gxcart(j,i),j=1,3),gloc(i,icg)
14509 #endif
14510       enddo
14511 #ifdef TIMING
14512       time01=MPI_Wtime()
14513 #endif
14514       call int_to_cart
14515 #ifdef TIMING
14516       time_inttocart=time_inttocart+MPI_Wtime()-time01
14517 #endif
14518 #ifdef DEBUG
14519       write (iout,*) "gcart and gxcart after int_to_cart"
14520       do i=0,nres-1
14521         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14522             (gxcart(j,i),j=1,3)
14523       enddo
14524 #endif
14525 #ifdef CARGRAD
14526 #ifdef DEBUG
14527       write (iout,*) "CARGRAD"
14528 #endif
14529       do i=nres,1,-1
14530         do j=1,3
14531           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14532 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14533         enddo
14534 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14535 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14536       enddo
14537 ! Correction: dummy residues
14538         if (nnt.gt.1) then
14539           do j=1,3
14540 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14541             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14542           enddo
14543         endif
14544         if (nct.lt.nres) then
14545           do j=1,3
14546 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14547             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14548           enddo
14549         endif
14550 #endif
14551 #ifdef TIMING
14552       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14553 #endif
14554 !el#undef DEBUG
14555       return
14556       end subroutine cartgrad
14557 !-----------------------------------------------------------------------------
14558       subroutine zerograd
14559 !      implicit real*8 (a-h,o-z)
14560 !      include 'DIMENSIONS'
14561 !      include 'COMMON.DERIV'
14562 !      include 'COMMON.CHAIN'
14563 !      include 'COMMON.VAR'
14564 !      include 'COMMON.MD'
14565 !      include 'COMMON.SCCOR'
14566 !
14567 !el local variables
14568       integer :: i,j,intertyp
14569 ! Initialize Cartesian-coordinate gradient
14570 !
14571 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14572 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14573
14574 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14575 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14576 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14577 !      allocate(gradcorr_long(3,nres))
14578 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14579 !      allocate(gcorr6_turn_long(3,nres))
14580 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14581
14582 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14583
14584 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14585 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14586
14587 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14588 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14589
14590 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14591 !      allocate(gscloc(3,nres)) !(3,maxres)
14592 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14593
14594
14595
14596 !      common /deriv_scloc/
14597 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14598 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14599 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14600 !      common /mpgrad/
14601 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14602
14603
14604
14605 !          gradc(j,i,icg)=0.0d0
14606 !          gradx(j,i,icg)=0.0d0
14607
14608 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14609 !elwrite(iout,*) "icg",icg
14610       do i=1,nres
14611         do j=1,3
14612           gvdwx(j,i)=0.0D0
14613           gradx_scp(j,i)=0.0D0
14614           gvdwc(j,i)=0.0D0
14615           gvdwc_scp(j,i)=0.0D0
14616           gvdwc_scpp(j,i)=0.0d0
14617           gelc(j,i)=0.0D0
14618           gelc_long(j,i)=0.0D0
14619           gradb(j,i)=0.0d0
14620           gradbx(j,i)=0.0d0
14621           gvdwpp(j,i)=0.0d0
14622           gel_loc(j,i)=0.0d0
14623           gel_loc_long(j,i)=0.0d0
14624           ghpbc(j,i)=0.0D0
14625           ghpbx(j,i)=0.0D0
14626           gcorr3_turn(j,i)=0.0d0
14627           gcorr4_turn(j,i)=0.0d0
14628           gradcorr(j,i)=0.0d0
14629           gradcorr_long(j,i)=0.0d0
14630           gradcorr5_long(j,i)=0.0d0
14631           gradcorr6_long(j,i)=0.0d0
14632           gcorr6_turn_long(j,i)=0.0d0
14633           gradcorr5(j,i)=0.0d0
14634           gradcorr6(j,i)=0.0d0
14635           gcorr6_turn(j,i)=0.0d0
14636           gsccorc(j,i)=0.0d0
14637           gsccorx(j,i)=0.0d0
14638           gradc(j,i,icg)=0.0d0
14639           gradx(j,i,icg)=0.0d0
14640           gscloc(j,i)=0.0d0
14641           gsclocx(j,i)=0.0d0
14642           do intertyp=1,3
14643            gloc_sc(intertyp,i,icg)=0.0d0
14644           enddo
14645         enddo
14646       enddo
14647 !
14648 ! Initialize the gradient of local energy terms.
14649 !
14650 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14651 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14652 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14653 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14654 !      allocate(gel_loc_turn3(nres))
14655 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14656 !      allocate(gsccor_loc(nres))       !(maxres)
14657
14658       do i=1,4*nres
14659         gloc(i,icg)=0.0D0
14660       enddo
14661       do i=1,nres
14662         gel_loc_loc(i)=0.0d0
14663         gcorr_loc(i)=0.0d0
14664         g_corr5_loc(i)=0.0d0
14665         g_corr6_loc(i)=0.0d0
14666         gel_loc_turn3(i)=0.0d0
14667         gel_loc_turn4(i)=0.0d0
14668         gel_loc_turn6(i)=0.0d0
14669         gsccor_loc(i)=0.0d0
14670       enddo
14671 ! initialize gcart and gxcart
14672 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14673       do i=0,nres
14674         do j=1,3
14675           gcart(j,i)=0.0d0
14676           gxcart(j,i)=0.0d0
14677         enddo
14678       enddo
14679       return
14680       end subroutine zerograd
14681 !-----------------------------------------------------------------------------
14682       real(kind=8) function fdum()
14683       fdum=0.0D0
14684       return
14685       end function fdum
14686 !-----------------------------------------------------------------------------
14687 ! intcartderiv.F
14688 !-----------------------------------------------------------------------------
14689       subroutine intcartderiv
14690 !      implicit real*8 (a-h,o-z)
14691 !      include 'DIMENSIONS'
14692 #ifdef MPI
14693       include 'mpif.h'
14694 #endif
14695 !      include 'COMMON.SETUP'
14696 !      include 'COMMON.CHAIN'
14697 !      include 'COMMON.VAR'
14698 !      include 'COMMON.GEO'
14699 !      include 'COMMON.INTERACT'
14700 !      include 'COMMON.DERIV'
14701 !      include 'COMMON.IOUNITS'
14702 !      include 'COMMON.LOCAL'
14703 !      include 'COMMON.SCCOR'
14704       real(kind=8) :: pi4,pi34
14705       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14706       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14707                     dcosomega,dsinomega !(3,3,maxres)
14708       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14709
14710       integer :: i,j,k
14711       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14712                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14713                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14714                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14715       integer :: nres2
14716       nres2=2*nres
14717
14718 !el from module energy-------------
14719 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14720 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14721 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14722
14723 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14724 !el      allocate(dsintau(3,3,3,0:nres2))
14725 !el      allocate(dtauangle(3,3,3,0:nres2))
14726 !el      allocate(domicron(3,2,2,0:nres2))
14727 !el      allocate(dcosomicron(3,2,2,0:nres2))
14728
14729
14730
14731 #if defined(MPI) && defined(PARINTDER)
14732       if (nfgtasks.gt.1 .and. me.eq.king) &
14733         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14734 #endif
14735       pi4 = 0.5d0*pipol
14736       pi34 = 3*pi4
14737
14738 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14739 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14740
14741 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14742       do i=1,nres
14743         do j=1,3
14744           dtheta(j,1,i)=0.0d0
14745           dtheta(j,2,i)=0.0d0
14746           dphi(j,1,i)=0.0d0
14747           dphi(j,2,i)=0.0d0
14748           dphi(j,3,i)=0.0d0
14749         enddo
14750       enddo
14751 ! Derivatives of theta's
14752 #if defined(MPI) && defined(PARINTDER)
14753 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14754       do i=max0(ithet_start-1,3),ithet_end
14755 #else
14756       do i=3,nres
14757 #endif
14758         cost=dcos(theta(i))
14759         sint=sqrt(1-cost*cost)
14760         do j=1,3
14761           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14762           vbld(i-1)
14763           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14764           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14765           vbld(i)
14766           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14767         enddo
14768       enddo
14769 #if defined(MPI) && defined(PARINTDER)
14770 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14771       do i=max0(ithet_start-1,3),ithet_end
14772 #else
14773       do i=3,nres
14774 #endif
14775       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14776         cost1=dcos(omicron(1,i))
14777         sint1=sqrt(1-cost1*cost1)
14778         cost2=dcos(omicron(2,i))
14779         sint2=sqrt(1-cost2*cost2)
14780        do j=1,3
14781 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14782           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14783           cost1*dc_norm(j,i-2))/ &
14784           vbld(i-1)
14785           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14786           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14787           +cost1*(dc_norm(j,i-1+nres)))/ &
14788           vbld(i-1+nres)
14789           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14790 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14791 !C Looks messy but better than if in loop
14792           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14793           +cost2*dc_norm(j,i-1))/ &
14794           vbld(i)
14795           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14796           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14797            +cost2*(-dc_norm(j,i-1+nres)))/ &
14798           vbld(i-1+nres)
14799 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14800           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14801         enddo
14802        endif
14803       enddo
14804 !elwrite(iout,*) "after vbld write"
14805 ! Derivatives of phi:
14806 ! If phi is 0 or 180 degrees, then the formulas
14807 ! have to be derived by power series expansion of the
14808 ! conventional formulas around 0 and 180.
14809 #ifdef PARINTDER
14810       do i=iphi1_start,iphi1_end
14811 #else
14812       do i=4,nres
14813 #endif
14814 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14815 ! the conventional case
14816         sint=dsin(theta(i))
14817         sint1=dsin(theta(i-1))
14818         sing=dsin(phi(i))
14819         cost=dcos(theta(i))
14820         cost1=dcos(theta(i-1))
14821         cosg=dcos(phi(i))
14822         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14823         fac0=1.0d0/(sint1*sint)
14824         fac1=cost*fac0
14825         fac2=cost1*fac0
14826         fac3=cosg*cost1/(sint1*sint1)
14827         fac4=cosg*cost/(sint*sint)
14828 !    Obtaining the gamma derivatives from sine derivative
14829        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14830            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14831            phi(i).ge.-pi.and.phi(i).le.-pi34) then
14832          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14833          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14834          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14835          do j=1,3
14836             ctgt=cost/sint
14837             ctgt1=cost1/sint1
14838             cosg_inv=1.0d0/cosg
14839             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14840             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14841               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14842             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14843             dsinphi(j,2,i)= &
14844               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14845               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14846             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14847             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14848               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14849 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14850             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14851             endif
14852 ! Bug fixed 3/24/05 (AL)
14853          enddo
14854 !   Obtaining the gamma derivatives from cosine derivative
14855         else
14856            do j=1,3
14857            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14858            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14859            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14860            dc_norm(j,i-3))/vbld(i-2)
14861            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14862            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14863            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14864            dcostheta(j,1,i)
14865            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14866            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14867            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14868            dc_norm(j,i-1))/vbld(i)
14869            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14870            endif
14871          enddo
14872         endif
14873       enddo
14874 !alculate derivative of Tauangle
14875 #ifdef PARINTDER
14876       do i=itau_start,itau_end
14877 #else
14878       do i=3,nres
14879 !elwrite(iout,*) " vecpr",i,nres
14880 #endif
14881        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14882 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14883 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14884 !c dtauangle(j,intertyp,dervityp,residue number)
14885 !c INTERTYP=1 SC...Ca...Ca..Ca
14886 ! the conventional case
14887         sint=dsin(theta(i))
14888         sint1=dsin(omicron(2,i-1))
14889         sing=dsin(tauangle(1,i))
14890         cost=dcos(theta(i))
14891         cost1=dcos(omicron(2,i-1))
14892         cosg=dcos(tauangle(1,i))
14893 !elwrite(iout,*) " vecpr5",i,nres
14894         do j=1,3
14895 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14896 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14897         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14898 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14899         enddo
14900         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14901         fac0=1.0d0/(sint1*sint)
14902         fac1=cost*fac0
14903         fac2=cost1*fac0
14904         fac3=cosg*cost1/(sint1*sint1)
14905         fac4=cosg*cost/(sint*sint)
14906 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14907 !    Obtaining the gamma derivatives from sine derivative
14908        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14909            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14910            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14911          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14912          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14913          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14914         do j=1,3
14915             ctgt=cost/sint
14916             ctgt1=cost1/sint1
14917             cosg_inv=1.0d0/cosg
14918             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14919        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14920        *vbld_inv(i-2+nres)
14921             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14922             dsintau(j,1,2,i)= &
14923               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14924               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14925 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14926             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14927 ! Bug fixed 3/24/05 (AL)
14928             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14929               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14930 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14931             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14932          enddo
14933 !   Obtaining the gamma derivatives from cosine derivative
14934         else
14935            do j=1,3
14936            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14937            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14938            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14939            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14940            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14941            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14942            dcostheta(j,1,i)
14943            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14944            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14945            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14946            dc_norm(j,i-1))/vbld(i)
14947            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14948 !         write (iout,*) "else",i
14949          enddo
14950         endif
14951 !        do k=1,3
14952 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14953 !        enddo
14954       enddo
14955 !C Second case Ca...Ca...Ca...SC
14956 #ifdef PARINTDER
14957       do i=itau_start,itau_end
14958 #else
14959       do i=4,nres
14960 #endif
14961        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14962           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14963 ! the conventional case
14964         sint=dsin(omicron(1,i))
14965         sint1=dsin(theta(i-1))
14966         sing=dsin(tauangle(2,i))
14967         cost=dcos(omicron(1,i))
14968         cost1=dcos(theta(i-1))
14969         cosg=dcos(tauangle(2,i))
14970 !        do j=1,3
14971 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14972 !        enddo
14973         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14974         fac0=1.0d0/(sint1*sint)
14975         fac1=cost*fac0
14976         fac2=cost1*fac0
14977         fac3=cosg*cost1/(sint1*sint1)
14978         fac4=cosg*cost/(sint*sint)
14979 !    Obtaining the gamma derivatives from sine derivative
14980        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14981            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14982            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14983          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14984          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14985          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14986         do j=1,3
14987             ctgt=cost/sint
14988             ctgt1=cost1/sint1
14989             cosg_inv=1.0d0/cosg
14990             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14991               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14992 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14993 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14994             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14995             dsintau(j,2,2,i)= &
14996               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14997               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14998 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14999 !     & sing*ctgt*domicron(j,1,2,i),
15000 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15001             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
15002 ! Bug fixed 3/24/05 (AL)
15003             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
15004              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
15005 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15006             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
15007          enddo
15008 !   Obtaining the gamma derivatives from cosine derivative
15009         else
15010            do j=1,3
15011            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
15012            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
15013            dc_norm(j,i-3))/vbld(i-2)
15014            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
15015            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
15016            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
15017            dcosomicron(j,1,1,i)
15018            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
15019            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
15020            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
15021            dc_norm(j,i-1+nres))/vbld(i-1+nres)
15022            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
15023 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
15024          enddo
15025         endif
15026       enddo
15027
15028 !CC third case SC...Ca...Ca...SC
15029 #ifdef PARINTDER
15030
15031       do i=itau_start,itau_end
15032 #else
15033       do i=3,nres
15034 #endif
15035 ! the conventional case
15036       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
15037       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
15038         sint=dsin(omicron(1,i))
15039         sint1=dsin(omicron(2,i-1))
15040         sing=dsin(tauangle(3,i))
15041         cost=dcos(omicron(1,i))
15042         cost1=dcos(omicron(2,i-1))
15043         cosg=dcos(tauangle(3,i))
15044         do j=1,3
15045         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
15046 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
15047         enddo
15048         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
15049         fac0=1.0d0/(sint1*sint)
15050         fac1=cost*fac0
15051         fac2=cost1*fac0
15052         fac3=cosg*cost1/(sint1*sint1)
15053         fac4=cosg*cost/(sint*sint)
15054 !    Obtaining the gamma derivatives from sine derivative
15055        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
15056            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
15057            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
15058          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
15059          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
15060          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
15061         do j=1,3
15062             ctgt=cost/sint
15063             ctgt1=cost1/sint1
15064             cosg_inv=1.0d0/cosg
15065             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
15066               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
15067               *vbld_inv(i-2+nres)
15068             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
15069             dsintau(j,3,2,i)= &
15070               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
15071               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
15072             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
15073 ! Bug fixed 3/24/05 (AL)
15074             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
15075               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
15076               *vbld_inv(i-1+nres)
15077 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15078             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
15079          enddo
15080 !   Obtaining the gamma derivatives from cosine derivative
15081         else
15082            do j=1,3
15083            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
15084            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
15085            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
15086            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
15087            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
15088            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
15089            dcosomicron(j,1,1,i)
15090            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
15091            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
15092            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
15093            dc_norm(j,i-1+nres))/vbld(i-1+nres)
15094            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
15095 !          write(iout,*) "else",i
15096          enddo
15097         endif
15098       enddo
15099
15100 #ifdef CRYST_SC
15101 !   Derivatives of side-chain angles alpha and omega
15102 #if defined(MPI) && defined(PARINTDER)
15103         do i=ibond_start,ibond_end
15104 #else
15105         do i=2,nres-1
15106 #endif
15107           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
15108              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
15109              fac6=fac5/vbld(i)
15110              fac7=fac5*fac5
15111              fac8=fac5/vbld(i+1)
15112              fac9=fac5/vbld(i+nres)
15113              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
15114              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
15115              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
15116              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
15117              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
15118              sina=sqrt(1-cosa*cosa)
15119              sino=dsin(omeg(i))
15120 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
15121              do j=1,3
15122                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
15123                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
15124                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
15125                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
15126                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
15127                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
15128                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
15129                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
15130                 vbld(i+nres))
15131                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
15132             enddo
15133 ! obtaining the derivatives of omega from sines
15134             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
15135                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
15136                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
15137                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
15138                dsin(theta(i+1)))
15139                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
15140                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
15141                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
15142                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
15143                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
15144                coso_inv=1.0d0/dcos(omeg(i))
15145                do j=1,3
15146                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
15147                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
15148                  (sino*dc_norm(j,i-1))/vbld(i)
15149                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
15150                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
15151                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
15152                  -sino*dc_norm(j,i)/vbld(i+1)
15153                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
15154                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
15155                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
15156                  vbld(i+nres)
15157                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
15158               enddo
15159            else
15160 !   obtaining the derivatives of omega from cosines
15161              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
15162              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
15163              fac12=fac10*sina
15164              fac13=fac12*fac12
15165              fac14=sina*sina
15166              do j=1,3
15167                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
15168                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
15169                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
15170                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
15171                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
15172                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
15173                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
15174                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
15175                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
15176                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
15177                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
15178                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
15179                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
15180                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
15181                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
15182             enddo
15183           endif
15184          else
15185            do j=1,3
15186              do k=1,3
15187                dalpha(k,j,i)=0.0d0
15188                domega(k,j,i)=0.0d0
15189              enddo
15190            enddo
15191          endif
15192        enddo
15193 #endif
15194 #if defined(MPI) && defined(PARINTDER)
15195       if (nfgtasks.gt.1) then
15196 #ifdef DEBUG
15197 !d      write (iout,*) "Gather dtheta"
15198 !d      call flush(iout)
15199       write (iout,*) "dtheta before gather"
15200       do i=1,nres
15201         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15202       enddo
15203 #endif
15204       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15205         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15206         king,FG_COMM,IERROR)
15207 #ifdef DEBUG
15208 !d      write (iout,*) "Gather dphi"
15209 !d      call flush(iout)
15210       write (iout,*) "dphi before gather"
15211       do i=1,nres
15212         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15213       enddo
15214 #endif
15215       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15216         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15217         king,FG_COMM,IERROR)
15218 !d      write (iout,*) "Gather dalpha"
15219 !d      call flush(iout)
15220 #ifdef CRYST_SC
15221       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15222         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15223         king,FG_COMM,IERROR)
15224 !d      write (iout,*) "Gather domega"
15225 !d      call flush(iout)
15226       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15227         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15228         king,FG_COMM,IERROR)
15229 #endif
15230       endif
15231 #endif
15232 #ifdef DEBUG
15233       write (iout,*) "dtheta after gather"
15234       do i=1,nres
15235         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15236       enddo
15237       write (iout,*) "dphi after gather"
15238       do i=1,nres
15239         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15240       enddo
15241       write (iout,*) "dalpha after gather"
15242       do i=1,nres
15243         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15244       enddo
15245       write (iout,*) "domega after gather"
15246       do i=1,nres
15247         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15248       enddo
15249 #endif
15250       return
15251       end subroutine intcartderiv
15252 !-----------------------------------------------------------------------------
15253       subroutine checkintcartgrad
15254 !      implicit real*8 (a-h,o-z)
15255 !      include 'DIMENSIONS'
15256 #ifdef MPI
15257       include 'mpif.h'
15258 #endif
15259 !      include 'COMMON.CHAIN'
15260 !      include 'COMMON.VAR'
15261 !      include 'COMMON.GEO'
15262 !      include 'COMMON.INTERACT'
15263 !      include 'COMMON.DERIV'
15264 !      include 'COMMON.IOUNITS'
15265 !      include 'COMMON.SETUP'
15266       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15267       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15268       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15269       real(kind=8),dimension(3) :: dc_norm_s
15270       real(kind=8) :: aincr=1.0d-5
15271       integer :: i,j
15272       real(kind=8) :: dcji
15273       do i=1,nres
15274         phi_s(i)=phi(i)
15275         theta_s(i)=theta(i)
15276         alph_s(i)=alph(i)
15277         omeg_s(i)=omeg(i)
15278       enddo
15279 ! Check theta gradient
15280       write (iout,*) &
15281        "Analytical (upper) and numerical (lower) gradient of theta"
15282       write (iout,*)
15283       do i=3,nres
15284         do j=1,3
15285           dcji=dc(j,i-2)
15286           dc(j,i-2)=dcji+aincr
15287           call chainbuild_cart
15288           call int_from_cart1(.false.)
15289           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15290           dc(j,i-2)=dcji
15291           dcji=dc(j,i-1)
15292           dc(j,i-1)=dc(j,i-1)+aincr
15293           call chainbuild_cart
15294           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15295           dc(j,i-1)=dcji
15296         enddo
15297 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15298 !el          (dtheta(j,2,i),j=1,3)
15299 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15300 !el          (dthetanum(j,2,i),j=1,3)
15301 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15302 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15303 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15304 !el        write (iout,*)
15305       enddo
15306 ! Check gamma gradient
15307       write (iout,*) &
15308        "Analytical (upper) and numerical (lower) gradient of gamma"
15309       do i=4,nres
15310         do j=1,3
15311           dcji=dc(j,i-3)
15312           dc(j,i-3)=dcji+aincr
15313           call chainbuild_cart
15314           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15315           dc(j,i-3)=dcji
15316           dcji=dc(j,i-2)
15317           dc(j,i-2)=dcji+aincr
15318           call chainbuild_cart
15319           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15320           dc(j,i-2)=dcji
15321           dcji=dc(j,i-1)
15322           dc(j,i-1)=dc(j,i-1)+aincr
15323           call chainbuild_cart
15324           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15325           dc(j,i-1)=dcji
15326         enddo
15327 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15328 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15329 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15330 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15331 !el        write (iout,'(5x,3(3f10.5,5x))') &
15332 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15333 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15334 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15335 !el        write (iout,*)
15336       enddo
15337 ! Check alpha gradient
15338       write (iout,*) &
15339        "Analytical (upper) and numerical (lower) gradient of alpha"
15340       do i=2,nres-1
15341        if(itype(i).ne.10) then
15342             do j=1,3
15343               dcji=dc(j,i-1)
15344               dc(j,i-1)=dcji+aincr
15345               call chainbuild_cart
15346               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15347               /aincr
15348               dc(j,i-1)=dcji
15349               dcji=dc(j,i)
15350               dc(j,i)=dcji+aincr
15351               call chainbuild_cart
15352               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15353               /aincr
15354               dc(j,i)=dcji
15355               dcji=dc(j,i+nres)
15356               dc(j,i+nres)=dc(j,i+nres)+aincr
15357               call chainbuild_cart
15358               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15359               /aincr
15360              dc(j,i+nres)=dcji
15361             enddo
15362           endif
15363 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15364 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15365 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15366 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15367 !el        write (iout,'(5x,3(3f10.5,5x))') &
15368 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15369 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15370 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15371 !el        write (iout,*)
15372       enddo
15373 !     Check omega gradient
15374       write (iout,*) &
15375        "Analytical (upper) and numerical (lower) gradient of omega"
15376       do i=2,nres-1
15377        if(itype(i).ne.10) then
15378             do j=1,3
15379               dcji=dc(j,i-1)
15380               dc(j,i-1)=dcji+aincr
15381               call chainbuild_cart
15382               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15383               /aincr
15384               dc(j,i-1)=dcji
15385               dcji=dc(j,i)
15386               dc(j,i)=dcji+aincr
15387               call chainbuild_cart
15388               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15389               /aincr
15390               dc(j,i)=dcji
15391               dcji=dc(j,i+nres)
15392               dc(j,i+nres)=dc(j,i+nres)+aincr
15393               call chainbuild_cart
15394               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15395               /aincr
15396              dc(j,i+nres)=dcji
15397             enddo
15398           endif
15399 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15400 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15401 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15402 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15403 !el        write (iout,'(5x,3(3f10.5,5x))') &
15404 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15405 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15406 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15407 !el        write (iout,*)
15408       enddo
15409       return
15410       end subroutine checkintcartgrad
15411 !-----------------------------------------------------------------------------
15412 ! q_measure.F
15413 !-----------------------------------------------------------------------------
15414       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15415 !      implicit real*8 (a-h,o-z)
15416 !      include 'DIMENSIONS'
15417 !      include 'COMMON.IOUNITS'
15418 !      include 'COMMON.CHAIN'
15419 !      include 'COMMON.INTERACT'
15420 !      include 'COMMON.VAR'
15421       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15422       integer :: kkk,nsep=3
15423       real(kind=8) :: qm        !dist,
15424       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15425       logical :: lprn=.false.
15426       logical :: flag
15427 !      real(kind=8) :: sigm,x
15428
15429 !el      sigm(x)=0.25d0*x     ! local function
15430       qqmax=1.0d10
15431       do kkk=1,nperm
15432       qq = 0.0d0
15433       nl=0
15434        if(flag) then
15435         do il=seg1+nsep,seg2
15436           do jl=seg1,il-nsep
15437             nl=nl+1
15438             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15439                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15440                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15441             dij=dist(il,jl)
15442             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15443             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15444               nl=nl+1
15445               d0ijCM=dsqrt( &
15446                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15447                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15448                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15449               dijCM=dist(il+nres,jl+nres)
15450               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15451             endif
15452             qq = qq+qqij+qqijCM
15453           enddo
15454         enddo
15455         qq = qq/nl
15456       else
15457       do il=seg1,seg2
15458         if((seg3-il).lt.3) then
15459              secseg=il+3
15460         else
15461              secseg=seg3
15462         endif
15463           do jl=secseg,seg4
15464             nl=nl+1
15465             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15466                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15467                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15468             dij=dist(il,jl)
15469             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15470             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15471               nl=nl+1
15472               d0ijCM=dsqrt( &
15473                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15474                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15475                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15476               dijCM=dist(il+nres,jl+nres)
15477               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15478             endif
15479             qq = qq+qqij+qqijCM
15480           enddo
15481         enddo
15482       qq = qq/nl
15483       endif
15484       if (qqmax.le.qq) qqmax=qq
15485       enddo
15486       qwolynes=1.0d0-qqmax
15487       return
15488       end function qwolynes
15489 !-----------------------------------------------------------------------------
15490       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15491 !      implicit real*8 (a-h,o-z)
15492 !      include 'DIMENSIONS'
15493 !      include 'COMMON.IOUNITS'
15494 !      include 'COMMON.CHAIN'
15495 !      include 'COMMON.INTERACT'
15496 !      include 'COMMON.VAR'
15497 !      include 'COMMON.MD'
15498       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15499       integer :: nsep=3, kkk
15500 !el      real(kind=8) :: dist
15501       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15502       logical :: lprn=.false.
15503       logical :: flag
15504       real(kind=8) :: sim,dd0,fac,ddqij
15505 !el      sigm(x)=0.25d0*x            ! local function
15506       do kkk=1,nperm
15507       do i=0,nres
15508         do j=1,3
15509           dqwol(j,i)=0.0d0
15510           dxqwol(j,i)=0.0d0
15511         enddo
15512       enddo
15513       nl=0
15514        if(flag) then
15515         do il=seg1+nsep,seg2
15516           do jl=seg1,il-nsep
15517             nl=nl+1
15518             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15519                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15520                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15521             dij=dist(il,jl)
15522             sim = 1.0d0/sigm(d0ij)
15523             sim = sim*sim
15524             dd0 = dij-d0ij
15525             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15526             do k=1,3
15527               ddqij = (c(k,il)-c(k,jl))*fac
15528               dqwol(k,il)=dqwol(k,il)+ddqij
15529               dqwol(k,jl)=dqwol(k,jl)-ddqij
15530             enddo
15531
15532             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15533               nl=nl+1
15534               d0ijCM=dsqrt( &
15535                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15536                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15537                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15538               dijCM=dist(il+nres,jl+nres)
15539               sim = 1.0d0/sigm(d0ijCM)
15540               sim = sim*sim
15541               dd0=dijCM-d0ijCM
15542               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15543               do k=1,3
15544                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15545                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15546                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15547               enddo
15548             endif
15549           enddo
15550         enddo
15551        else
15552         do il=seg1,seg2
15553         if((seg3-il).lt.3) then
15554              secseg=il+3
15555         else
15556              secseg=seg3
15557         endif
15558           do jl=secseg,seg4
15559             nl=nl+1
15560             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15561                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15562                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15563             dij=dist(il,jl)
15564             sim = 1.0d0/sigm(d0ij)
15565             sim = sim*sim
15566             dd0 = dij-d0ij
15567             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15568             do k=1,3
15569               ddqij = (c(k,il)-c(k,jl))*fac
15570               dqwol(k,il)=dqwol(k,il)+ddqij
15571               dqwol(k,jl)=dqwol(k,jl)-ddqij
15572             enddo
15573             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15574               nl=nl+1
15575               d0ijCM=dsqrt( &
15576                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15577                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15578                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15579               dijCM=dist(il+nres,jl+nres)
15580               sim = 1.0d0/sigm(d0ijCM)
15581               sim=sim*sim
15582               dd0 = dijCM-d0ijCM
15583               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15584               do k=1,3
15585                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15586                dxqwol(k,il)=dxqwol(k,il)+ddqij
15587                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15588               enddo
15589             endif
15590           enddo
15591         enddo
15592       endif
15593       enddo
15594        do i=0,nres
15595          do j=1,3
15596            dqwol(j,i)=dqwol(j,i)/nl
15597            dxqwol(j,i)=dxqwol(j,i)/nl
15598          enddo
15599        enddo
15600       return
15601       end subroutine qwolynes_prim
15602 !-----------------------------------------------------------------------------
15603       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15604 !      implicit real*8 (a-h,o-z)
15605 !      include 'DIMENSIONS'
15606 !      include 'COMMON.IOUNITS'
15607 !      include 'COMMON.CHAIN'
15608 !      include 'COMMON.INTERACT'
15609 !      include 'COMMON.VAR'
15610       integer :: seg1,seg2,seg3,seg4
15611       logical :: flag
15612       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15613       real(kind=8),dimension(3,0:2*nres) :: cdummy
15614       real(kind=8) :: q1,q2
15615       real(kind=8) :: delta=1.0d-10
15616       integer :: i,j
15617
15618       do i=0,nres
15619         do j=1,3
15620           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15621           cdummy(j,i)=c(j,i)
15622           c(j,i)=c(j,i)+delta
15623           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15624           qwolan(j,i)=(q2-q1)/delta
15625           c(j,i)=cdummy(j,i)
15626         enddo
15627       enddo
15628       do i=0,nres
15629         do j=1,3
15630           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15631           cdummy(j,i+nres)=c(j,i+nres)
15632           c(j,i+nres)=c(j,i+nres)+delta
15633           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15634           qwolxan(j,i)=(q2-q1)/delta
15635           c(j,i+nres)=cdummy(j,i+nres)
15636         enddo
15637       enddo
15638 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15639 !      do i=0,nct
15640 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15641 !      enddo
15642 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15643 !      do i=0,nct
15644 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15645 !      enddo
15646       return
15647       end subroutine qwol_num
15648 !-----------------------------------------------------------------------------
15649       subroutine EconstrQ
15650 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15651 !      implicit real*8 (a-h,o-z)
15652 !      include 'DIMENSIONS'
15653 !      include 'COMMON.CONTROL'
15654 !      include 'COMMON.VAR'
15655 !      include 'COMMON.MD'
15656       use MD_data
15657 !#ifndef LANG0
15658 !      include 'COMMON.LANGEVIN'
15659 !#else
15660 !      include 'COMMON.LANGEVIN.lang0'
15661 !#endif
15662 !      include 'COMMON.CHAIN'
15663 !      include 'COMMON.DERIV'
15664 !      include 'COMMON.GEO'
15665 !      include 'COMMON.LOCAL'
15666 !      include 'COMMON.INTERACT'
15667 !      include 'COMMON.IOUNITS'
15668 !      include 'COMMON.NAMES'
15669 !      include 'COMMON.TIME1'
15670       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15671       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15672                    duconst,duxconst
15673       integer :: kstart,kend,lstart,lend,idummy
15674       real(kind=8) :: delta=1.0d-7
15675       integer :: i,j,k,ii
15676       do i=0,nres
15677          do j=1,3
15678             duconst(j,i)=0.0d0
15679             dudconst(j,i)=0.0d0
15680             duxconst(j,i)=0.0d0
15681             dudxconst(j,i)=0.0d0
15682          enddo
15683       enddo
15684       Uconst=0.0d0
15685       do i=1,nfrag
15686          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15687            idummy,idummy)
15688          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15689 ! Calculating the derivatives of Constraint energy with respect to Q
15690          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15691            qinfrag(i,iset))
15692 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15693 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15694 !         hmnum=(hm2-hm1)/delta
15695 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15696 !     &   qinfrag(i,iset))
15697 !         write(iout,*) "harmonicnum frag", hmnum
15698 ! Calculating the derivatives of Q with respect to cartesian coordinates
15699          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15700           idummy,idummy)
15701 !         write(iout,*) "dqwol "
15702 !         do ii=1,nres
15703 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15704 !         enddo
15705 !         write(iout,*) "dxqwol "
15706 !         do ii=1,nres
15707 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15708 !         enddo
15709 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15710 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15711 !     &  ,idummy,idummy)
15712 !  The gradients of Uconst in Cs
15713          do ii=0,nres
15714             do j=1,3
15715                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15716                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15717             enddo
15718          enddo
15719       enddo
15720       do i=1,npair
15721          kstart=ifrag(1,ipair(1,i,iset),iset)
15722          kend=ifrag(2,ipair(1,i,iset),iset)
15723          lstart=ifrag(1,ipair(2,i,iset),iset)
15724          lend=ifrag(2,ipair(2,i,iset),iset)
15725          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15726          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15727 !  Calculating dU/dQ
15728          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15729 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15730 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15731 !         hmnum=(hm2-hm1)/delta
15732 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15733 !     &   qinpair(i,iset))
15734 !         write(iout,*) "harmonicnum pair ", hmnum
15735 ! Calculating dQ/dXi
15736          call qwolynes_prim(kstart,kend,.false.,&
15737           lstart,lend)
15738 !         write(iout,*) "dqwol "
15739 !         do ii=1,nres
15740 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15741 !         enddo
15742 !         write(iout,*) "dxqwol "
15743 !         do ii=1,nres
15744 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15745 !        enddo
15746 ! Calculating numerical gradients
15747 !        call qwol_num(kstart,kend,.false.
15748 !     &  ,lstart,lend)
15749 ! The gradients of Uconst in Cs
15750          do ii=0,nres
15751             do j=1,3
15752                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15753                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15754             enddo
15755          enddo
15756       enddo
15757 !      write(iout,*) "Uconst inside subroutine ", Uconst
15758 ! Transforming the gradients from Cs to dCs for the backbone
15759       do i=0,nres
15760          do j=i+1,nres
15761            do k=1,3
15762              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15763            enddo
15764          enddo
15765       enddo
15766 !  Transforming the gradients from Cs to dCs for the side chains
15767       do i=1,nres
15768          do j=1,3
15769            dudxconst(j,i)=duxconst(j,i)
15770          enddo
15771       enddo
15772 !      write(iout,*) "dU/ddc backbone "
15773 !       do ii=0,nres
15774 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15775 !      enddo
15776 !      write(iout,*) "dU/ddX side chain "
15777 !      do ii=1,nres
15778 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15779 !      enddo
15780 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15781 !      call dEconstrQ_num
15782       return
15783       end subroutine EconstrQ
15784 !-----------------------------------------------------------------------------
15785       subroutine dEconstrQ_num
15786 ! Calculating numerical dUconst/ddc and dUconst/ddx
15787 !      implicit real*8 (a-h,o-z)
15788 !      include 'DIMENSIONS'
15789 !      include 'COMMON.CONTROL'
15790 !      include 'COMMON.VAR'
15791 !      include 'COMMON.MD'
15792       use MD_data
15793 !#ifndef LANG0
15794 !      include 'COMMON.LANGEVIN'
15795 !#else
15796 !      include 'COMMON.LANGEVIN.lang0'
15797 !#endif
15798 !      include 'COMMON.CHAIN'
15799 !      include 'COMMON.DERIV'
15800 !      include 'COMMON.GEO'
15801 !      include 'COMMON.LOCAL'
15802 !      include 'COMMON.INTERACT'
15803 !      include 'COMMON.IOUNITS'
15804 !      include 'COMMON.NAMES'
15805 !      include 'COMMON.TIME1'
15806       real(kind=8) :: uzap1,uzap2
15807       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15808       integer :: kstart,kend,lstart,lend,idummy
15809       real(kind=8) :: delta=1.0d-7
15810 !el local variables
15811       integer :: i,ii,j
15812 !     real(kind=8) ::
15813 !     For the backbone
15814       do i=0,nres-1
15815          do j=1,3
15816             dUcartan(j,i)=0.0d0
15817             cdummy(j,i)=dc(j,i)
15818             dc(j,i)=dc(j,i)+delta
15819             call chainbuild_cart
15820             uzap2=0.0d0
15821             do ii=1,nfrag
15822              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15823                 idummy,idummy)
15824                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15825                 qinfrag(ii,iset))
15826             enddo
15827             do ii=1,npair
15828                kstart=ifrag(1,ipair(1,ii,iset),iset)
15829                kend=ifrag(2,ipair(1,ii,iset),iset)
15830                lstart=ifrag(1,ipair(2,ii,iset),iset)
15831                lend=ifrag(2,ipair(2,ii,iset),iset)
15832                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15833                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15834                  qinpair(ii,iset))
15835             enddo
15836             dc(j,i)=cdummy(j,i)
15837             call chainbuild_cart
15838             uzap1=0.0d0
15839              do ii=1,nfrag
15840              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15841                 idummy,idummy)
15842                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15843                 qinfrag(ii,iset))
15844             enddo
15845             do ii=1,npair
15846                kstart=ifrag(1,ipair(1,ii,iset),iset)
15847                kend=ifrag(2,ipair(1,ii,iset),iset)
15848                lstart=ifrag(1,ipair(2,ii,iset),iset)
15849                lend=ifrag(2,ipair(2,ii,iset),iset)
15850                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15851                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15852                 qinpair(ii,iset))
15853             enddo
15854             ducartan(j,i)=(uzap2-uzap1)/(delta)
15855          enddo
15856       enddo
15857 ! Calculating numerical gradients for dU/ddx
15858       do i=0,nres-1
15859          duxcartan(j,i)=0.0d0
15860          do j=1,3
15861             cdummy(j,i)=dc(j,i+nres)
15862             dc(j,i+nres)=dc(j,i+nres)+delta
15863             call chainbuild_cart
15864             uzap2=0.0d0
15865             do ii=1,nfrag
15866              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15867                 idummy,idummy)
15868                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15869                 qinfrag(ii,iset))
15870             enddo
15871             do ii=1,npair
15872                kstart=ifrag(1,ipair(1,ii,iset),iset)
15873                kend=ifrag(2,ipair(1,ii,iset),iset)
15874                lstart=ifrag(1,ipair(2,ii,iset),iset)
15875                lend=ifrag(2,ipair(2,ii,iset),iset)
15876                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15877                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15878                 qinpair(ii,iset))
15879             enddo
15880             dc(j,i+nres)=cdummy(j,i)
15881             call chainbuild_cart
15882             uzap1=0.0d0
15883              do ii=1,nfrag
15884                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15885                 ifrag(2,ii,iset),.true.,idummy,idummy)
15886                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15887                 qinfrag(ii,iset))
15888             enddo
15889             do ii=1,npair
15890                kstart=ifrag(1,ipair(1,ii,iset),iset)
15891                kend=ifrag(2,ipair(1,ii,iset),iset)
15892                lstart=ifrag(1,ipair(2,ii,iset),iset)
15893                lend=ifrag(2,ipair(2,ii,iset),iset)
15894                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15895                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15896                 qinpair(ii,iset))
15897             enddo
15898             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15899          enddo
15900       enddo
15901       write(iout,*) "Numerical dUconst/ddc backbone "
15902       do ii=0,nres
15903         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15904       enddo
15905 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15906 !      do ii=1,nres
15907 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15908 !      enddo
15909       return
15910       end subroutine dEconstrQ_num
15911 !-----------------------------------------------------------------------------
15912 ! ssMD.F
15913 !-----------------------------------------------------------------------------
15914       subroutine check_energies
15915
15916 !      use random, only: ran_number
15917
15918 !      implicit none
15919 !     Includes
15920 !      include 'DIMENSIONS'
15921 !      include 'COMMON.CHAIN'
15922 !      include 'COMMON.VAR'
15923 !      include 'COMMON.IOUNITS'
15924 !      include 'COMMON.SBRIDGE'
15925 !      include 'COMMON.LOCAL'
15926 !      include 'COMMON.GEO'
15927
15928 !     External functions
15929 !EL      double precision ran_number
15930 !EL      external ran_number
15931
15932 !     Local variables
15933       integer :: i,j,k,l,lmax,p,pmax
15934       real(kind=8) :: rmin,rmax
15935       real(kind=8) :: eij
15936
15937       real(kind=8) :: d
15938       real(kind=8) :: wi,rij,tj,pj
15939 !      return
15940
15941       i=5
15942       j=14
15943
15944       d=dsc(1)
15945       rmin=2.0D0
15946       rmax=12.0D0
15947
15948       lmax=10000
15949       pmax=1
15950
15951       do k=1,3
15952         c(k,i)=0.0D0
15953         c(k,j)=0.0D0
15954         c(k,nres+i)=0.0D0
15955         c(k,nres+j)=0.0D0
15956       enddo
15957
15958       do l=1,lmax
15959
15960 !t        wi=ran_number(0.0D0,pi)
15961 !        wi=ran_number(0.0D0,pi/6.0D0)
15962 !        wi=0.0D0
15963 !t        tj=ran_number(0.0D0,pi)
15964 !t        pj=ran_number(0.0D0,pi)
15965 !        pj=ran_number(0.0D0,pi/6.0D0)
15966 !        pj=0.0D0
15967
15968         do p=1,pmax
15969 !t           rij=ran_number(rmin,rmax)
15970
15971            c(1,j)=d*sin(pj)*cos(tj)
15972            c(2,j)=d*sin(pj)*sin(tj)
15973            c(3,j)=d*cos(pj)
15974
15975            c(3,nres+i)=-rij
15976
15977            c(1,i)=d*sin(wi)
15978            c(3,i)=-rij-d*cos(wi)
15979
15980            do k=1,3
15981               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15982               dc_norm(k,nres+i)=dc(k,nres+i)/d
15983               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15984               dc_norm(k,nres+j)=dc(k,nres+j)/d
15985            enddo
15986
15987            call dyn_ssbond_ene(i,j,eij)
15988         enddo
15989       enddo
15990       call exit(1)
15991       return
15992       end subroutine check_energies
15993 !-----------------------------------------------------------------------------
15994       subroutine dyn_ssbond_ene(resi,resj,eij)
15995 !      implicit none
15996 !      Includes
15997       use calc_data
15998       use comm_sschecks
15999 !      include 'DIMENSIONS'
16000 !      include 'COMMON.SBRIDGE'
16001 !      include 'COMMON.CHAIN'
16002 !      include 'COMMON.DERIV'
16003 !      include 'COMMON.LOCAL'
16004 !      include 'COMMON.INTERACT'
16005 !      include 'COMMON.VAR'
16006 !      include 'COMMON.IOUNITS'
16007 !      include 'COMMON.CALC'
16008 #ifndef CLUST
16009 #ifndef WHAM
16010        use MD_data
16011 !      include 'COMMON.MD'
16012 !      use MD, only: totT,t_bath
16013 #endif
16014 #endif
16015 !     External functions
16016 !EL      double precision h_base
16017 !EL      external h_base
16018
16019 !     Input arguments
16020       integer :: resi,resj
16021
16022 !     Output arguments
16023       real(kind=8) :: eij
16024
16025 !     Local variables
16026       logical :: havebond
16027       integer itypi,itypj
16028       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
16029       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
16030       real(kind=8),dimension(3) :: dcosom1,dcosom2
16031       real(kind=8) :: ed
16032       real(kind=8) :: pom1,pom2
16033       real(kind=8) :: ljA,ljB,ljXs
16034       real(kind=8),dimension(1:3) :: d_ljB
16035       real(kind=8) :: ssA,ssB,ssC,ssXs
16036       real(kind=8) :: ssxm,ljxm,ssm,ljm
16037       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
16038       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
16039       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
16040 !-------FIRST METHOD
16041       real(kind=8) :: xm
16042       real(kind=8),dimension(1:3) :: d_xm
16043 !-------END FIRST METHOD
16044 !-------SECOND METHOD
16045 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
16046 !-------END SECOND METHOD
16047
16048 !-------TESTING CODE
16049 !el      logical :: checkstop,transgrad
16050 !el      common /sschecks/ checkstop,transgrad
16051
16052       integer :: icheck,nicheck,jcheck,njcheck
16053       real(kind=8),dimension(-1:1) :: echeck
16054       real(kind=8) :: deps,ssx0,ljx0
16055 !-------END TESTING CODE
16056
16057       eij=0.0d0
16058       i=resi
16059       j=resj
16060
16061 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
16062 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
16063
16064       itypi=itype(i)
16065       dxi=dc_norm(1,nres+i)
16066       dyi=dc_norm(2,nres+i)
16067       dzi=dc_norm(3,nres+i)
16068       dsci_inv=vbld_inv(i+nres)
16069
16070       itypj=itype(j)
16071       xj=c(1,nres+j)-c(1,nres+i)
16072       yj=c(2,nres+j)-c(2,nres+i)
16073       zj=c(3,nres+j)-c(3,nres+i)
16074       dxj=dc_norm(1,nres+j)
16075       dyj=dc_norm(2,nres+j)
16076       dzj=dc_norm(3,nres+j)
16077       dscj_inv=vbld_inv(j+nres)
16078
16079       chi1=chi(itypi,itypj)
16080       chi2=chi(itypj,itypi)
16081       chi12=chi1*chi2
16082       chip1=chip(itypi)
16083       chip2=chip(itypj)
16084       chip12=chip1*chip2
16085       alf1=alp(itypi)
16086       alf2=alp(itypj)
16087       alf12=0.5D0*(alf1+alf2)
16088
16089       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16090       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
16091 !     The following are set in sc_angular
16092 !      erij(1)=xj*rij
16093 !      erij(2)=yj*rij
16094 !      erij(3)=zj*rij
16095 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
16096 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
16097 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
16098       call sc_angular
16099       rij=1.0D0/rij  ! Reset this so it makes sense
16100
16101       sig0ij=sigma(itypi,itypj)
16102       sig=sig0ij*dsqrt(1.0D0/sigsq)
16103
16104       ljXs=sig-sig0ij
16105       ljA=eps1*eps2rt**2*eps3rt**2
16106       ljB=ljA*bb(itypi,itypj)
16107       ljA=ljA*aa(itypi,itypj)
16108       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16109
16110       ssXs=d0cm
16111       deltat1=1.0d0-om1
16112       deltat2=1.0d0+om2
16113       deltat12=om2-om1+2.0d0
16114       cosphi=om12-om1*om2
16115       ssA=akcm
16116       ssB=akct*deltat12
16117       ssC=ss_depth &
16118            +akth*(deltat1*deltat1+deltat2*deltat2) &
16119            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
16120       ssxm=ssXs-0.5D0*ssB/ssA
16121
16122 !-------TESTING CODE
16123 !$$$c     Some extra output
16124 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
16125 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16126 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
16127 !$$$      if (ssx0.gt.0.0d0) then
16128 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
16129 !$$$      else
16130 !$$$        ssx0=ssxm
16131 !$$$      endif
16132 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16133 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
16134 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
16135 !$$$      return
16136 !-------END TESTING CODE
16137
16138 !-------TESTING CODE
16139 !     Stop and plot energy and derivative as a function of distance
16140       if (checkstop) then
16141         ssm=ssC-0.25D0*ssB*ssB/ssA
16142         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16143         if (ssm.lt.ljm .and. &
16144              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
16145           nicheck=1000
16146           njcheck=1
16147           deps=0.5d-7
16148         else
16149           checkstop=.false.
16150         endif
16151       endif
16152       if (.not.checkstop) then
16153         nicheck=0
16154         njcheck=-1
16155       endif
16156
16157       do icheck=0,nicheck
16158       do jcheck=-1,njcheck
16159       if (checkstop) rij=(ssxm-1.0d0)+ &
16160              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
16161 !-------END TESTING CODE
16162
16163       if (rij.gt.ljxm) then
16164         havebond=.false.
16165         ljd=rij-ljXs
16166         fac=(1.0D0/ljd)**expon
16167         e1=fac*fac*aa(itypi,itypj)
16168         e2=fac*bb(itypi,itypj)
16169         eij=eps1*eps2rt*eps3rt*(e1+e2)
16170         eps2der=eij*eps3rt
16171         eps3der=eij*eps2rt
16172         eij=eij*eps2rt*eps3rt
16173
16174         sigder=-sig/sigsq
16175         e1=e1*eps1*eps2rt**2*eps3rt**2
16176         ed=-expon*(e1+eij)/ljd
16177         sigder=ed*sigder
16178         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16179         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16180         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
16181              -2.0D0*alf12*eps3der+sigder*sigsq_om12
16182       else if (rij.lt.ssxm) then
16183         havebond=.true.
16184         ssd=rij-ssXs
16185         eij=ssA*ssd*ssd+ssB*ssd+ssC
16186
16187         ed=2*akcm*ssd+akct*deltat12
16188         pom1=akct*ssd
16189         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
16190         eom1=-2*akth*deltat1-pom1-om2*pom2
16191         eom2= 2*akth*deltat2+pom1-om1*pom2
16192         eom12=pom2
16193       else
16194         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16195
16196         d_ssxm(1)=0.5D0*akct/ssA
16197         d_ssxm(2)=-d_ssxm(1)
16198         d_ssxm(3)=0.0D0
16199
16200         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16201         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16202         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16203         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16204
16205 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16206         xm=0.5d0*(ssxm+ljxm)
16207         do k=1,3
16208           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16209         enddo
16210         if (rij.lt.xm) then
16211           havebond=.true.
16212           ssm=ssC-0.25D0*ssB*ssB/ssA
16213           d_ssm(1)=0.5D0*akct*ssB/ssA
16214           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16215           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16216           d_ssm(3)=omega
16217           f1=(rij-xm)/(ssxm-xm)
16218           f2=(rij-ssxm)/(xm-ssxm)
16219           h1=h_base(f1,hd1)
16220           h2=h_base(f2,hd2)
16221           eij=ssm*h1+Ht*h2
16222           delta_inv=1.0d0/(xm-ssxm)
16223           deltasq_inv=delta_inv*delta_inv
16224           fac=ssm*hd1-Ht*hd2
16225           fac1=deltasq_inv*fac*(xm-rij)
16226           fac2=deltasq_inv*fac*(rij-ssxm)
16227           ed=delta_inv*(Ht*hd2-ssm*hd1)
16228           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16229           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16230           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16231         else
16232           havebond=.false.
16233           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16234           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16235           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16236           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16237                alf12/eps3rt)
16238           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16239           f1=(rij-ljxm)/(xm-ljxm)
16240           f2=(rij-xm)/(ljxm-xm)
16241           h1=h_base(f1,hd1)
16242           h2=h_base(f2,hd2)
16243           eij=Ht*h1+ljm*h2
16244           delta_inv=1.0d0/(ljxm-xm)
16245           deltasq_inv=delta_inv*delta_inv
16246           fac=Ht*hd1-ljm*hd2
16247           fac1=deltasq_inv*fac*(ljxm-rij)
16248           fac2=deltasq_inv*fac*(rij-xm)
16249           ed=delta_inv*(ljm*hd2-Ht*hd1)
16250           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16251           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16252           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16253         endif
16254 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16255
16256 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16257 !$$$        ssd=rij-ssXs
16258 !$$$        ljd=rij-ljXs
16259 !$$$        fac1=rij-ljxm
16260 !$$$        fac2=rij-ssxm
16261 !$$$
16262 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16263 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16264 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16265 !$$$
16266 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16267 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16268 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16269 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16270 !$$$        d_ssm(3)=omega
16271 !$$$
16272 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16273 !$$$        do k=1,3
16274 !$$$          d_ljm(k)=ljm*d_ljB(k)
16275 !$$$        enddo
16276 !$$$        ljm=ljm*ljB
16277 !$$$
16278 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16279 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16280 !$$$        d_ss(2)=akct*ssd
16281 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16282 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16283 !$$$        d_ss(3)=omega
16284 !$$$
16285 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16286 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16287 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16288 !$$$        do k=1,3
16289 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16290 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16291 !$$$        enddo
16292 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16293 !$$$
16294 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16295 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16296 !$$$        h1=h_base(f1,hd1)
16297 !$$$        h2=h_base(f2,hd2)
16298 !$$$        eij=ss*h1+ljf*h2
16299 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16300 !$$$        deltasq_inv=delta_inv*delta_inv
16301 !$$$        fac=ljf*hd2-ss*hd1
16302 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16303 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16304 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16305 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16306 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16307 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16308 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16309 !$$$
16310 !$$$        havebond=.false.
16311 !$$$        if (ed.gt.0.0d0) havebond=.true.
16312 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16313
16314       endif
16315
16316       if (havebond) then
16317 !#ifndef CLUST
16318 !#ifndef WHAM
16319 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16320 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16321 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16322 !        endif
16323 !#endif
16324 !#endif
16325         dyn_ssbond_ij(i,j)=eij
16326       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16327         dyn_ssbond_ij(i,j)=1.0d300
16328 !#ifndef CLUST
16329 !#ifndef WHAM
16330 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16331 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16332 !#endif
16333 !#endif
16334       endif
16335
16336 !-------TESTING CODE
16337 !el      if (checkstop) then
16338         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16339              "CHECKSTOP",rij,eij,ed
16340         echeck(jcheck)=eij
16341 !el      endif
16342       enddo
16343       if (checkstop) then
16344         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16345       endif
16346       enddo
16347       if (checkstop) then
16348         transgrad=.true.
16349         checkstop=.false.
16350       endif
16351 !-------END TESTING CODE
16352
16353       do k=1,3
16354         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16355         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16356       enddo
16357       do k=1,3
16358         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16359       enddo
16360       do k=1,3
16361         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16362              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16363              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16364         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16365              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16366              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16367       enddo
16368 !grad      do k=i,j-1
16369 !grad        do l=1,3
16370 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16371 !grad        enddo
16372 !grad      enddo
16373
16374       do l=1,3
16375         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16376         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16377       enddo
16378
16379       return
16380       end subroutine dyn_ssbond_ene
16381 !-----------------------------------------------------------------------------
16382       real(kind=8) function h_base(x,deriv)
16383 !     A smooth function going 0->1 in range [0,1]
16384 !     It should NOT be called outside range [0,1], it will not work there.
16385       implicit none
16386
16387 !     Input arguments
16388       real(kind=8) :: x
16389
16390 !     Output arguments
16391       real(kind=8) :: deriv
16392
16393 !     Local variables
16394       real(kind=8) :: xsq
16395
16396
16397 !     Two parabolas put together.  First derivative zero at extrema
16398 !$$$      if (x.lt.0.5D0) then
16399 !$$$        h_base=2.0D0*x*x
16400 !$$$        deriv=4.0D0*x
16401 !$$$      else
16402 !$$$        deriv=1.0D0-x
16403 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16404 !$$$        deriv=4.0D0*deriv
16405 !$$$      endif
16406
16407 !     Third degree polynomial.  First derivative zero at extrema
16408       h_base=x*x*(3.0d0-2.0d0*x)
16409       deriv=6.0d0*x*(1.0d0-x)
16410
16411 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16412 !$$$      xsq=x*x
16413 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16414 !$$$      deriv=x-1.0d0
16415 !$$$      deriv=deriv*deriv
16416 !$$$      deriv=30.0d0*xsq*deriv
16417
16418       return
16419       end function h_base
16420 !-----------------------------------------------------------------------------
16421       subroutine dyn_set_nss
16422 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16423 !      implicit none
16424       use MD_data, only: totT,t_bath
16425 !     Includes
16426 !      include 'DIMENSIONS'
16427 #ifdef MPI
16428       include "mpif.h"
16429 #endif
16430 !      include 'COMMON.SBRIDGE'
16431 !      include 'COMMON.CHAIN'
16432 !      include 'COMMON.IOUNITS'
16433 !      include 'COMMON.SETUP'
16434 !      include 'COMMON.MD'
16435 !     Local variables
16436       real(kind=8) :: emin
16437       integer :: i,j,imin,ierr
16438       integer :: diff,allnss,newnss
16439       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16440                 newihpb,newjhpb
16441       logical :: found
16442       integer,dimension(0:nfgtasks) :: i_newnss
16443       integer,dimension(0:nfgtasks) :: displ
16444       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16445       integer :: g_newnss
16446
16447       allnss=0
16448       do i=1,nres-1
16449         do j=i+1,nres
16450           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16451             allnss=allnss+1
16452             allflag(allnss)=0
16453             allihpb(allnss)=i
16454             alljhpb(allnss)=j
16455           endif
16456         enddo
16457       enddo
16458
16459 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16460
16461  1    emin=1.0d300
16462       do i=1,allnss
16463         if (allflag(i).eq.0 .and. &
16464              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16465           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16466           imin=i
16467         endif
16468       enddo
16469       if (emin.lt.1.0d300) then
16470         allflag(imin)=1
16471         do i=1,allnss
16472           if (allflag(i).eq.0 .and. &
16473                (allihpb(i).eq.allihpb(imin) .or. &
16474                alljhpb(i).eq.allihpb(imin) .or. &
16475                allihpb(i).eq.alljhpb(imin) .or. &
16476                alljhpb(i).eq.alljhpb(imin))) then
16477             allflag(i)=-1
16478           endif
16479         enddo
16480         goto 1
16481       endif
16482
16483 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16484
16485       newnss=0
16486       do i=1,allnss
16487         if (allflag(i).eq.1) then
16488           newnss=newnss+1
16489           newihpb(newnss)=allihpb(i)
16490           newjhpb(newnss)=alljhpb(i)
16491         endif
16492       enddo
16493
16494 #ifdef MPI
16495       if (nfgtasks.gt.1)then
16496
16497         call MPI_Reduce(newnss,g_newnss,1,&
16498           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16499         call MPI_Gather(newnss,1,MPI_INTEGER,&
16500                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16501         displ(0)=0
16502         do i=1,nfgtasks-1,1
16503           displ(i)=i_newnss(i-1)+displ(i-1)
16504         enddo
16505         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16506                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16507                          king,FG_COMM,IERR)
16508         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16509                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16510                          king,FG_COMM,IERR)
16511         if(fg_rank.eq.0) then
16512 !         print *,'g_newnss',g_newnss
16513 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16514 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16515          newnss=g_newnss
16516          do i=1,newnss
16517           newihpb(i)=g_newihpb(i)
16518           newjhpb(i)=g_newjhpb(i)
16519          enddo
16520         endif
16521       endif
16522 #endif
16523
16524       diff=newnss-nss
16525
16526 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16527
16528       do i=1,nss
16529         found=.false.
16530         do j=1,newnss
16531           if (idssb(i).eq.newihpb(j) .and. &
16532                jdssb(i).eq.newjhpb(j)) found=.true.
16533         enddo
16534 #ifndef CLUST
16535 #ifndef WHAM
16536         if (.not.found.and.fg_rank.eq.0) &
16537             write(iout,'(a15,f12.2,f8.1,2i5)') &
16538              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16539 #endif
16540 #endif
16541       enddo
16542
16543       do i=1,newnss
16544         found=.false.
16545         do j=1,nss
16546           if (newihpb(i).eq.idssb(j) .and. &
16547                newjhpb(i).eq.jdssb(j)) found=.true.
16548         enddo
16549 #ifndef CLUST
16550 #ifndef WHAM
16551         if (.not.found.and.fg_rank.eq.0) &
16552             write(iout,'(a15,f12.2,f8.1,2i5)') &
16553              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16554 #endif
16555 #endif
16556       enddo
16557
16558       nss=newnss
16559       do i=1,nss
16560         idssb(i)=newihpb(i)
16561         jdssb(i)=newjhpb(i)
16562       enddo
16563
16564       return
16565       end subroutine dyn_set_nss
16566 !-----------------------------------------------------------------------------
16567 #ifdef WHAM
16568       subroutine read_ssHist
16569 !      implicit none
16570 !      Includes
16571 !      include 'DIMENSIONS'
16572 !      include "DIMENSIONS.FREE"
16573 !      include 'COMMON.FREE'
16574 !     Local variables
16575       integer :: i,j
16576       character(len=80) :: controlcard
16577
16578       do i=1,dyn_nssHist
16579         call card_concat(controlcard,.true.)
16580         read(controlcard,*) &
16581              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16582       enddo
16583
16584       return
16585       end subroutine read_ssHist
16586 #endif
16587 !-----------------------------------------------------------------------------
16588       integer function indmat(i,j)
16589 !el
16590 ! get the position of the jth ijth fragment of the chain coordinate system
16591 ! in the fromto array.
16592         integer :: i,j
16593
16594         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16595       return
16596       end function indmat
16597 !-----------------------------------------------------------------------------
16598       real(kind=8) function sigm(x)
16599 !el
16600        real(kind=8) :: x
16601         sigm=0.25d0*x
16602       return
16603       end function sigm
16604 !-----------------------------------------------------------------------------
16605 !-----------------------------------------------------------------------------
16606       subroutine alloc_ener_arrays
16607 !EL Allocation of arrays used by module energy
16608       use MD_data, only: mset
16609 !el local variables
16610       integer :: i,j
16611
16612       if(nres.lt.100) then
16613         maxconts=nres
16614       elseif(nres.lt.200) then
16615         maxconts=0.8*nres       ! Max. number of contacts per residue
16616       else
16617         maxconts=0.6*nres ! (maxconts=maxres/4)
16618       endif
16619       maxcont=12*nres   ! Max. number of SC contacts
16620       maxvar=6*nres     ! Max. number of variables
16621 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16622       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16623 !----------------------
16624 ! arrays in subroutine init_int_table
16625 !el#ifdef MPI
16626 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16627 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16628 !el#endif
16629       allocate(nint_gr(nres))
16630       allocate(nscp_gr(nres))
16631       allocate(ielstart(nres))
16632       allocate(ielend(nres))
16633 !(maxres)
16634       allocate(istart(nres,maxint_gr))
16635       allocate(iend(nres,maxint_gr))
16636 !(maxres,maxint_gr)
16637       allocate(iscpstart(nres,maxint_gr))
16638       allocate(iscpend(nres,maxint_gr))
16639 !(maxres,maxint_gr)
16640       allocate(ielstart_vdw(nres))
16641       allocate(ielend_vdw(nres))
16642 !(maxres)
16643
16644       allocate(lentyp(0:nfgtasks-1))
16645 !(0:maxprocs-1)
16646 !----------------------
16647 ! commom.contacts
16648 !      common /contacts/
16649       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16650       allocate(icont(2,maxcont))
16651 !(2,maxcont)
16652 !      common /contacts1/
16653       allocate(num_cont(0:nres+4))
16654 !(maxres)
16655       allocate(jcont(maxconts,nres))
16656 !(maxconts,maxres)
16657       allocate(facont(maxconts,nres))
16658 !(maxconts,maxres)
16659       allocate(gacont(3,maxconts,nres))
16660 !(3,maxconts,maxres)
16661 !      common /contacts_hb/
16662       allocate(gacontp_hb1(3,maxconts,nres))
16663       allocate(gacontp_hb2(3,maxconts,nres))
16664       allocate(gacontp_hb3(3,maxconts,nres))
16665       allocate(gacontm_hb1(3,maxconts,nres))
16666       allocate(gacontm_hb2(3,maxconts,nres))
16667       allocate(gacontm_hb3(3,maxconts,nres))
16668       allocate(gacont_hbr(3,maxconts,nres))
16669       allocate(grij_hb_cont(3,maxconts,nres))
16670 !(3,maxconts,maxres)
16671       allocate(facont_hb(maxconts,nres))
16672       allocate(ees0p(maxconts,nres))
16673       allocate(ees0m(maxconts,nres))
16674       allocate(d_cont(maxconts,nres))
16675 !(maxconts,maxres)
16676       allocate(num_cont_hb(nres))
16677 !(maxres)
16678       allocate(jcont_hb(maxconts,nres))
16679 !(maxconts,maxres)
16680 !      common /rotat/
16681       allocate(Ug(2,2,nres))
16682       allocate(Ugder(2,2,nres))
16683       allocate(Ug2(2,2,nres))
16684       allocate(Ug2der(2,2,nres))
16685 !(2,2,maxres)
16686       allocate(obrot(2,nres))
16687       allocate(obrot2(2,nres))
16688       allocate(obrot_der(2,nres))
16689       allocate(obrot2_der(2,nres))
16690 !(2,maxres)
16691 !      common /precomp1/
16692       allocate(mu(2,nres))
16693       allocate(muder(2,nres))
16694       allocate(Ub2(2,nres))
16695       Ub2(1,:)=0.0d0
16696       Ub2(2,:)=0.0d0
16697       allocate(Ub2der(2,nres))
16698       allocate(Ctobr(2,nres))
16699       allocate(Ctobrder(2,nres))
16700       allocate(Dtobr2(2,nres))
16701       allocate(Dtobr2der(2,nres))
16702 !(2,maxres)
16703       allocate(EUg(2,2,nres))
16704       allocate(EUgder(2,2,nres))
16705       allocate(CUg(2,2,nres))
16706       allocate(CUgder(2,2,nres))
16707       allocate(DUg(2,2,nres))
16708       allocate(Dugder(2,2,nres))
16709       allocate(DtUg2(2,2,nres))
16710       allocate(DtUg2der(2,2,nres))
16711 !(2,2,maxres)
16712 !      common /precomp2/
16713       allocate(Ug2Db1t(2,nres))
16714       allocate(Ug2Db1tder(2,nres))
16715       allocate(CUgb2(2,nres))
16716       allocate(CUgb2der(2,nres))
16717 !(2,maxres)
16718       allocate(EUgC(2,2,nres))
16719       allocate(EUgCder(2,2,nres))
16720       allocate(EUgD(2,2,nres))
16721       allocate(EUgDder(2,2,nres))
16722       allocate(DtUg2EUg(2,2,nres))
16723       allocate(Ug2DtEUg(2,2,nres))
16724 !(2,2,maxres)
16725       allocate(Ug2DtEUgder(2,2,2,nres))
16726       allocate(DtUg2EUgder(2,2,2,nres))
16727 !(2,2,2,maxres)
16728 !      common /rotat_old/
16729       allocate(costab(nres))
16730       allocate(sintab(nres))
16731       allocate(costab2(nres))
16732       allocate(sintab2(nres))
16733 !(maxres)
16734 !      common /dipmat/
16735       allocate(a_chuj(2,2,maxconts,nres))
16736 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16737       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16738 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16739 !      common /contdistrib/
16740       allocate(ncont_sent(nres))
16741       allocate(ncont_recv(nres))
16742
16743       allocate(iat_sent(nres))
16744 !(maxres)
16745       allocate(iint_sent(4,nres,nres))
16746       allocate(iint_sent_local(4,nres,nres))
16747 !(4,maxres,maxres)
16748       allocate(iturn3_sent(4,0:nres+4))
16749       allocate(iturn4_sent(4,0:nres+4))
16750       allocate(iturn3_sent_local(4,nres))
16751       allocate(iturn4_sent_local(4,nres))
16752 !(4,maxres)
16753       allocate(itask_cont_from(0:nfgtasks-1))
16754       allocate(itask_cont_to(0:nfgtasks-1))
16755 !(0:max_fg_procs-1)
16756
16757
16758
16759 !----------------------
16760 ! commom.deriv;
16761 !      common /derivat/
16762       allocate(dcdv(6,maxdim))
16763       allocate(dxdv(6,maxdim))
16764 !(6,maxdim)
16765       allocate(dxds(6,nres))
16766 !(6,maxres)
16767       allocate(gradx(3,nres,0:2))
16768       allocate(gradc(3,nres,0:2))
16769 !(3,maxres,2)
16770       allocate(gvdwx(3,nres))
16771       allocate(gvdwc(3,nres))
16772       allocate(gelc(3,nres))
16773       allocate(gelc_long(3,nres))
16774       allocate(gvdwpp(3,nres))
16775       allocate(gvdwc_scpp(3,nres))
16776       allocate(gradx_scp(3,nres))
16777       allocate(gvdwc_scp(3,nres))
16778       allocate(ghpbx(3,nres))
16779       allocate(ghpbc(3,nres))
16780       allocate(gradcorr(3,nres))
16781       allocate(gradcorr_long(3,nres))
16782       allocate(gradcorr5_long(3,nres))
16783       allocate(gradcorr6_long(3,nres))
16784       allocate(gcorr6_turn_long(3,nres))
16785       allocate(gradxorr(3,nres))
16786       allocate(gradcorr5(3,nres))
16787       allocate(gradcorr6(3,nres))
16788 !(3,maxres)
16789       allocate(gloc(0:maxvar,0:2))
16790       allocate(gloc_x(0:maxvar,2))
16791 !(maxvar,2)
16792       allocate(gel_loc(3,nres))
16793       allocate(gel_loc_long(3,nres))
16794       allocate(gcorr3_turn(3,nres))
16795       allocate(gcorr4_turn(3,nres))
16796       allocate(gcorr6_turn(3,nres))
16797       allocate(gradb(3,nres))
16798       allocate(gradbx(3,nres))
16799 !(3,maxres)
16800       allocate(gel_loc_loc(maxvar))
16801       allocate(gel_loc_turn3(maxvar))
16802       allocate(gel_loc_turn4(maxvar))
16803       allocate(gel_loc_turn6(maxvar))
16804       allocate(gcorr_loc(maxvar))
16805       allocate(g_corr5_loc(maxvar))
16806       allocate(g_corr6_loc(maxvar))
16807 !(maxvar)
16808       allocate(gsccorc(3,nres))
16809       allocate(gsccorx(3,nres))
16810 !(3,maxres)
16811       allocate(gsccor_loc(nres))
16812 !(maxres)
16813       allocate(dtheta(3,2,nres))
16814 !(3,2,maxres)
16815       allocate(gscloc(3,nres))
16816       allocate(gsclocx(3,nres))
16817 !(3,maxres)
16818       allocate(dphi(3,3,nres))
16819       allocate(dalpha(3,3,nres))
16820       allocate(domega(3,3,nres))
16821 !(3,3,maxres)
16822 !      common /deriv_scloc/
16823       allocate(dXX_C1tab(3,nres))
16824       allocate(dYY_C1tab(3,nres))
16825       allocate(dZZ_C1tab(3,nres))
16826       allocate(dXX_Ctab(3,nres))
16827       allocate(dYY_Ctab(3,nres))
16828       allocate(dZZ_Ctab(3,nres))
16829       allocate(dXX_XYZtab(3,nres))
16830       allocate(dYY_XYZtab(3,nres))
16831       allocate(dZZ_XYZtab(3,nres))
16832 !(3,maxres)
16833 !      common /mpgrad/
16834       allocate(jgrad_start(nres))
16835       allocate(jgrad_end(nres))
16836 !(maxres)
16837 !----------------------
16838
16839 !      common /indices/
16840       allocate(ibond_displ(0:nfgtasks-1))
16841       allocate(ibond_count(0:nfgtasks-1))
16842       allocate(ithet_displ(0:nfgtasks-1))
16843       allocate(ithet_count(0:nfgtasks-1))
16844       allocate(iphi_displ(0:nfgtasks-1))
16845       allocate(iphi_count(0:nfgtasks-1))
16846       allocate(iphi1_displ(0:nfgtasks-1))
16847       allocate(iphi1_count(0:nfgtasks-1))
16848       allocate(ivec_displ(0:nfgtasks-1))
16849       allocate(ivec_count(0:nfgtasks-1))
16850       allocate(iset_displ(0:nfgtasks-1))
16851       allocate(iset_count(0:nfgtasks-1))
16852       allocate(iint_count(0:nfgtasks-1))
16853       allocate(iint_displ(0:nfgtasks-1))
16854 !(0:max_fg_procs-1)
16855 !----------------------
16856 ! common.MD
16857 !      common /mdgrad/
16858       allocate(gcart(3,0:nres))
16859       allocate(gxcart(3,0:nres))
16860 !(3,0:MAXRES)
16861       allocate(gradcag(3,nres))
16862       allocate(gradxag(3,nres))
16863 !(3,MAXRES)
16864 !      common /back_constr/
16865 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16866       allocate(dutheta(nres))
16867       allocate(dugamma(nres))
16868 !(maxres)
16869       allocate(duscdiff(3,nres))
16870       allocate(duscdiffx(3,nres))
16871 !(3,maxres)
16872 !el i io:read_fragments
16873 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16874 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16875 !      common /qmeas/
16876 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16877 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16878       allocate(mset(0:nprocs))  !(maxprocs/20)
16879       mset(:)=0
16880 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16881 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16882       allocate(dUdconst(3,0:nres))
16883       allocate(dUdxconst(3,0:nres))
16884       allocate(dqwol(3,0:nres))
16885       allocate(dxqwol(3,0:nres))
16886 !(3,0:MAXRES)
16887 !----------------------
16888 ! common.sbridge
16889 !      common /sbridge/ in io_common: read_bridge
16890 !el    allocate((:),allocatable :: iss  !(maxss)
16891 !      common /links/  in io_common: read_bridge
16892 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16893 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16894 !      common /dyn_ssbond/
16895 ! and side-chain vectors in theta or phi.
16896       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16897 !(maxres,maxres)
16898 !      do i=1,nres
16899 !        do j=i+1,nres
16900       dyn_ssbond_ij(:,:)=1.0d300
16901 !        enddo
16902 !      enddo
16903
16904       if (nss.gt.0) then
16905         allocate(idssb(nss),jdssb(nss))
16906 !(maxdim)
16907       endif
16908       allocate(dyn_ss_mask(nres))
16909 !(maxres)
16910       dyn_ss_mask(:)=.false.
16911 !----------------------
16912 ! common.sccor
16913 ! Parameters of the SCCOR term
16914 !      common/sccor/
16915 !el in io_conf: parmread
16916 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16917 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16918 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16919 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16920 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16921 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16922 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16923 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16924 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16925 !----------------
16926       allocate(gloc_sc(3,0:2*nres,0:10))
16927 !(3,0:maxres2,10)maxres2=2*maxres
16928       allocate(dcostau(3,3,3,2*nres))
16929       allocate(dsintau(3,3,3,2*nres))
16930       allocate(dtauangle(3,3,3,2*nres))
16931       allocate(dcosomicron(3,3,3,2*nres))
16932       allocate(domicron(3,3,3,2*nres))
16933 !(3,3,3,maxres2)maxres2=2*maxres
16934 !----------------------
16935 ! common.var
16936 !      common /restr/
16937       allocate(varall(maxvar))
16938 !(maxvar)(maxvar=6*maxres)
16939       allocate(mask_theta(nres))
16940       allocate(mask_phi(nres))
16941       allocate(mask_side(nres))
16942 !(maxres)
16943 !----------------------
16944 ! common.vectors
16945 !      common /vectors/
16946       allocate(uy(3,nres))
16947       allocate(uz(3,nres))
16948 !(3,maxres)
16949       allocate(uygrad(3,3,2,nres))
16950       allocate(uzgrad(3,3,2,nres))
16951 !(3,3,2,maxres)
16952
16953       return
16954       end subroutine alloc_ener_arrays
16955 !-----------------------------------------------------------------------------
16956 !-----------------------------------------------------------------------------
16957       end module energy