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, only: totT
 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 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 217 !     & " nfgtasks",nfgtasks
 218       if (nfgtasks.gt.1) then
 219         time00=MPI_Wtime()
 220 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 221         if (fg_rank.eq.0) then
 222           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 223 !          print *,"Processor",myrank," BROADCAST iorder"
 224 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 225 ! FG slaves as WEIGHTS array.
 226           weights_(1)=wsc
 227           weights_(2)=wscp
 228           weights_(3)=welec
 229           weights_(4)=wcorr
 230           weights_(5)=wcorr5
 231           weights_(6)=wcorr6
 232           weights_(7)=wel_loc
 233           weights_(8)=wturn3
 234           weights_(9)=wturn4
 235           weights_(10)=wturn6
 236           weights_(11)=wang
 237           weights_(12)=wscloc
 238           weights_(13)=wtor
 239           weights_(14)=wtor_d
 240           weights_(15)=wstrain
 241           weights_(16)=wvdwpp
 242           weights_(17)=wbond
 243           weights_(18)=scal14
 244           weights_(21)=wsccor
 245 ! FG Master broadcasts the WEIGHTS_ array
 246           call MPI_Bcast(weights_(1),n_ene,&
 247              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 248         else
 249 ! FG slaves receive the WEIGHTS array
 250           call MPI_Bcast(weights(1),n_ene,&
 251               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 252           wsc=weights(1)
 253           wscp=weights(2)
 254           welec=weights(3)
 255           wcorr=weights(4)
 256           wcorr5=weights(5)
 257           wcorr6=weights(6)
 258           wel_loc=weights(7)
 259           wturn3=weights(8)
 260           wturn4=weights(9)
 261           wturn6=weights(10)
 262           wang=weights(11)
 263           wscloc=weights(12)
 264           wtor=weights(13)
 265           wtor_d=weights(14)
 266           wstrain=weights(15)
 267           wvdwpp=weights(16)
 268           wbond=weights(17)
 269           scal14=weights(18)
 270           wsccor=weights(21)
 271         endif
 272         time_Bcast=time_Bcast+MPI_Wtime()-time00
 273         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 274 !        call chainbuild_cart
 275       endif
 276 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 277 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 278 #else
 279 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 280 !        call int_from_cart1(.false.)
 281 !      endif
 282 #endif
 283 #ifdef TIMING
 284       time00=MPI_Wtime()
 285 #endif
 286 !
 287 ! Compute the side-chain and electrostatic interaction energy
 288 !
 289 !      goto (101,102,103,104,105,106) ipot
 290       select case(ipot)
 291 ! Lennard-Jones potential.
 292 !  101 call elj(evdw)
 293        case (1)
 294          call elj(evdw)
 295 !d    print '(a)','Exit ELJcall el'
 296 !      goto 107
 297 ! Lennard-Jones-Kihara potential (shifted).
 298 !  102 call eljk(evdw)
 299        case (2)
 300          call eljk(evdw)
 301 !      goto 107
 302 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 303 !  103 call ebp(evdw)
 304        case (3)
 305          call ebp(evdw)
 306 !      goto 107
 307 ! Gay-Berne potential (shifted LJ, angular dependence).
 308 !  104 call egb(evdw)
 309        case (4)
 310          call egb(evdw)
 311 !      goto 107
 312 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 313 !  105 call egbv(evdw)
 314        case (5)
 315          call egbv(evdw)
 316 !      goto 107
 317 ! Soft-sphere potential
 318 !  106 call e_softsphere(evdw)
 319        case (6)
 320          call e_softsphere(evdw)
 321 !
 322 ! Calculate electrostatic (H-bonding) energy of the main chain.
 323 !
 324 !  107 continue
 325        case default
 326          write(iout,*)"Wrong ipot"
 327 !         return
 328 !   50 continue
 329       end select
 330 !      continue
 331
 332 !mc
 333 !mc Sep-06: egb takes care of dynamic ss bonds too
 334 !mc
 335 !      if (dyn_ss) call dyn_set_nss
 336 !      print *,"Processor",myrank," computed USCSC"
 337 #ifdef TIMING
 338       time01=MPI_Wtime()
 339 #endif
 340       call vec_and_deriv
 341 #ifdef TIMING
 342       time_vec=time_vec+MPI_Wtime()-time01
 343 #endif
 344 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 345       if (ipot.lt.6) then
 346 #ifdef SPLITELE
 347          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 348              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 349              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 350              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 351 #else
 352          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 353              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 354              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 355              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 356 #endif
 357             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 358 !        write (iout,*) "ELEC calc"
 359          else
 360             ees=0.0d0
 361             evdw1=0.0d0
 362             eel_loc=0.0d0
 363             eello_turn3=0.0d0
 364             eello_turn4=0.0d0
 365          endif
 366       else
 367 !        write (iout,*) "Soft-spheer ELEC potential"
 368         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 369          eello_turn4)
 370       endif
 371 !      print *,"Processor",myrank," computed UELEC"
 372 !
 373 ! Calculate excluded-volume interaction energy between peptide groups
 374 ! and side chains.
 375 !
 376 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 377
 378       if (ipot.lt.6) then
 379        if(wscp.gt.0d0) then
 380         call escp(evdw2,evdw2_14)
 381        else
 382         evdw2=0
 383         evdw2_14=0
 384        endif
 385       else
 386 !        write (iout,*) "Soft-sphere SCP potential"
 387         call escp_soft_sphere(evdw2,evdw2_14)
 388       endif
 389 !elwrite(iout,*) "in etotal before ebond",ipot
 390
 391 !
 392 ! Calculate the bond-stretching energy
 393 !
 394       call ebond(estr)
 395 !elwrite(iout,*) "in etotal afer ebond",ipot
 396
 397 !
 398 ! Calculate the disulfide-bridge and other energy and the contributions
 399 ! from other distance constraints.
 400 !      print *,'Calling EHPB'
 401       call edis(ehpb)
 402 !elwrite(iout,*) "in etotal afer edis",ipot
 403 !      print *,'EHPB exitted succesfully.'
 404 !
 405 ! Calculate the virtual-bond-angle energy.
 406 !
 407       if (wang.gt.0d0) then
 408         call ebend(ebe)
 409       else
 410         ebe=0
 411       endif
 412 !      print *,"Processor",myrank," computed UB"
 413 !
 414 ! Calculate the SC local energy.
 415 !
 416       call esc(escloc)
 417 !elwrite(iout,*) "in etotal afer esc",ipot
 418 !      print *,"Processor",myrank," computed USC"
 419 !
 420 ! Calculate the virtual-bond torsional energy.
 421 !
 422 !d    print *,'nterm=',nterm
 423       if (wtor.gt.0) then
 424        call etor(etors,edihcnstr)
 425       else
 426        etors=0
 427        edihcnstr=0
 428       endif
 429 !      print *,"Processor",myrank," computed Utor"
 430 !
 431 ! 6/23/01 Calculate double-torsional energy
 432 !
 433 !elwrite(iout,*) "in etotal",ipot
 434       if (wtor_d.gt.0) then
 435        call etor_d(etors_d)
 436       else
 437        etors_d=0
 438       endif
 439 !      print *,"Processor",myrank," computed Utord"
 440 !
 441 ! 21/5/07 Calculate local sicdechain correlation energy
 442 !
 443       if (wsccor.gt.0.0d0) then
 444         call eback_sc_corr(esccor)
 445       else
 446         esccor=0.0d0
 447       endif
 448 !      print *,"Processor",myrank," computed Usccorr"
 449 !
 450 ! 12/1/95 Multi-body terms
 451 !
 452       n_corr=0
 453       n_corr1=0
 454       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 455           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 456          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 457 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 458 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 459       else
 460          ecorr=0.0d0
 461          ecorr5=0.0d0
 462          ecorr6=0.0d0
 463          eturn6=0.0d0
 464       endif
 465 !elwrite(iout,*) "in etotal",ipot
 466       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 467          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 468 !d         write (iout,*) "multibody_hb ecorr",ecorr
 469       endif
 470 !elwrite(iout,*) "afeter  multibody hb"
 471
 472 !      print *,"Processor",myrank," computed Ucorr"
 473 !
 474 ! If performing constraint dynamics, call the constraint energy
 475 !  after the equilibration time
 476       if(usampl.and.totT.gt.eq_time) then
 477 !elwrite(iout,*) "afeter  multibody hb"
 478          call EconstrQ
 479 !elwrite(iout,*) "afeter  multibody hb"
 480          call Econstr_back
 481 !elwrite(iout,*) "afeter  multibody hb"
 482       else
 483          Uconst=0.0d0
 484          Uconst_back=0.0d0
 485       endif
 486 !elwrite(iout,*) "after Econstr"
 487
 488 #ifdef TIMING
 489       time_enecalc=time_enecalc+MPI_Wtime()-time00
 490 #endif
 491 !      print *,"Processor",myrank," computed Uconstr"
 492 #ifdef TIMING
 493       time00=MPI_Wtime()
 494 #endif
 495 !
 496 ! Sum the energies
 497 !
 498       energia(1)=evdw
 499 #ifdef SCP14
 500       energia(2)=evdw2-evdw2_14
 501       energia(18)=evdw2_14
 502 #else
 503       energia(2)=evdw2
 504       energia(18)=0.0d0
 505 #endif
 506 #ifdef SPLITELE
 507       energia(3)=ees
 508       energia(16)=evdw1
 509 #else
 510       energia(3)=ees+evdw1
 511       energia(16)=0.0d0
 512 #endif
 513       energia(4)=ecorr
 514       energia(5)=ecorr5
 515       energia(6)=ecorr6
 516       energia(7)=eel_loc
 517       energia(8)=eello_turn3
 518       energia(9)=eello_turn4
 519       energia(10)=eturn6
 520       energia(11)=ebe
 521       energia(12)=escloc
 522       energia(13)=etors
 523       energia(14)=etors_d
 524       energia(15)=ehpb
 525       energia(19)=edihcnstr
 526       energia(17)=estr
 527       energia(20)=Uconst+Uconst_back
 528       energia(21)=esccor
 529 !    Here are the energies showed per procesor if the are more processors
 530 !    per molecule then we sum it up in sum_energy subroutine
 531 !      print *," Processor",myrank," calls SUM_ENERGY"
 532       call sum_energy(energia,.true.)
 533       if (dyn_ss) call dyn_set_nss
 534 !      print *," Processor",myrank," left SUM_ENERGY"
 535 #ifdef TIMING
 536       time_sumene=time_sumene+MPI_Wtime()-time00
 537 #endif
 538 !el        call enerprint(energia)
 539 !elwrite(iout,*)"finish etotal"
 540       return
 541       end subroutine etotal
 542 !-----------------------------------------------------------------------------
 543       subroutine sum_energy(energia,reduce)
 544 !      implicit real*8 (a-h,o-z)
 545 !      include 'DIMENSIONS'
 546 #ifndef ISNAN
 547       external proc_proc
 548 #ifdef WINPGI
 549 !MS$ATTRIBUTES C ::  proc_proc
 550 #endif
 551 #endif
 552 #ifdef MPI
 553       include "mpif.h"
 554 #endif
 555 !      include 'COMMON.SETUP'
 556 !      include 'COMMON.IOUNITS'
 557       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 558 !      include 'COMMON.FFIELD'
 559 !      include 'COMMON.DERIV'
 560 !      include 'COMMON.INTERACT'
 561 !      include 'COMMON.SBRIDGE'
 562 !      include 'COMMON.CHAIN'
 563 !      include 'COMMON.VAR'
 564 !      include 'COMMON.CONTROL'
 565 !      include 'COMMON.TIME1'
 566       logical :: reduce
 567       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 568       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 569       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 570       integer :: i
 571 #ifdef MPI
 572       integer :: ierr
 573       real(kind=8) :: time00
 574       if (nfgtasks.gt.1 .and. reduce) then
 575
 576 #ifdef DEBUG
 577         write (iout,*) "energies before REDUCE"
 578         call enerprint(energia)
 579         call flush(iout)
 580 #endif
 581         do i=0,n_ene
 582           enebuff(i)=energia(i)
 583         enddo
 584         time00=MPI_Wtime()
 585         call MPI_Barrier(FG_COMM,IERR)
 586         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 587         time00=MPI_Wtime()
 588         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 589           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 590 #ifdef DEBUG
 591         write (iout,*) "energies after REDUCE"
 592         call enerprint(energia)
 593         call flush(iout)
 594 #endif
 595         time_Reduce=time_Reduce+MPI_Wtime()-time00
 596       endif
 597       if (fg_rank.eq.0) then
 598 #endif
 599       evdw=energia(1)
 600 #ifdef SCP14
 601       evdw2=energia(2)+energia(18)
 602       evdw2_14=energia(18)
 603 #else
 604       evdw2=energia(2)
 605 #endif
 606 #ifdef SPLITELE
 607       ees=energia(3)
 608       evdw1=energia(16)
 609 #else
 610       ees=energia(3)
 611       evdw1=0.0d0
 612 #endif
 613       ecorr=energia(4)
 614       ecorr5=energia(5)
 615       ecorr6=energia(6)
 616       eel_loc=energia(7)
 617       eello_turn3=energia(8)
 618       eello_turn4=energia(9)
 619       eturn6=energia(10)
 620       ebe=energia(11)
 621       escloc=energia(12)
 622       etors=energia(13)
 623       etors_d=energia(14)
 624       ehpb=energia(15)
 625       edihcnstr=energia(19)
 626       estr=energia(17)
 627       Uconst=energia(20)
 628       esccor=energia(21)
 629 #ifdef SPLITELE
 630       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 631        +wang*ebe+wtor*etors+wscloc*escloc &
 632        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 633        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 634        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 635        +wbond*estr+Uconst+wsccor*esccor
 636 #else
 637       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 638        +wang*ebe+wtor*etors+wscloc*escloc &
 639        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 640        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 641        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 642        +wbond*estr+Uconst+wsccor*esccor
 643 #endif
 644       energia(0)=etot
 645 ! detecting NaNQ
 646 #ifdef ISNAN
 647 #ifdef AIX
 648       if (isnan(etot).ne.0) energia(0)=1.0d+99
 649 #else
 650       if (isnan(etot)) energia(0)=1.0d+99
 651 #endif
 652 #else
 653       i=0
 654 #ifdef WINPGI
 655       idumm=proc_proc(etot,i)
 656 #else
 657       call proc_proc(etot,i)
 658 #endif
 659       if(i.eq.1)energia(0)=1.0d+99
 660 #endif
 661 #ifdef MPI
 662       endif
 663 #endif
 664 !      call enerprint(energia)
 665       call flush(iout)
 666       return
 667       end subroutine sum_energy
 668 !-----------------------------------------------------------------------------
 669       subroutine rescale_weights(t_bath)
 670 !      implicit real*8 (a-h,o-z)
 671 #ifdef MPI
 672       include 'mpif.h'
 673 #endif
 674 !      include 'DIMENSIONS'
 675 !      include 'COMMON.IOUNITS'
 676 !      include 'COMMON.FFIELD'
 677 !      include 'COMMON.SBRIDGE'
 678       real(kind=8) :: kfac=2.4d0
 679       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 680 !el local variables
 681       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 682       real(kind=8) :: T0=3.0d2
 683       integer :: ierror
 684 !      facT=temp0/t_bath
 685 !      facT=2*temp0/(t_bath+temp0)
 686       if (rescale_mode.eq.0) then
 687         facT(1)=1.0d0
 688         facT(2)=1.0d0
 689         facT(3)=1.0d0
 690         facT(4)=1.0d0
 691         facT(5)=1.0d0
 692         facT(6)=1.0d0
 693       else if (rescale_mode.eq.1) then
 694         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 695         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 696         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 697         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 698         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 699 #ifdef WHAM_RUN
 700 !#if defined(WHAM_RUN) || defined(CLUSTER)
 701 #if defined(FUNCTH)
 702 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 703         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 704 #elif defined(FUNCT)
 705         facT(6)=t_bath/T0
 706 #else
 707         facT(6)=1.0d0
 708 #endif
 709 #endif
 710       else if (rescale_mode.eq.2) then
 711         x=t_bath/temp0
 712         x2=x*x
 713         x3=x2*x
 714         x4=x3*x
 715         x5=x4*x
 716         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 717         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 718         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 719         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 720         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 721 #ifdef WHAM_RUN
 722 !#if defined(WHAM_RUN) || defined(CLUSTER)
 723 #if defined(FUNCTH)
 724         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 725 #elif defined(FUNCT)
 726         facT(6)=t_bath/T0
 727 #else
 728         facT(6)=1.0d0
 729 #endif
 730 #endif
 731       else
 732         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 733         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 734 #ifdef MPI
 735        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 736 #endif
 737        stop 555
 738       endif
 739       welec=weights(3)*fact(1)
 740       wcorr=weights(4)*fact(3)
 741       wcorr5=weights(5)*fact(4)
 742       wcorr6=weights(6)*fact(5)
 743       wel_loc=weights(7)*fact(2)
 744       wturn3=weights(8)*fact(2)
 745       wturn4=weights(9)*fact(3)
 746       wturn6=weights(10)*fact(5)
 747       wtor=weights(13)*fact(1)
 748       wtor_d=weights(14)*fact(2)
 749       wsccor=weights(21)*fact(1)
 750
 751       return
 752       end subroutine rescale_weights
 753 !-----------------------------------------------------------------------------
 754       subroutine enerprint(energia)
 755 !      implicit real*8 (a-h,o-z)
 756 !      include 'DIMENSIONS'
 757 !      include 'COMMON.IOUNITS'
 758 !      include 'COMMON.FFIELD'
 759 !      include 'COMMON.SBRIDGE'
 760 !      include 'COMMON.MD'
 761       real(kind=8) :: energia(0:n_ene)
 762 !el local variables
 763       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 764       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 765       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 766
 767       etot=energia(0)
 768       evdw=energia(1)
 769       evdw2=energia(2)
 770 #ifdef SCP14
 771       evdw2=energia(2)+energia(18)
 772 #else
 773       evdw2=energia(2)
 774 #endif
 775       ees=energia(3)
 776 #ifdef SPLITELE
 777       evdw1=energia(16)
 778 #endif
 779       ecorr=energia(4)
 780       ecorr5=energia(5)
 781       ecorr6=energia(6)
 782       eel_loc=energia(7)
 783       eello_turn3=energia(8)
 784       eello_turn4=energia(9)
 785       eello_turn6=energia(10)
 786       ebe=energia(11)
 787       escloc=energia(12)
 788       etors=energia(13)
 789       etors_d=energia(14)
 790       ehpb=energia(15)
 791       edihcnstr=energia(19)
 792       estr=energia(17)
 793       Uconst=energia(20)
 794       esccor=energia(21)
 795 #ifdef SPLITELE
 796       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 797         estr,wbond,ebe,wang,&
 798         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 799         ecorr,wcorr,&
 800         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 801         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 802         edihcnstr,ebr*nss,&
 803         Uconst,etot
 804    10 format (/'Virtual-chain energies:'// &
 805        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 806        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 807        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 808        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 809        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 810        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 811        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 812        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 813        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 814        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 815        ' (SS bridges & dist. cnstr.)'/ &
 816        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 817        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 818        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 819        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 820        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 821        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 822        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 823        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 824        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 825        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 826        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 827        'ETOT=  ',1pE16.6,' (total)')
 828 #else
 829       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 830         estr,wbond,ebe,wang,&
 831         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 832         ecorr,wcorr,&
 833         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 834         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 835         ebr*nss,Uconst,etot
 836    10 format (/'Virtual-chain energies:'// &
 837        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 838        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 839        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 840        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 841        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 842        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 843        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 844        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 845        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 846        ' (SS bridges & dist. cnstr.)'/ &
 847        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 848        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 849        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 850        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 851        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 852        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 853        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 854        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 855        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 856        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 857        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 858        'ETOT=  ',1pE16.6,' (total)')
 859 #endif
 860       return
 861       end subroutine enerprint
 862 !-----------------------------------------------------------------------------
 863       subroutine elj(evdw)
 864 !
 865 ! This subroutine calculates the interaction energy of nonbonded side chains
 866 ! assuming the LJ potential of interaction.
 867 !
 868 !      implicit real*8 (a-h,o-z)
 869 !      include 'DIMENSIONS'
 870       real(kind=8),parameter :: accur=1.0d-10
 871 !      include 'COMMON.GEO'
 872 !      include 'COMMON.VAR'
 873 !      include 'COMMON.LOCAL'
 874 !      include 'COMMON.CHAIN'
 875 !      include 'COMMON.DERIV'
 876 !      include 'COMMON.INTERACT'
 877 !      include 'COMMON.TORSION'
 878 !      include 'COMMON.SBRIDGE'
 879 !      include 'COMMON.NAMES'
 880 !      include 'COMMON.IOUNITS'
 881 !      include 'COMMON.CONTACTS'
 882       real(kind=8),dimension(3) :: gg
 883       integer :: num_conti
 884 !el local variables
 885       integer :: i,itypi,iint,j,itypi1,itypj,k
 886       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 887       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 888       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 889
 890 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 891       evdw=0.0D0
 892 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 893 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 894 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 895 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 896
 897       do i=iatsc_s,iatsc_e
 898         itypi=iabs(itype(i))
 899         if (itypi.eq.ntyp1) cycle
 900         itypi1=iabs(itype(i+1))
 901         xi=c(1,nres+i)
 902         yi=c(2,nres+i)
 903         zi=c(3,nres+i)
 904 ! Change 12/1/95
 905         num_conti=0
 906 !
 907 ! Calculate SC interaction energy.
 908 !
 909         do iint=1,nint_gr(i)
 910 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 911 !d   &                  'iend=',iend(i,iint)
 912           do j=istart(i,iint),iend(i,iint)
 913             itypj=iabs(itype(j))
 914             if (itypj.eq.ntyp1) cycle
 915             xj=c(1,nres+j)-xi
 916             yj=c(2,nres+j)-yi
 917             zj=c(3,nres+j)-zi
 918 ! Change 12/1/95 to calculate four-body interactions
 919             rij=xj*xj+yj*yj+zj*zj
 920             rrij=1.0D0/rij
 921 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 922             eps0ij=eps(itypi,itypj)
 923             fac=rrij**expon2
 924             e1=fac*fac*aa(itypi,itypj)
 925             e2=fac*bb(itypi,itypj)
 926             evdwij=e1+e2
 927 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 928 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 929 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 930 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 931 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 932 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 933             evdw=evdw+evdwij
 934 !
 935 ! Calculate the components of the gradient in DC and X
 936 !
 937             fac=-rrij*(e1+evdwij)
 938             gg(1)=xj*fac
 939             gg(2)=yj*fac
 940             gg(3)=zj*fac
 941             do k=1,3
 942               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 943               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 944               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 945               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 946             enddo
 947 !grad            do k=i,j-1
 948 !grad              do l=1,3
 949 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 950 !grad              enddo
 951 !grad            enddo
 952 !
 953 ! 12/1/95, revised on 5/20/97
 954 !
 955 ! Calculate the contact function. The ith column of the array JCONT will
 956 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 957 ! greater than I). The arrays FACONT and GACONT will contain the values of
 958 ! the contact function and its derivative.
 959 !
 960 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 961 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 962 ! Uncomment next line, if the correlation interactions are contact function only
 963             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 964               rij=dsqrt(rij)
 965               sigij=sigma(itypi,itypj)
 966               r0ij=rs0(itypi,itypj)
 967 !
 968 ! Check whether the SC's are not too far to make a contact.
 969 !
 970               rcut=1.5d0*r0ij
 971               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 972 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 973 !
 974               if (fcont.gt.0.0D0) then
 975 ! If the SC-SC distance if close to sigma, apply spline.
 976 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 977 !Adam &             fcont1,fprimcont1)
 978 !Adam           fcont1=1.0d0-fcont1
 979 !Adam           if (fcont1.gt.0.0d0) then
 980 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 981 !Adam             fcont=fcont*fcont1
 982 !Adam           endif
 983 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 984 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 985 !ga             do k=1,3
 986 !ga               gg(k)=gg(k)*eps0ij
 987 !ga             enddo
 988 !ga             eps0ij=-evdwij*eps0ij
 989 ! Uncomment for AL's type of SC correlation interactions.
 990 !adam           eps0ij=-evdwij
 991                 num_conti=num_conti+1
 992                 jcont(num_conti,i)=j
 993                 facont(num_conti,i)=fcont*eps0ij
 994                 fprimcont=eps0ij*fprimcont/rij
 995                 fcont=expon*fcont
 996 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 997 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 998 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 999 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1000                 gacont(1,num_conti,i)=-fprimcont*xj
1001                 gacont(2,num_conti,i)=-fprimcont*yj
1002                 gacont(3,num_conti,i)=-fprimcont*zj
1003 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1004 !d              write (iout,'(2i3,3f10.5)')
1005 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1006               endif
1007             endif
1008           enddo      ! j
1009         enddo        ! iint
1010 ! Change 12/1/95
1011         num_cont(i)=num_conti
1012       enddo          ! i
1013       do i=1,nct
1014         do j=1,3
1015           gvdwc(j,i)=expon*gvdwc(j,i)
1016           gvdwx(j,i)=expon*gvdwx(j,i)
1017         enddo
1018       enddo
1019 !******************************************************************************
1020 !
1021 !                              N O T E !!!
1022 !
1023 ! To save time, the factor of EXPON has been extracted from ALL components
1024 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1025 ! use!
1026 !
1027 !******************************************************************************
1028       return
1029       end subroutine elj
1030 !-----------------------------------------------------------------------------
1031       subroutine eljk(evdw)
1032 !
1033 ! This subroutine calculates the interaction energy of nonbonded side chains
1034 ! assuming the LJK potential of interaction.
1035 !
1036 !      implicit real*8 (a-h,o-z)
1037 !      include 'DIMENSIONS'
1038 !      include 'COMMON.GEO'
1039 !      include 'COMMON.VAR'
1040 !      include 'COMMON.LOCAL'
1041 !      include 'COMMON.CHAIN'
1042 !      include 'COMMON.DERIV'
1043 !      include 'COMMON.INTERACT'
1044 !      include 'COMMON.IOUNITS'
1045 !      include 'COMMON.NAMES'
1046       real(kind=8),dimension(3) :: gg
1047       logical :: scheck
1048 !el local variables
1049       integer :: i,iint,j,itypi,itypi1,k,itypj
1050       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1051       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1052
1053 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1054       evdw=0.0D0
1055       do i=iatsc_s,iatsc_e
1056         itypi=iabs(itype(i))
1057         if (itypi.eq.ntyp1) cycle
1058         itypi1=iabs(itype(i+1))
1059         xi=c(1,nres+i)
1060         yi=c(2,nres+i)
1061         zi=c(3,nres+i)
1062 !
1063 ! Calculate SC interaction energy.
1064 !
1065         do iint=1,nint_gr(i)
1066           do j=istart(i,iint),iend(i,iint)
1067             itypj=iabs(itype(j))
1068             if (itypj.eq.ntyp1) cycle
1069             xj=c(1,nres+j)-xi
1070             yj=c(2,nres+j)-yi
1071             zj=c(3,nres+j)-zi
1072             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1073             fac_augm=rrij**expon
1074             e_augm=augm(itypi,itypj)*fac_augm
1075             r_inv_ij=dsqrt(rrij)
1076             rij=1.0D0/r_inv_ij
1077             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1078             fac=r_shift_inv**expon
1079             e1=fac*fac*aa(itypi,itypj)
1080             e2=fac*bb(itypi,itypj)
1081             evdwij=e_augm+e1+e2
1082 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1083 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1084 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1085 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1086 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1087 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1088 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1089             evdw=evdw+evdwij
1090 !
1091 ! Calculate the components of the gradient in DC and X
1092 !
1093             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1094             gg(1)=xj*fac
1095             gg(2)=yj*fac
1096             gg(3)=zj*fac
1097             do k=1,3
1098               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1099               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1100               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1101               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1102             enddo
1103 !grad            do k=i,j-1
1104 !grad              do l=1,3
1105 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1106 !grad              enddo
1107 !grad            enddo
1108           enddo      ! j
1109         enddo        ! iint
1110       enddo          ! i
1111       do i=1,nct
1112         do j=1,3
1113           gvdwc(j,i)=expon*gvdwc(j,i)
1114           gvdwx(j,i)=expon*gvdwx(j,i)
1115         enddo
1116       enddo
1117       return
1118       end subroutine eljk
1119 !-----------------------------------------------------------------------------
1120       subroutine ebp(evdw)
1121 !
1122 ! This subroutine calculates the interaction energy of nonbonded side chains
1123 ! assuming the Berne-Pechukas potential of interaction.
1124 !
1125       use comm_srutu
1126       use calc_data
1127 !      implicit real*8 (a-h,o-z)
1128 !      include 'DIMENSIONS'
1129 !      include 'COMMON.GEO'
1130 !      include 'COMMON.VAR'
1131 !      include 'COMMON.LOCAL'
1132 !      include 'COMMON.CHAIN'
1133 !      include 'COMMON.DERIV'
1134 !      include 'COMMON.NAMES'
1135 !      include 'COMMON.INTERACT'
1136 !      include 'COMMON.IOUNITS'
1137 !      include 'COMMON.CALC'
1138       use comm_srutu
1139 !el      integer :: icall
1140 !el      common /srutu/ icall
1141 !     double precision rrsave(maxdim)
1142       logical :: lprn
1143 !el local variables
1144       integer :: iint,itypi,itypi1,itypj
1145       real(kind=8) :: rrij,xi,yi,zi
1146       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1147
1148 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1149       evdw=0.0D0
1150 !     if (icall.eq.0) then
1151 !       lprn=.true.
1152 !     else
1153         lprn=.false.
1154 !     endif
1155 !el      ind=0
1156       do i=iatsc_s,iatsc_e
1157         itypi=iabs(itype(i))
1158         if (itypi.eq.ntyp1) cycle
1159         itypi1=iabs(itype(i+1))
1160         xi=c(1,nres+i)
1161         yi=c(2,nres+i)
1162         zi=c(3,nres+i)
1163         dxi=dc_norm(1,nres+i)
1164         dyi=dc_norm(2,nres+i)
1165         dzi=dc_norm(3,nres+i)
1166 !        dsci_inv=dsc_inv(itypi)
1167         dsci_inv=vbld_inv(i+nres)
1168 !
1169 ! Calculate SC interaction energy.
1170 !
1171         do iint=1,nint_gr(i)
1172           do j=istart(i,iint),iend(i,iint)
1173 !el            ind=ind+1
1174             itypj=iabs(itype(j))
1175             if (itypj.eq.ntyp1) cycle
1176 !            dscj_inv=dsc_inv(itypj)
1177             dscj_inv=vbld_inv(j+nres)
1178             chi1=chi(itypi,itypj)
1179             chi2=chi(itypj,itypi)
1180             chi12=chi1*chi2
1181             chip1=chip(itypi)
1182             chip2=chip(itypj)
1183             chip12=chip1*chip2
1184             alf1=alp(itypi)
1185             alf2=alp(itypj)
1186             alf12=0.5D0*(alf1+alf2)
1187 ! For diagnostics only!!!
1188 !           chi1=0.0D0
1189 !           chi2=0.0D0
1190 !           chi12=0.0D0
1191 !           chip1=0.0D0
1192 !           chip2=0.0D0
1193 !           chip12=0.0D0
1194 !           alf1=0.0D0
1195 !           alf2=0.0D0
1196 !           alf12=0.0D0
1197             xj=c(1,nres+j)-xi
1198             yj=c(2,nres+j)-yi
1199             zj=c(3,nres+j)-zi
1200             dxj=dc_norm(1,nres+j)
1201             dyj=dc_norm(2,nres+j)
1202             dzj=dc_norm(3,nres+j)
1203             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1204 !d          if (icall.eq.0) then
1205 !d            rrsave(ind)=rrij
1206 !d          else
1207 !d            rrij=rrsave(ind)
1208 !d          endif
1209             rij=dsqrt(rrij)
1210 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1211             call sc_angular
1212 ! Calculate whole angle-dependent part of epsilon and contributions
1213 ! to its derivatives
1214             fac=(rrij*sigsq)**expon2
1215             e1=fac*fac*aa(itypi,itypj)
1216             e2=fac*bb(itypi,itypj)
1217             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1218             eps2der=evdwij*eps3rt
1219             eps3der=evdwij*eps2rt
1220             evdwij=evdwij*eps2rt*eps3rt
1221             evdw=evdw+evdwij
1222             if (lprn) then
1223             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1224             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1225 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1226 !d     &        restyp(itypi),i,restyp(itypj),j,
1227 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1228 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1229 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1230 !d     &        evdwij
1231             endif
1232 ! Calculate gradient components.
1233             e1=e1*eps1*eps2rt**2*eps3rt**2
1234             fac=-expon*(e1+evdwij)
1235             sigder=fac/sigsq
1236             fac=rrij*fac
1237 ! Calculate radial part of the gradient
1238             gg(1)=xj*fac
1239             gg(2)=yj*fac
1240             gg(3)=zj*fac
1241 ! Calculate the angular part of the gradient and sum add the contributions
1242 ! to the appropriate components of the Cartesian gradient.
1243             call sc_grad
1244           enddo      ! j
1245         enddo        ! iint
1246       enddo          ! i
1247 !     stop
1248       return
1249       end subroutine ebp
1250 !-----------------------------------------------------------------------------
1251       subroutine egb(evdw)
1252 !
1253 ! This subroutine calculates the interaction energy of nonbonded side chains
1254 ! assuming the Gay-Berne potential of interaction.
1255 !
1256       use calc_data
1257 !      implicit real*8 (a-h,o-z)
1258 !      include 'DIMENSIONS'
1259 !      include 'COMMON.GEO'
1260 !      include 'COMMON.VAR'
1261 !      include 'COMMON.LOCAL'
1262 !      include 'COMMON.CHAIN'
1263 !      include 'COMMON.DERIV'
1264 !      include 'COMMON.NAMES'
1265 !      include 'COMMON.INTERACT'
1266 !      include 'COMMON.IOUNITS'
1267 !      include 'COMMON.CALC'
1268 !      include 'COMMON.CONTROL'
1269 !      include 'COMMON.SBRIDGE'
1270       logical :: lprn
1271 !el local variables
1272       integer :: iint,itypi,itypi1,itypj
1273       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1274       real(kind=8) :: evdw,sig0ij
1275       integer :: ii
1276 !cccc      energy_dec=.false.
1277 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1278       evdw=0.0D0
1279       lprn=.false.
1280 !     if (icall.eq.0) lprn=.false.
1281 !el      ind=0
1282       do i=iatsc_s,iatsc_e
1283         itypi=iabs(itype(i))
1284         if (itypi.eq.ntyp1) cycle
1285         itypi1=iabs(itype(i+1))
1286         xi=c(1,nres+i)
1287         yi=c(2,nres+i)
1288         zi=c(3,nres+i)
1289         dxi=dc_norm(1,nres+i)
1290         dyi=dc_norm(2,nres+i)
1291         dzi=dc_norm(3,nres+i)
1292 !        dsci_inv=dsc_inv(itypi)
1293         dsci_inv=vbld_inv(i+nres)
1294 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1295 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1296 !
1297 ! Calculate SC interaction energy.
1298 !
1299         do iint=1,nint_gr(i)
1300           do j=istart(i,iint),iend(i,iint)
1301             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1302               call dyn_ssbond_ene(i,j,evdwij)
1303               evdw=evdw+evdwij
1304               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1305                               'evdw',i,j,evdwij,' ss'
1306 !              if (energy_dec) write (iout,*) &
1307 !                              'evdw',i,j,evdwij,' ss'
1308             ELSE
1309 !el            ind=ind+1
1310             itypj=iabs(itype(j))
1311             if (itypj.eq.ntyp1) cycle
1312 !            dscj_inv=dsc_inv(itypj)
1313             dscj_inv=vbld_inv(j+nres)
1314 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1315 !              1.0d0/vbld(j+nres) !d
1316 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1317             sig0ij=sigma(itypi,itypj)
1318             chi1=chi(itypi,itypj)
1319             chi2=chi(itypj,itypi)
1320             chi12=chi1*chi2
1321             chip1=chip(itypi)
1322             chip2=chip(itypj)
1323             chip12=chip1*chip2
1324             alf1=alp(itypi)
1325             alf2=alp(itypj)
1326             alf12=0.5D0*(alf1+alf2)
1327 ! For diagnostics only!!!
1328 !           chi1=0.0D0
1329 !           chi2=0.0D0
1330 !           chi12=0.0D0
1331 !           chip1=0.0D0
1332 !           chip2=0.0D0
1333 !           chip12=0.0D0
1334 !           alf1=0.0D0
1335 !           alf2=0.0D0
1336 !           alf12=0.0D0
1337             xj=c(1,nres+j)-xi
1338             yj=c(2,nres+j)-yi
1339             zj=c(3,nres+j)-zi
1340             dxj=dc_norm(1,nres+j)
1341             dyj=dc_norm(2,nres+j)
1342             dzj=dc_norm(3,nres+j)
1343 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1344 !            write (iout,*) "j",j," dc_norm",& !d
1345 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1346 !          write(iout,*)"rrij ",rrij
1347 !          write(iout,*)"xj yj zj ", xj, yj, zj
1348 !          write(iout,*)"xi yi zi ", xi, yi, zi
1349 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351             rij=dsqrt(rrij)
1352 ! Calculate angle-dependent terms of energy and contributions to their
1353 ! derivatives.
1354             call sc_angular
1355             sigsq=1.0D0/sigsq
1356             sig=sig0ij*dsqrt(sigsq)
1357             rij_shift=1.0D0/rij-sig+sig0ij
1358 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1359 !            "sig0ij",sig0ij
1360 ! for diagnostics; uncomment
1361 !            rij_shift=1.2*sig0ij
1362 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1363             if (rij_shift.le.0.0D0) then
1364               evdw=1.0D20
1365 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1366 !d     &        restyp(itypi),i,restyp(itypj),j,
1367 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1368               return
1369             endif
1370             sigder=-sig*sigsq
1371 !---------------------------------------------------------------
1372             rij_shift=1.0D0/rij_shift
1373             fac=rij_shift**expon
1374             e1=fac*fac*aa(itypi,itypj)
1375             e2=fac*bb(itypi,itypj)
1376             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1377             eps2der=evdwij*eps3rt
1378             eps3der=evdwij*eps2rt
1379 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1380 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1381 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1382             evdwij=evdwij*eps2rt*eps3rt
1383             evdw=evdw+evdwij
1384             if (lprn) then
1385             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1386             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1387             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1388               restyp(itypi),i,restyp(itypj),j, &
1389               epsi,sigm,chi1,chi2,chip1,chip2, &
1390               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1391               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1392               evdwij
1393             endif
1394
1395             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1396                              'evdw',i,j,evdwij !,"egb"
1397 !            if (energy_dec) write (iout,*) &
1398 !                             'evdw',i,j,evdwij
1399
1400 ! Calculate gradient components.
1401             e1=e1*eps1*eps2rt**2*eps3rt**2
1402             fac=-expon*(e1+evdwij)*rij_shift
1403             sigder=fac*sigder
1404             fac=rij*fac
1405 !            fac=0.0d0
1406 ! Calculate the radial part of the gradient
1407             gg(1)=xj*fac
1408             gg(2)=yj*fac
1409             gg(3)=zj*fac
1410 ! Calculate angular part of the gradient.
1411             call sc_grad
1412             ENDIF    ! dyn_ss
1413           enddo      ! j
1414         enddo        ! iint
1415       enddo          ! i
1416 !      write (iout,*) "Number of loop steps in EGB:",ind
1417 !ccc      energy_dec=.false.
1418       return
1419       end subroutine egb
1420 !-----------------------------------------------------------------------------
1421       subroutine egbv(evdw)
1422 !
1423 ! This subroutine calculates the interaction energy of nonbonded side chains
1424 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1425 !
1426       use comm_srutu
1427       use calc_data
1428 !      implicit real*8 (a-h,o-z)
1429 !      include 'DIMENSIONS'
1430 !      include 'COMMON.GEO'
1431 !      include 'COMMON.VAR'
1432 !      include 'COMMON.LOCAL'
1433 !      include 'COMMON.CHAIN'
1434 !      include 'COMMON.DERIV'
1435 !      include 'COMMON.NAMES'
1436 !      include 'COMMON.INTERACT'
1437 !      include 'COMMON.IOUNITS'
1438 !      include 'COMMON.CALC'
1439       use comm_srutu
1440 !el      integer :: icall
1441 !el      common /srutu/ icall
1442       logical :: lprn
1443 !el local variables
1444       integer :: iint,itypi,itypi1,itypj
1445       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1446       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1447
1448 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1449       evdw=0.0D0
1450       lprn=.false.
1451 !     if (icall.eq.0) lprn=.true.
1452 !el      ind=0
1453       do i=iatsc_s,iatsc_e
1454         itypi=iabs(itype(i))
1455         if (itypi.eq.ntyp1) cycle
1456         itypi1=iabs(itype(i+1))
1457         xi=c(1,nres+i)
1458         yi=c(2,nres+i)
1459         zi=c(3,nres+i)
1460         dxi=dc_norm(1,nres+i)
1461         dyi=dc_norm(2,nres+i)
1462         dzi=dc_norm(3,nres+i)
1463 !        dsci_inv=dsc_inv(itypi)
1464         dsci_inv=vbld_inv(i+nres)
1465 !
1466 ! Calculate SC interaction energy.
1467 !
1468         do iint=1,nint_gr(i)
1469           do j=istart(i,iint),iend(i,iint)
1470 !el            ind=ind+1
1471             itypj=iabs(itype(j))
1472             if (itypj.eq.ntyp1) cycle
1473 !            dscj_inv=dsc_inv(itypj)
1474             dscj_inv=vbld_inv(j+nres)
1475             sig0ij=sigma(itypi,itypj)
1476             r0ij=r0(itypi,itypj)
1477             chi1=chi(itypi,itypj)
1478             chi2=chi(itypj,itypi)
1479             chi12=chi1*chi2
1480             chip1=chip(itypi)
1481             chip2=chip(itypj)
1482             chip12=chip1*chip2
1483             alf1=alp(itypi)
1484             alf2=alp(itypj)
1485             alf12=0.5D0*(alf1+alf2)
1486 ! For diagnostics only!!!
1487 !           chi1=0.0D0
1488 !           chi2=0.0D0
1489 !           chi12=0.0D0
1490 !           chip1=0.0D0
1491 !           chip2=0.0D0
1492 !           chip12=0.0D0
1493 !           alf1=0.0D0
1494 !           alf2=0.0D0
1495 !           alf12=0.0D0
1496             xj=c(1,nres+j)-xi
1497             yj=c(2,nres+j)-yi
1498             zj=c(3,nres+j)-zi
1499             dxj=dc_norm(1,nres+j)
1500             dyj=dc_norm(2,nres+j)
1501             dzj=dc_norm(3,nres+j)
1502             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1503             rij=dsqrt(rrij)
1504 ! Calculate angle-dependent terms of energy and contributions to their
1505 ! derivatives.
1506             call sc_angular
1507             sigsq=1.0D0/sigsq
1508             sig=sig0ij*dsqrt(sigsq)
1509             rij_shift=1.0D0/rij-sig+r0ij
1510 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1511             if (rij_shift.le.0.0D0) then
1512               evdw=1.0D20
1513               return
1514             endif
1515             sigder=-sig*sigsq
1516 !---------------------------------------------------------------
1517             rij_shift=1.0D0/rij_shift
1518             fac=rij_shift**expon
1519             e1=fac*fac*aa(itypi,itypj)
1520             e2=fac*bb(itypi,itypj)
1521             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1522             eps2der=evdwij*eps3rt
1523             eps3der=evdwij*eps2rt
1524             fac_augm=rrij**expon
1525             e_augm=augm(itypi,itypj)*fac_augm
1526             evdwij=evdwij*eps2rt*eps3rt
1527             evdw=evdw+evdwij+e_augm
1528             if (lprn) then
1529             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1530             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1531             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1532               restyp(itypi),i,restyp(itypj),j,&
1533               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1534               chi1,chi2,chip1,chip2,&
1535               eps1,eps2rt**2,eps3rt**2,&
1536               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1537               evdwij+e_augm
1538             endif
1539 ! Calculate gradient components.
1540             e1=e1*eps1*eps2rt**2*eps3rt**2
1541             fac=-expon*(e1+evdwij)*rij_shift
1542             sigder=fac*sigder
1543             fac=rij*fac-2*expon*rrij*e_augm
1544 ! Calculate the radial part of the gradient
1545             gg(1)=xj*fac
1546             gg(2)=yj*fac
1547             gg(3)=zj*fac
1548 ! Calculate angular part of the gradient.
1549             call sc_grad
1550           enddo      ! j
1551         enddo        ! iint
1552       enddo          ! i
1553       end subroutine egbv
1554 !-----------------------------------------------------------------------------
1555 !el      subroutine sc_angular in module geometry
1556 !-----------------------------------------------------------------------------
1557       subroutine e_softsphere(evdw)
1558 !
1559 ! This subroutine calculates the interaction energy of nonbonded side chains
1560 ! assuming the LJ potential of interaction.
1561 !
1562 !      implicit real*8 (a-h,o-z)
1563 !      include 'DIMENSIONS'
1564       real(kind=8),parameter :: accur=1.0d-10
1565 !      include 'COMMON.GEO'
1566 !      include 'COMMON.VAR'
1567 !      include 'COMMON.LOCAL'
1568 !      include 'COMMON.CHAIN'
1569 !      include 'COMMON.DERIV'
1570 !      include 'COMMON.INTERACT'
1571 !      include 'COMMON.TORSION'
1572 !      include 'COMMON.SBRIDGE'
1573 !      include 'COMMON.NAMES'
1574 !      include 'COMMON.IOUNITS'
1575 !      include 'COMMON.CONTACTS'
1576       real(kind=8),dimension(3) :: gg
1577 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1578 !el local variables
1579       integer :: i,iint,j,itypi,itypi1,itypj,k
1580       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1581       real(kind=8) :: fac
1582
1583       evdw=0.0D0
1584       do i=iatsc_s,iatsc_e
1585         itypi=iabs(itype(i))
1586         if (itypi.eq.ntyp1) cycle
1587         itypi1=iabs(itype(i+1))
1588         xi=c(1,nres+i)
1589         yi=c(2,nres+i)
1590         zi=c(3,nres+i)
1591 !
1592 ! Calculate SC interaction energy.
1593 !
1594         do iint=1,nint_gr(i)
1595 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1596 !d   &                  'iend=',iend(i,iint)
1597           do j=istart(i,iint),iend(i,iint)
1598             itypj=iabs(itype(j))
1599             if (itypj.eq.ntyp1) cycle
1600             xj=c(1,nres+j)-xi
1601             yj=c(2,nres+j)-yi
1602             zj=c(3,nres+j)-zi
1603             rij=xj*xj+yj*yj+zj*zj
1604 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1605             r0ij=r0(itypi,itypj)
1606             r0ijsq=r0ij*r0ij
1607 !            print *,i,j,r0ij,dsqrt(rij)
1608             if (rij.lt.r0ijsq) then
1609               evdwij=0.25d0*(rij-r0ijsq)**2
1610               fac=rij-r0ijsq
1611             else
1612               evdwij=0.0d0
1613               fac=0.0d0
1614             endif
1615             evdw=evdw+evdwij
1616 !
1617 ! Calculate the components of the gradient in DC and X
1618 !
1619             gg(1)=xj*fac
1620             gg(2)=yj*fac
1621             gg(3)=zj*fac
1622             do k=1,3
1623               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1624               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1625               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1626               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1627             enddo
1628 !grad            do k=i,j-1
1629 !grad              do l=1,3
1630 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1631 !grad              enddo
1632 !grad            enddo
1633           enddo ! j
1634         enddo ! iint
1635       enddo ! i
1636       return
1637       end subroutine e_softsphere
1638 !-----------------------------------------------------------------------------
1639       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1640 !
1641 ! Soft-sphere potential of p-p interaction
1642 !
1643 !      implicit real*8 (a-h,o-z)
1644 !      include 'DIMENSIONS'
1645 !      include 'COMMON.CONTROL'
1646 !      include 'COMMON.IOUNITS'
1647 !      include 'COMMON.GEO'
1648 !      include 'COMMON.VAR'
1649 !      include 'COMMON.LOCAL'
1650 !      include 'COMMON.CHAIN'
1651 !      include 'COMMON.DERIV'
1652 !      include 'COMMON.INTERACT'
1653 !      include 'COMMON.CONTACTS'
1654 !      include 'COMMON.TORSION'
1655 !      include 'COMMON.VECTORS'
1656 !      include 'COMMON.FFIELD'
1657       real(kind=8),dimension(3) :: ggg
1658 !d      write(iout,*) 'In EELEC_soft_sphere'
1659 !el local variables
1660       integer :: i,j,k,num_conti,iteli,itelj
1661       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1662       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1663       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1664
1665       ees=0.0D0
1666       evdw1=0.0D0
1667       eel_loc=0.0d0
1668       eello_turn3=0.0d0
1669       eello_turn4=0.0d0
1670 !el      ind=0
1671       do i=iatel_s,iatel_e
1672         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1673         dxi=dc(1,i)
1674         dyi=dc(2,i)
1675         dzi=dc(3,i)
1676         xmedi=c(1,i)+0.5d0*dxi
1677         ymedi=c(2,i)+0.5d0*dyi
1678         zmedi=c(3,i)+0.5d0*dzi
1679         num_conti=0
1680 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1681         do j=ielstart(i),ielend(i)
1682           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1683 !el          ind=ind+1
1684           iteli=itel(i)
1685           itelj=itel(j)
1686           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1687           r0ij=rpp(iteli,itelj)
1688           r0ijsq=r0ij*r0ij
1689           dxj=dc(1,j)
1690           dyj=dc(2,j)
1691           dzj=dc(3,j)
1692           xj=c(1,j)+0.5D0*dxj-xmedi
1693           yj=c(2,j)+0.5D0*dyj-ymedi
1694           zj=c(3,j)+0.5D0*dzj-zmedi
1695           rij=xj*xj+yj*yj+zj*zj
1696           if (rij.lt.r0ijsq) then
1697             evdw1ij=0.25d0*(rij-r0ijsq)**2
1698             fac=rij-r0ijsq
1699           else
1700             evdw1ij=0.0d0
1701             fac=0.0d0
1702           endif
1703           evdw1=evdw1+evdw1ij
1704 !
1705 ! Calculate contributions to the Cartesian gradient.
1706 !
1707           ggg(1)=fac*xj
1708           ggg(2)=fac*yj
1709           ggg(3)=fac*zj
1710           do k=1,3
1711             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1712             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1713           enddo
1714 !
1715 ! Loop over residues i+1 thru j-1.
1716 !
1717 !grad          do k=i+1,j-1
1718 !grad            do l=1,3
1719 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1720 !grad            enddo
1721 !grad          enddo
1722         enddo ! j
1723       enddo   ! i
1724 !grad      do i=nnt,nct-1
1725 !grad        do k=1,3
1726 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1727 !grad        enddo
1728 !grad        do j=i+1,nct-1
1729 !grad          do k=1,3
1730 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1731 !grad          enddo
1732 !grad        enddo
1733 !grad      enddo
1734       return
1735       end subroutine eelec_soft_sphere
1736 !-----------------------------------------------------------------------------
1737       subroutine vec_and_deriv
1738 !      implicit real*8 (a-h,o-z)
1739 !      include 'DIMENSIONS'
1740 #ifdef MPI
1741       include 'mpif.h'
1742 #endif
1743 !      include 'COMMON.IOUNITS'
1744 !      include 'COMMON.GEO'
1745 !      include 'COMMON.VAR'
1746 !      include 'COMMON.LOCAL'
1747 !      include 'COMMON.CHAIN'
1748 !      include 'COMMON.VECTORS'
1749 !      include 'COMMON.SETUP'
1750 !      include 'COMMON.TIME1'
1751       real(kind=8),dimension(3,3,2) :: uyder,uzder
1752       real(kind=8),dimension(2) :: vbld_inv_temp
1753 ! Compute the local reference systems. For reference system (i), the
1754 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1755 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1756 !el local variables
1757       integer :: i,j,k,l
1758       real(kind=8) :: facy,fac,costh
1759
1760 #ifdef PARVEC
1761       do i=ivec_start,ivec_end
1762 #else
1763       do i=1,nres-1
1764 #endif
1765           if (i.eq.nres-1) then
1766 ! Case of the last full residue
1767 ! Compute the Z-axis
1768             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1769             costh=dcos(pi-theta(nres))
1770             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1771             do k=1,3
1772               uz(k,i)=fac*uz(k,i)
1773             enddo
1774 ! Compute the derivatives of uz
1775             uzder(1,1,1)= 0.0d0
1776             uzder(2,1,1)=-dc_norm(3,i-1)
1777             uzder(3,1,1)= dc_norm(2,i-1)
1778             uzder(1,2,1)= dc_norm(3,i-1)
1779             uzder(2,2,1)= 0.0d0
1780             uzder(3,2,1)=-dc_norm(1,i-1)
1781             uzder(1,3,1)=-dc_norm(2,i-1)
1782             uzder(2,3,1)= dc_norm(1,i-1)
1783             uzder(3,3,1)= 0.0d0
1784             uzder(1,1,2)= 0.0d0
1785             uzder(2,1,2)= dc_norm(3,i)
1786             uzder(3,1,2)=-dc_norm(2,i)
1787             uzder(1,2,2)=-dc_norm(3,i)
1788             uzder(2,2,2)= 0.0d0
1789             uzder(3,2,2)= dc_norm(1,i)
1790             uzder(1,3,2)= dc_norm(2,i)
1791             uzder(2,3,2)=-dc_norm(1,i)
1792             uzder(3,3,2)= 0.0d0
1793 ! Compute the Y-axis
1794             facy=fac
1795             do k=1,3
1796               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1797             enddo
1798 ! Compute the derivatives of uy
1799             do j=1,3
1800               do k=1,3
1801                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1802                               -dc_norm(k,i)*dc_norm(j,i-1)
1803                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1804               enddo
1805               uyder(j,j,1)=uyder(j,j,1)-costh
1806               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1807             enddo
1808             do j=1,2
1809               do k=1,3
1810                 do l=1,3
1811                   uygrad(l,k,j,i)=uyder(l,k,j)
1812                   uzgrad(l,k,j,i)=uzder(l,k,j)
1813                 enddo
1814               enddo
1815             enddo
1816             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1817             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1818             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1819             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1820           else
1821 ! Other residues
1822 ! Compute the Z-axis
1823             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1824             costh=dcos(pi-theta(i+2))
1825             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1826             do k=1,3
1827               uz(k,i)=fac*uz(k,i)
1828             enddo
1829 ! Compute the derivatives of uz
1830             uzder(1,1,1)= 0.0d0
1831             uzder(2,1,1)=-dc_norm(3,i+1)
1832             uzder(3,1,1)= dc_norm(2,i+1)
1833             uzder(1,2,1)= dc_norm(3,i+1)
1834             uzder(2,2,1)= 0.0d0
1835             uzder(3,2,1)=-dc_norm(1,i+1)
1836             uzder(1,3,1)=-dc_norm(2,i+1)
1837             uzder(2,3,1)= dc_norm(1,i+1)
1838             uzder(3,3,1)= 0.0d0
1839             uzder(1,1,2)= 0.0d0
1840             uzder(2,1,2)= dc_norm(3,i)
1841             uzder(3,1,2)=-dc_norm(2,i)
1842             uzder(1,2,2)=-dc_norm(3,i)
1843             uzder(2,2,2)= 0.0d0
1844             uzder(3,2,2)= dc_norm(1,i)
1845             uzder(1,3,2)= dc_norm(2,i)
1846             uzder(2,3,2)=-dc_norm(1,i)
1847             uzder(3,3,2)= 0.0d0
1848 ! Compute the Y-axis
1849             facy=fac
1850             do k=1,3
1851               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1852             enddo
1853 ! Compute the derivatives of uy
1854             do j=1,3
1855               do k=1,3
1856                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1857                               -dc_norm(k,i)*dc_norm(j,i+1)
1858                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1859               enddo
1860               uyder(j,j,1)=uyder(j,j,1)-costh
1861               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1862             enddo
1863             do j=1,2
1864               do k=1,3
1865                 do l=1,3
1866                   uygrad(l,k,j,i)=uyder(l,k,j)
1867                   uzgrad(l,k,j,i)=uzder(l,k,j)
1868                 enddo
1869               enddo
1870             enddo
1871             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1872             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1873             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1874             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1875           endif
1876       enddo
1877       do i=1,nres-1
1878         vbld_inv_temp(1)=vbld_inv(i+1)
1879         if (i.lt.nres-1) then
1880           vbld_inv_temp(2)=vbld_inv(i+2)
1881           else
1882           vbld_inv_temp(2)=vbld_inv(i)
1883           endif
1884         do j=1,2
1885           do k=1,3
1886             do l=1,3
1887               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1888               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1889             enddo
1890           enddo
1891         enddo
1892       enddo
1893 #if defined(PARVEC) && defined(MPI)
1894       if (nfgtasks1.gt.1) then
1895         time00=MPI_Wtime()
1896 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1897 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1898 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1899         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1900          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1901          FG_COMM1,IERR)
1902         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1903          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1904          FG_COMM1,IERR)
1905         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1906          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1907          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1908         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1909          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1910          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1911         time_gather=time_gather+MPI_Wtime()-time00
1912       endif
1913 !      if (fg_rank.eq.0) then
1914 !        write (iout,*) "Arrays UY and UZ"
1915 !        do i=1,nres-1
1916 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1917 !     &     (uz(k,i),k=1,3)
1918 !        enddo
1919 !      endif
1920 #endif
1921       return
1922       end subroutine vec_and_deriv
1923 !-----------------------------------------------------------------------------
1924       subroutine check_vecgrad
1925 !      implicit real*8 (a-h,o-z)
1926 !      include 'DIMENSIONS'
1927 !      include 'COMMON.IOUNITS'
1928 !      include 'COMMON.GEO'
1929 !      include 'COMMON.VAR'
1930 !      include 'COMMON.LOCAL'
1931 !      include 'COMMON.CHAIN'
1932 !      include 'COMMON.VECTORS'
1933       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
1934       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
1935       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
1936       real(kind=8),dimension(3) :: erij
1937       real(kind=8) :: delta=1.0d-7
1938 !el local variables
1939       integer :: i,j,k,l
1940
1941       call vec_and_deriv
1942 !d      do i=1,nres
1943 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1944 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1945 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1946 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1947 !d     &     (dc_norm(if90,i),if90=1,3)
1948 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1949 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1950 !d          write(iout,'(a)')
1951 !d      enddo
1952       do i=1,nres
1953         do j=1,2
1954           do k=1,3
1955             do l=1,3
1956               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1957               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1958             enddo
1959           enddo
1960         enddo
1961       enddo
1962       call vec_and_deriv
1963       do i=1,nres
1964         do j=1,3
1965           uyt(j,i)=uy(j,i)
1966           uzt(j,i)=uz(j,i)
1967         enddo
1968       enddo
1969       do i=1,nres
1970 !d        write (iout,*) 'i=',i
1971         do k=1,3
1972           erij(k)=dc_norm(k,i)
1973         enddo
1974         do j=1,3
1975           do k=1,3
1976             dc_norm(k,i)=erij(k)
1977           enddo
1978           dc_norm(j,i)=dc_norm(j,i)+delta
1979 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1980 !          do k=1,3
1981 !            dc_norm(k,i)=dc_norm(k,i)/fac
1982 !          enddo
1983 !          write (iout,*) (dc_norm(k,i),k=1,3)
1984 !          write (iout,*) (erij(k),k=1,3)
1985           call vec_and_deriv
1986           do k=1,3
1987             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1988             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1989             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1990             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1991           enddo
1992 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1993 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1994 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1995         enddo
1996         do k=1,3
1997           dc_norm(k,i)=erij(k)
1998         enddo
1999 !d        do k=1,3
2000 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2001 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2002 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2003 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2004 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2005 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2006 !d          write (iout,'(a)')
2007 !d        enddo
2008       enddo
2009       return
2010       end subroutine check_vecgrad
2011 !-----------------------------------------------------------------------------
2012       subroutine set_matrices
2013 !      implicit real*8 (a-h,o-z)
2014 !      include 'DIMENSIONS'
2015 #ifdef MPI
2016       include "mpif.h"
2017 !      include "COMMON.SETUP"
2018       integer :: IERR
2019       integer :: status(MPI_STATUS_SIZE)
2020 #endif
2021 !      include 'COMMON.IOUNITS'
2022 !      include 'COMMON.GEO'
2023 !      include 'COMMON.VAR'
2024 !      include 'COMMON.LOCAL'
2025 !      include 'COMMON.CHAIN'
2026 !      include 'COMMON.DERIV'
2027 !      include 'COMMON.INTERACT'
2028 !      include 'COMMON.CONTACTS'
2029 !      include 'COMMON.TORSION'
2030 !      include 'COMMON.VECTORS'
2031 !      include 'COMMON.FFIELD'
2032       real(kind=8) :: auxvec(2),auxmat(2,2)
2033       integer :: i,iti1,iti,k,l
2034       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2035
2036 !
2037 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2038 ! to calculate the el-loc multibody terms of various order.
2039 !
2040 !AL el      mu=0.0d0
2041 #ifdef PARMAT
2042       do i=ivec_start+2,ivec_end+2
2043 #else
2044       do i=3,nres+1
2045 #endif
2046         if (i .lt. nres+1) then
2047           sin1=dsin(phi(i))
2048           cos1=dcos(phi(i))
2049           sintab(i-2)=sin1
2050           costab(i-2)=cos1
2051           obrot(1,i-2)=cos1
2052           obrot(2,i-2)=sin1
2053           sin2=dsin(2*phi(i))
2054           cos2=dcos(2*phi(i))
2055           sintab2(i-2)=sin2
2056           costab2(i-2)=cos2
2057           obrot2(1,i-2)=cos2
2058           obrot2(2,i-2)=sin2
2059           Ug(1,1,i-2)=-cos1
2060           Ug(1,2,i-2)=-sin1
2061           Ug(2,1,i-2)=-sin1
2062           Ug(2,2,i-2)= cos1
2063           Ug2(1,1,i-2)=-cos2
2064           Ug2(1,2,i-2)=-sin2
2065           Ug2(2,1,i-2)=-sin2
2066           Ug2(2,2,i-2)= cos2
2067         else
2068           costab(i-2)=1.0d0
2069           sintab(i-2)=0.0d0
2070           obrot(1,i-2)=1.0d0
2071           obrot(2,i-2)=0.0d0
2072           obrot2(1,i-2)=0.0d0
2073           obrot2(2,i-2)=0.0d0
2074           Ug(1,1,i-2)=1.0d0
2075           Ug(1,2,i-2)=0.0d0
2076           Ug(2,1,i-2)=0.0d0
2077           Ug(2,2,i-2)=1.0d0
2078           Ug2(1,1,i-2)=0.0d0
2079           Ug2(1,2,i-2)=0.0d0
2080           Ug2(2,1,i-2)=0.0d0
2081           Ug2(2,2,i-2)=0.0d0
2082         endif
2083         if (i .gt. 3 .and. i .lt. nres+1) then
2084           obrot_der(1,i-2)=-sin1
2085           obrot_der(2,i-2)= cos1
2086           Ugder(1,1,i-2)= sin1
2087           Ugder(1,2,i-2)=-cos1
2088           Ugder(2,1,i-2)=-cos1
2089           Ugder(2,2,i-2)=-sin1
2090           dwacos2=cos2+cos2
2091           dwasin2=sin2+sin2
2092           obrot2_der(1,i-2)=-dwasin2
2093           obrot2_der(2,i-2)= dwacos2
2094           Ug2der(1,1,i-2)= dwasin2
2095           Ug2der(1,2,i-2)=-dwacos2
2096           Ug2der(2,1,i-2)=-dwacos2
2097           Ug2der(2,2,i-2)=-dwasin2
2098         else
2099           obrot_der(1,i-2)=0.0d0
2100           obrot_der(2,i-2)=0.0d0
2101           Ugder(1,1,i-2)=0.0d0
2102           Ugder(1,2,i-2)=0.0d0
2103           Ugder(2,1,i-2)=0.0d0
2104           Ugder(2,2,i-2)=0.0d0
2105           obrot2_der(1,i-2)=0.0d0
2106           obrot2_der(2,i-2)=0.0d0
2107           Ug2der(1,1,i-2)=0.0d0
2108           Ug2der(1,2,i-2)=0.0d0
2109           Ug2der(2,1,i-2)=0.0d0
2110           Ug2der(2,2,i-2)=0.0d0
2111         endif
2112 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2113         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2114           iti = itortyp(itype(i-2))
2115         else
2116           iti=ntortyp+1
2117         endif
2118 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2119         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2120           iti1 = itortyp(itype(i-1))
2121         else
2122           iti1=ntortyp+1
2123         endif
2124 !d        write (iout,*) '*******i',i,' iti1',iti
2125 !d        write (iout,*) 'b1',b1(:,iti)
2126 !d        write (iout,*) 'b2',b2(:,iti)
2127 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2128 !        if (i .gt. iatel_s+2) then
2129         if (i .gt. nnt+2) then
2130           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2131           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2132           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2133           then
2134           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2135           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2136           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2137           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2138           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2139           endif
2140         else
2141           do k=1,2
2142             Ub2(k,i-2)=0.0d0
2143             Ctobr(k,i-2)=0.0d0
2144             Dtobr2(k,i-2)=0.0d0
2145             do l=1,2
2146               EUg(l,k,i-2)=0.0d0
2147               CUg(l,k,i-2)=0.0d0
2148               DUg(l,k,i-2)=0.0d0
2149               DtUg2(l,k,i-2)=0.0d0
2150             enddo
2151           enddo
2152         endif
2153         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2154         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2155         do k=1,2
2156           muder(k,i-2)=Ub2der(k,i-2)
2157         enddo
2158 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2159         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2160           if (itype(i-1).le.ntyp) then
2161             iti1 = itortyp(itype(i-1))
2162           else
2163             iti1=ntortyp+1
2164           endif
2165         else
2166           iti1=ntortyp+1
2167         endif
2168         do k=1,2
2169           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2170         enddo
2171 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2172 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2173 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2174 !d        write (iout,*) 'mu1',mu1(:,i-2)
2175 !d        write (iout,*) 'mu2',mu2(:,i-2)
2176         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2177         then
2178         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2179         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2180         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2181         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2182         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2183 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2184         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2185         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2186         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2187         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2188         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2189         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2190         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2191         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2192         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2193         endif
2194       enddo
2195 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2196 ! The order of matrices is from left to right.
2197       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2198       then
2199 !      do i=max0(ivec_start,2),ivec_end
2200       do i=2,nres-1
2201         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2202         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2203         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2204         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2205         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2206         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2207         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2208         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2209       enddo
2210       endif
2211 #if defined(MPI) && defined(PARMAT)
2212 #ifdef DEBUG
2213 !      if (fg_rank.eq.0) then
2214         write (iout,*) "Arrays UG and UGDER before GATHER"
2215         do i=1,nres-1
2216           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2217            ((ug(l,k,i),l=1,2),k=1,2),&
2218            ((ugder(l,k,i),l=1,2),k=1,2)
2219         enddo
2220         write (iout,*) "Arrays UG2 and UG2DER"
2221         do i=1,nres-1
2222           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2223            ((ug2(l,k,i),l=1,2),k=1,2),&
2224            ((ug2der(l,k,i),l=1,2),k=1,2)
2225         enddo
2226         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2227         do i=1,nres-1
2228           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2229            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2230            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2231         enddo
2232         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2233         do i=1,nres-1
2234           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2235            costab(i),sintab(i),costab2(i),sintab2(i)
2236         enddo
2237         write (iout,*) "Array MUDER"
2238         do i=1,nres-1
2239           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2240         enddo
2241 !      endif
2242 #endif
2243       if (nfgtasks.gt.1) then
2244         time00=MPI_Wtime()
2245 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2246 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2247 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2248 #ifdef MATGATHER
2249         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2250          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2251          FG_COMM1,IERR)
2252         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2253          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2254          FG_COMM1,IERR)
2255         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2256          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2257          FG_COMM1,IERR)
2258         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2259          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2260          FG_COMM1,IERR)
2261         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2262          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2263          FG_COMM1,IERR)
2264         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2265          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2266          FG_COMM1,IERR)
2267         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2268          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2269          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2270         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2271          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2272          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2273         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2274          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2275          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2276         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2277          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2278          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2279         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2280         then
2281         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2282          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2283          FG_COMM1,IERR)
2284         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2285          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2286          FG_COMM1,IERR)
2287         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2288          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2289          FG_COMM1,IERR)
2290        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2291          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2292          FG_COMM1,IERR)
2293         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2294          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2295          FG_COMM1,IERR)
2296         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2297          ivec_count(fg_rank1),&
2298          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2299          FG_COMM1,IERR)
2300         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2301          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2302          FG_COMM1,IERR)
2303         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2304          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2305          FG_COMM1,IERR)
2306         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2307          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2308          FG_COMM1,IERR)
2309         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2310          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2311          FG_COMM1,IERR)
2312         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2313          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2314          FG_COMM1,IERR)
2315         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2316          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2317          FG_COMM1,IERR)
2318         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2319          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2320          FG_COMM1,IERR)
2321         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2322          ivec_count(fg_rank1),&
2323          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2324          FG_COMM1,IERR)
2325         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2326          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2327          FG_COMM1,IERR)
2328        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2329          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2330          FG_COMM1,IERR)
2331         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2332          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2333          FG_COMM1,IERR)
2334        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2335          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2336          FG_COMM1,IERR)
2337         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2338          ivec_count(fg_rank1),&
2339          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2340          FG_COMM1,IERR)
2341         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2342          ivec_count(fg_rank1),&
2343          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2344          FG_COMM1,IERR)
2345         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2346          ivec_count(fg_rank1),&
2347          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2348          MPI_MAT2,FG_COMM1,IERR)
2349         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2350          ivec_count(fg_rank1),&
2351          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2352          MPI_MAT2,FG_COMM1,IERR)
2353         endif
2354 #else
2355 ! Passes matrix info through the ring
2356       isend=fg_rank1
2357       irecv=fg_rank1-1
2358       if (irecv.lt.0) irecv=nfgtasks1-1
2359       iprev=irecv
2360       inext=fg_rank1+1
2361       if (inext.ge.nfgtasks1) inext=0
2362       do i=1,nfgtasks1-1
2363 !        write (iout,*) "isend",isend," irecv",irecv
2364 !        call flush(iout)
2365         lensend=lentyp(isend)
2366         lenrecv=lentyp(irecv)
2367 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2368 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2369 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2370 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2371 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2372 !        write (iout,*) "Gather ROTAT1"
2373 !        call flush(iout)
2374 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2375 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2376 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2377 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2378 !        write (iout,*) "Gather ROTAT2"
2379 !        call flush(iout)
2380         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2381          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2382          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2383          iprev,4400+irecv,FG_COMM,status,IERR)
2384 !        write (iout,*) "Gather ROTAT_OLD"
2385 !        call flush(iout)
2386         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2387          MPI_PRECOMP11(lensend),inext,5500+isend,&
2388          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2389          iprev,5500+irecv,FG_COMM,status,IERR)
2390 !        write (iout,*) "Gather PRECOMP11"
2391 !        call flush(iout)
2392         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2393          MPI_PRECOMP12(lensend),inext,6600+isend,&
2394          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2395          iprev,6600+irecv,FG_COMM,status,IERR)
2396 !        write (iout,*) "Gather PRECOMP12"
2397 !        call flush(iout)
2398         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2399         then
2400         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2401          MPI_ROTAT2(lensend),inext,7700+isend,&
2402          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2403          iprev,7700+irecv,FG_COMM,status,IERR)
2404 !        write (iout,*) "Gather PRECOMP21"
2405 !        call flush(iout)
2406         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2407          MPI_PRECOMP22(lensend),inext,8800+isend,&
2408          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2409          iprev,8800+irecv,FG_COMM,status,IERR)
2410 !        write (iout,*) "Gather PRECOMP22"
2411 !        call flush(iout)
2412         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2413          MPI_PRECOMP23(lensend),inext,9900+isend,&
2414          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2415          MPI_PRECOMP23(lenrecv),&
2416          iprev,9900+irecv,FG_COMM,status,IERR)
2417 !        write (iout,*) "Gather PRECOMP23"
2418 !        call flush(iout)
2419         endif
2420         isend=irecv
2421         irecv=irecv-1
2422         if (irecv.lt.0) irecv=nfgtasks1-1
2423       enddo
2424 #endif
2425         time_gather=time_gather+MPI_Wtime()-time00
2426       endif
2427 #ifdef DEBUG
2428 !      if (fg_rank.eq.0) then
2429         write (iout,*) "Arrays UG and UGDER"
2430         do i=1,nres-1
2431           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2432            ((ug(l,k,i),l=1,2),k=1,2),&
2433            ((ugder(l,k,i),l=1,2),k=1,2)
2434         enddo
2435         write (iout,*) "Arrays UG2 and UG2DER"
2436         do i=1,nres-1
2437           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2438            ((ug2(l,k,i),l=1,2),k=1,2),&
2439            ((ug2der(l,k,i),l=1,2),k=1,2)
2440         enddo
2441         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2442         do i=1,nres-1
2443           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2444            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2445            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2446         enddo
2447         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2448         do i=1,nres-1
2449           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2450            costab(i),sintab(i),costab2(i),sintab2(i)
2451         enddo
2452         write (iout,*) "Array MUDER"
2453         do i=1,nres-1
2454           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2455         enddo
2456 !      endif
2457 #endif
2458 #endif
2459 !d      do i=1,nres
2460 !d        iti = itortyp(itype(i))
2461 !d        write (iout,*) i
2462 !d        do j=1,2
2463 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2464 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2465 !d        enddo
2466 !d      enddo
2467       return
2468       end subroutine set_matrices
2469 !-----------------------------------------------------------------------------
2470       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2471 !
2472 ! This subroutine calculates the average interaction energy and its gradient
2473 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2474 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2475 ! The potential depends both on the distance of peptide-group centers and on
2476 ! the orientation of the CA-CA virtual bonds.
2477 !
2478       use comm_locel
2479 !      implicit real*8 (a-h,o-z)
2480 #ifdef MPI
2481       include 'mpif.h'
2482 #endif
2483 !      include 'DIMENSIONS'
2484 !      include 'COMMON.CONTROL'
2485 !      include 'COMMON.SETUP'
2486 !      include 'COMMON.IOUNITS'
2487 !      include 'COMMON.GEO'
2488 !      include 'COMMON.VAR'
2489 !      include 'COMMON.LOCAL'
2490 !      include 'COMMON.CHAIN'
2491 !      include 'COMMON.DERIV'
2492 !      include 'COMMON.INTERACT'
2493 !      include 'COMMON.CONTACTS'
2494 !      include 'COMMON.TORSION'
2495 !      include 'COMMON.VECTORS'
2496 !      include 'COMMON.FFIELD'
2497 !      include 'COMMON.TIME1'
2498       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2499       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2500       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2501 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2502       real(kind=8),dimension(4) :: muij
2503 !el      integer :: num_conti,j1,j2
2504 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2505 !el        dz_normi,xmedi,ymedi,zmedi
2506
2507 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2508 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2509 !el          num_conti,j1,j2
2510
2511 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2512 #ifdef MOMENT
2513       real(kind=8) :: scal_el=1.0d0
2514 #else
2515       real(kind=8) :: scal_el=0.5d0
2516 #endif
2517 ! 12/13/98
2518 ! 13-go grudnia roku pamietnego...
2519       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2520                                              0.0d0,1.0d0,0.0d0,&
2521                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2522 !el local variables
2523       integer :: i,k,j
2524       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2525       real(kind=8) :: fac,t_eelecij
2526
2527
2528 !d      write(iout,*) 'In EELEC'
2529 !d      do i=1,nloctyp
2530 !d        write(iout,*) 'Type',i
2531 !d        write(iout,*) 'B1',B1(:,i)
2532 !d        write(iout,*) 'B2',B2(:,i)
2533 !d        write(iout,*) 'CC',CC(:,:,i)
2534 !d        write(iout,*) 'DD',DD(:,:,i)
2535 !d        write(iout,*) 'EE',EE(:,:,i)
2536 !d      enddo
2537 !d      call check_vecgrad
2538 !d      stop
2539 !      ees=0.0d0  !AS
2540 !      evdw1=0.0d0
2541 !      eel_loc=0.0d0
2542 !      eello_turn3=0.0d0
2543 !      eello_turn4=0.0d0
2544       t_eelecij=0.0d0
2545       ees=0.0D0
2546       evdw1=0.0D0
2547       eel_loc=0.0d0
2548       eello_turn3=0.0d0
2549       eello_turn4=0.0d0
2550 !
2551
2552       if (icheckgrad.eq.1) then
2553 !el
2554 !        do i=0,2*nres+2
2555 !          dc_norm(1,i)=0.0d0
2556 !          dc_norm(2,i)=0.0d0
2557 !          dc_norm(3,i)=0.0d0
2558 !        enddo
2559         do i=1,nres-1
2560           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2561           do k=1,3
2562             dc_norm(k,i)=dc(k,i)*fac
2563           enddo
2564 !          write (iout,*) 'i',i,' fac',fac
2565         enddo
2566       endif
2567       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2568           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2569           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2570 !        call vec_and_deriv
2571 #ifdef TIMING
2572         time01=MPI_Wtime()
2573 #endif
2574         call set_matrices
2575 #ifdef TIMING
2576         time_mat=time_mat+MPI_Wtime()-time01
2577 #endif
2578       endif
2579 !d      do i=1,nres-1
2580 !d        write (iout,*) 'i=',i
2581 !d        do k=1,3
2582 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2583 !d        enddo
2584 !d        do k=1,3
2585 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2586 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2587 !d        enddo
2588 !d      enddo
2589       t_eelecij=0.0d0
2590       ees=0.0D0
2591       evdw1=0.0D0
2592       eel_loc=0.0d0
2593       eello_turn3=0.0d0
2594       eello_turn4=0.0d0
2595 !el      ind=0
2596       do i=1,nres
2597         num_cont_hb(i)=0
2598       enddo
2599 !d      print '(a)','Enter EELEC'
2600 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2601 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2602 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2603       do i=1,nres
2604         gel_loc_loc(i)=0.0d0
2605         gcorr_loc(i)=0.0d0
2606       enddo
2607 !
2608 !
2609 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2610 !
2611 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2612 !
2613
2614
2615
2616       do i=iturn3_start,iturn3_end
2617         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2618         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2619         dxi=dc(1,i)
2620         dyi=dc(2,i)
2621         dzi=dc(3,i)
2622         dx_normi=dc_norm(1,i)
2623         dy_normi=dc_norm(2,i)
2624         dz_normi=dc_norm(3,i)
2625         xmedi=c(1,i)+0.5d0*dxi
2626         ymedi=c(2,i)+0.5d0*dyi
2627         zmedi=c(3,i)+0.5d0*dzi
2628         num_conti=0
2629         call eelecij(i,i+2,ees,evdw1,eel_loc)
2630         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2631         num_cont_hb(i)=num_conti
2632       enddo
2633       do i=iturn4_start,iturn4_end
2634         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2635           .or. itype(i+3).eq.ntyp1 &
2636           .or. itype(i+4).eq.ntyp1) cycle
2637         dxi=dc(1,i)
2638         dyi=dc(2,i)
2639         dzi=dc(3,i)
2640         dx_normi=dc_norm(1,i)
2641         dy_normi=dc_norm(2,i)
2642         dz_normi=dc_norm(3,i)
2643         xmedi=c(1,i)+0.5d0*dxi
2644         ymedi=c(2,i)+0.5d0*dyi
2645         zmedi=c(3,i)+0.5d0*dzi
2646         num_conti=num_cont_hb(i)
2647         call eelecij(i,i+3,ees,evdw1,eel_loc)
2648         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2649          call eturn4(i,eello_turn4)
2650         num_cont_hb(i)=num_conti
2651       enddo   ! i
2652 !
2653 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2654 !
2655       do i=iatel_s,iatel_e
2656         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2657         dxi=dc(1,i)
2658         dyi=dc(2,i)
2659         dzi=dc(3,i)
2660         dx_normi=dc_norm(1,i)
2661         dy_normi=dc_norm(2,i)
2662         dz_normi=dc_norm(3,i)
2663         xmedi=c(1,i)+0.5d0*dxi
2664         ymedi=c(2,i)+0.5d0*dyi
2665         zmedi=c(3,i)+0.5d0*dzi
2666 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2667         num_conti=num_cont_hb(i)
2668         do j=ielstart(i),ielend(i)
2669 !          write (iout,*) i,j,itype(i),itype(j)
2670           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2671           call eelecij(i,j,ees,evdw1,eel_loc)
2672         enddo ! j
2673         num_cont_hb(i)=num_conti
2674       enddo   ! i
2675 !      write (iout,*) "Number of loop steps in EELEC:",ind
2676 !d      do i=1,nres
2677 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2678 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2679 !d      enddo
2680 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2681 !cc      eel_loc=eel_loc+eello_turn3
2682 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2683       return
2684       end subroutine eelec
2685 !-----------------------------------------------------------------------------
2686       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2687
2688       use comm_locel
2689 !      implicit real*8 (a-h,o-z)
2690 !      include 'DIMENSIONS'
2691 #ifdef MPI
2692       include "mpif.h"
2693 #endif
2694 !      include 'COMMON.CONTROL'
2695 !      include 'COMMON.IOUNITS'
2696 !      include 'COMMON.GEO'
2697 !      include 'COMMON.VAR'
2698 !      include 'COMMON.LOCAL'
2699 !      include 'COMMON.CHAIN'
2700 !      include 'COMMON.DERIV'
2701 !      include 'COMMON.INTERACT'
2702 !      include 'COMMON.CONTACTS'
2703 !      include 'COMMON.TORSION'
2704 !      include 'COMMON.VECTORS'
2705 !      include 'COMMON.FFIELD'
2706 !      include 'COMMON.TIME1'
2707       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2708       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2709       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2710 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2711       real(kind=8),dimension(4) :: muij
2712 !el      integer :: num_conti,j1,j2
2713 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2714 !el        dz_normi,xmedi,ymedi,zmedi
2715
2716 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2717 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2718 !el          num_conti,j1,j2
2719
2720 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2721 #ifdef MOMENT
2722       real(kind=8) :: scal_el=1.0d0
2723 #else
2724       real(kind=8) :: scal_el=0.5d0
2725 #endif
2726 ! 12/13/98
2727 ! 13-go grudnia roku pamietnego...
2728       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2729                                              0.0d0,1.0d0,0.0d0,&
2730                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2731 !      integer :: maxconts=nres/4
2732 !el local variables
2733       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
2734       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2735       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2736       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2737                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2738                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2739                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2740                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2741                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2742                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2743                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2744 !      maxconts=nres/4
2745 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2746 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2747
2748 !          time00=MPI_Wtime()
2749 !d      write (iout,*) "eelecij",i,j
2750 !          ind=ind+1
2751           iteli=itel(i)
2752           itelj=itel(j)
2753           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2754           aaa=app(iteli,itelj)
2755           bbb=bpp(iteli,itelj)
2756           ael6i=ael6(iteli,itelj)
2757           ael3i=ael3(iteli,itelj)
2758           dxj=dc(1,j)
2759           dyj=dc(2,j)
2760           dzj=dc(3,j)
2761           dx_normj=dc_norm(1,j)
2762           dy_normj=dc_norm(2,j)
2763           dz_normj=dc_norm(3,j)
2764           xj=c(1,j)+0.5D0*dxj-xmedi
2765           yj=c(2,j)+0.5D0*dyj-ymedi
2766           zj=c(3,j)+0.5D0*dzj-zmedi
2767           rij=xj*xj+yj*yj+zj*zj
2768           rrmij=1.0D0/rij
2769           rij=dsqrt(rij)
2770           rmij=1.0D0/rij
2771           r3ij=rrmij*rmij
2772           r6ij=r3ij*r3ij
2773           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2774           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2775           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2776           fac=cosa-3.0D0*cosb*cosg
2777           ev1=aaa*r6ij*r6ij
2778 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2779           if (j.eq.i+2) ev1=scal_el*ev1
2780           ev2=bbb*r6ij
2781           fac3=ael6i*r6ij
2782           fac4=ael3i*r3ij
2783           evdwij=ev1+ev2
2784           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2785           el2=fac4*fac
2786           eesij=el1+el2
2787 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2788           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2789           ees=ees+eesij
2790           evdw1=evdw1+evdwij
2791 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2792 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2793 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2794 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2795
2796           if (energy_dec) then
2797               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2798                   'evdw1',i,j,evdwij,&
2799                   iteli,itelj,aaa,evdw1
2800               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2801           endif
2802 !
2803 ! Calculate contributions to the Cartesian gradient.
2804 !
2805 #ifdef SPLITELE
2806           facvdw=-6*rrmij*(ev1+evdwij)
2807           facel=-3*rrmij*(el1+eesij)
2808           fac1=fac
2809           erij(1)=xj*rmij
2810           erij(2)=yj*rmij
2811           erij(3)=zj*rmij
2812 !
2813 ! Radial derivatives. First process both termini of the fragment (i,j)
2814 !
2815           ggg(1)=facel*xj
2816           ggg(2)=facel*yj
2817           ggg(3)=facel*zj
2818 !          do k=1,3
2819 !            ghalf=0.5D0*ggg(k)
2820 !            gelc(k,i)=gelc(k,i)+ghalf
2821 !            gelc(k,j)=gelc(k,j)+ghalf
2822 !          enddo
2823 ! 9/28/08 AL Gradient compotents will be summed only at the end
2824           do k=1,3
2825             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2826             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2827           enddo
2828 !
2829 ! Loop over residues i+1 thru j-1.
2830 !
2831 !grad          do k=i+1,j-1
2832 !grad            do l=1,3
2833 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2834 !grad            enddo
2835 !grad          enddo
2836           ggg(1)=facvdw*xj
2837           ggg(2)=facvdw*yj
2838           ggg(3)=facvdw*zj
2839 !          do k=1,3
2840 !            ghalf=0.5D0*ggg(k)
2841 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2842 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2843 !          enddo
2844 ! 9/28/08 AL Gradient compotents will be summed only at the end
2845           do k=1,3
2846             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2847             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2848           enddo
2849 !
2850 ! Loop over residues i+1 thru j-1.
2851 !
2852 !grad          do k=i+1,j-1
2853 !grad            do l=1,3
2854 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2855 !grad            enddo
2856 !grad          enddo
2857 #else
2858           facvdw=ev1+evdwij
2859           facel=el1+eesij
2860           fac1=fac
2861           fac=-3*rrmij*(facvdw+facvdw+facel)
2862           erij(1)=xj*rmij
2863           erij(2)=yj*rmij
2864           erij(3)=zj*rmij
2865 !
2866 ! Radial derivatives. First process both termini of the fragment (i,j)
2867 !
2868           ggg(1)=fac*xj
2869           ggg(2)=fac*yj
2870           ggg(3)=fac*zj
2871 !          do k=1,3
2872 !            ghalf=0.5D0*ggg(k)
2873 !            gelc(k,i)=gelc(k,i)+ghalf
2874 !            gelc(k,j)=gelc(k,j)+ghalf
2875 !          enddo
2876 ! 9/28/08 AL Gradient compotents will be summed only at the end
2877           do k=1,3
2878             gelc_long(k,j)=gelc(k,j)+ggg(k)
2879             gelc_long(k,i)=gelc(k,i)-ggg(k)
2880           enddo
2881 !
2882 ! Loop over residues i+1 thru j-1.
2883 !
2884 !grad          do k=i+1,j-1
2885 !grad            do l=1,3
2886 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2887 !grad            enddo
2888 !grad          enddo
2889 ! 9/28/08 AL Gradient compotents will be summed only at the end
2890           ggg(1)=facvdw*xj
2891           ggg(2)=facvdw*yj
2892           ggg(3)=facvdw*zj
2893           do k=1,3
2894             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2895             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2896           enddo
2897 #endif
2898 !
2899 ! Angular part
2900 !
2901           ecosa=2.0D0*fac3*fac1+fac4
2902           fac4=-3.0D0*fac4
2903           fac3=-6.0D0*fac3
2904           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2905           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2906           do k=1,3
2907             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2908             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2909           enddo
2910 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2911 !d   &          (dcosg(k),k=1,3)
2912           do k=1,3
2913             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2914           enddo
2915 !          do k=1,3
2916 !            ghalf=0.5D0*ggg(k)
2917 !            gelc(k,i)=gelc(k,i)+ghalf
2918 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2919 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2920 !            gelc(k,j)=gelc(k,j)+ghalf
2921 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2922 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2923 !          enddo
2924 !grad          do k=i+1,j-1
2925 !grad            do l=1,3
2926 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2927 !grad            enddo
2928 !grad          enddo
2929           do k=1,3
2930             gelc(k,i)=gelc(k,i) &
2931                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2932                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2933             gelc(k,j)=gelc(k,j) &
2934                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
2935                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2936             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2937             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2938           enddo
2939           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2940               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
2941               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2942 !
2943 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2944 !   energy of a peptide unit is assumed in the form of a second-order
2945 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2946 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2947 !   are computed for EVERY pair of non-contiguous peptide groups.
2948 !
2949           if (j.lt.nres-1) then
2950             j1=j+1
2951             j2=j-1
2952           else
2953             j1=j-1
2954             j2=j-2
2955           endif
2956           kkk=0
2957           do k=1,2
2958             do l=1,2
2959               kkk=kkk+1
2960               muij(kkk)=mu(k,i)*mu(l,j)
2961             enddo
2962           enddo
2963 !d         write (iout,*) 'EELEC: i',i,' j',j
2964 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
2965 !d          write(iout,*) 'muij',muij
2966           ury=scalar(uy(1,i),erij)
2967           urz=scalar(uz(1,i),erij)
2968           vry=scalar(uy(1,j),erij)
2969           vrz=scalar(uz(1,j),erij)
2970           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2971           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2972           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2973           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2974           fac=dsqrt(-ael6i)*r3ij
2975           a22=a22*fac
2976           a23=a23*fac
2977           a32=a32*fac
2978           a33=a33*fac
2979 !d          write (iout,'(4i5,4f10.5)')
2980 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2981 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2982 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2983 !d     &      uy(:,j),uz(:,j)
2984 !d          write (iout,'(4f10.5)')
2985 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2986 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2987 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
2988 !d           write (iout,'(9f10.5/)')
2989 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2990 ! Derivatives of the elements of A in virtual-bond vectors
2991           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2992           do k=1,3
2993             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2994             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2995             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2996             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2997             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2998             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2999             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3000             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3001             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3002             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3003             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3004             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3005           enddo
3006 ! Compute radial contributions to the gradient
3007           facr=-3.0d0*rrmij
3008           a22der=a22*facr
3009           a23der=a23*facr
3010           a32der=a32*facr
3011           a33der=a33*facr
3012           agg(1,1)=a22der*xj
3013           agg(2,1)=a22der*yj
3014           agg(3,1)=a22der*zj
3015           agg(1,2)=a23der*xj
3016           agg(2,2)=a23der*yj
3017           agg(3,2)=a23der*zj
3018           agg(1,3)=a32der*xj
3019           agg(2,3)=a32der*yj
3020           agg(3,3)=a32der*zj
3021           agg(1,4)=a33der*xj
3022           agg(2,4)=a33der*yj
3023           agg(3,4)=a33der*zj
3024 ! Add the contributions coming from er
3025           fac3=-3.0d0*fac
3026           do k=1,3
3027             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3028             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3029             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3030             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3031           enddo
3032           do k=1,3
3033 ! Derivatives in DC(i)
3034 !grad            ghalf1=0.5d0*agg(k,1)
3035 !grad            ghalf2=0.5d0*agg(k,2)
3036 !grad            ghalf3=0.5d0*agg(k,3)
3037 !grad            ghalf4=0.5d0*agg(k,4)
3038             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3039             -3.0d0*uryg(k,2)*vry)!+ghalf1
3040             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3041             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3042             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3043             -3.0d0*urzg(k,2)*vry)!+ghalf3
3044             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3045             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3046 ! Derivatives in DC(i+1)
3047             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3048             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3049             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3050             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3051             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3052             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3053             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3054             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3055 ! Derivatives in DC(j)
3056             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3057             -3.0d0*vryg(k,2)*ury)!+ghalf1
3058             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3059             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3060             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3061             -3.0d0*vryg(k,2)*urz)!+ghalf3
3062             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3063             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3064 ! Derivatives in DC(j+1) or DC(nres-1)
3065             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3066             -3.0d0*vryg(k,3)*ury)
3067             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3068             -3.0d0*vrzg(k,3)*ury)
3069             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3070             -3.0d0*vryg(k,3)*urz)
3071             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3072             -3.0d0*vrzg(k,3)*urz)
3073 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3074 !grad              do l=1,4
3075 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3076 !grad              enddo
3077 !grad            endif
3078           enddo
3079           acipa(1,1)=a22
3080           acipa(1,2)=a23
3081           acipa(2,1)=a32
3082           acipa(2,2)=a33
3083           a22=-a22
3084           a23=-a23
3085           do l=1,2
3086             do k=1,3
3087               agg(k,l)=-agg(k,l)
3088               aggi(k,l)=-aggi(k,l)
3089               aggi1(k,l)=-aggi1(k,l)
3090               aggj(k,l)=-aggj(k,l)
3091               aggj1(k,l)=-aggj1(k,l)
3092             enddo
3093           enddo
3094           if (j.lt.nres-1) then
3095             a22=-a22
3096             a32=-a32
3097             do l=1,3,2
3098               do k=1,3
3099                 agg(k,l)=-agg(k,l)
3100                 aggi(k,l)=-aggi(k,l)
3101                 aggi1(k,l)=-aggi1(k,l)
3102                 aggj(k,l)=-aggj(k,l)
3103                 aggj1(k,l)=-aggj1(k,l)
3104               enddo
3105             enddo
3106           else
3107             a22=-a22
3108             a23=-a23
3109             a32=-a32
3110             a33=-a33
3111             do l=1,4
3112               do k=1,3
3113                 agg(k,l)=-agg(k,l)
3114                 aggi(k,l)=-aggi(k,l)
3115                 aggi1(k,l)=-aggi1(k,l)
3116                 aggj(k,l)=-aggj(k,l)
3117                 aggj1(k,l)=-aggj1(k,l)
3118               enddo
3119             enddo
3120           endif
3121           ENDIF ! WCORR
3122           IF (wel_loc.gt.0.0d0) THEN
3123 ! Contribution to the local-electrostatic energy coming from the i-j pair
3124           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3125            +a33*muij(4)
3126 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3127
3128           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3129                   'eelloc',i,j,eel_loc_ij
3130 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3131 !          if (energy_dec) write (iout,*) "muij",muij
3132 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3133
3134           eel_loc=eel_loc+eel_loc_ij
3135 ! Partial derivatives in virtual-bond dihedral angles gamma
3136           if (i.gt.1) &
3137           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3138                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3139                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3140           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3141                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3142                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3143 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3144           do l=1,3
3145             ggg(l)=agg(l,1)*muij(1)+ &
3146                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3147             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3148             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3149 !grad            ghalf=0.5d0*ggg(l)
3150 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3151 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3152           enddo
3153 !grad          do k=i+1,j2
3154 !grad            do l=1,3
3155 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3156 !grad            enddo
3157 !grad          enddo
3158 ! Remaining derivatives of eello
3159           do l=1,3
3160             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3161                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3162             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3163                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3164             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3165                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3166             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3167                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3168           enddo
3169           ENDIF
3170 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3171 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3172           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3173              .and. num_conti.le.maxconts) then
3174 !            write (iout,*) i,j," entered corr"
3175 !
3176 ! Calculate the contact function. The ith column of the array JCONT will
3177 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3178 ! greater than I). The arrays FACONT and GACONT will contain the values of
3179 ! the contact function and its derivative.
3180 !           r0ij=1.02D0*rpp(iteli,itelj)
3181 !           r0ij=1.11D0*rpp(iteli,itelj)
3182             r0ij=2.20D0*rpp(iteli,itelj)
3183 !           r0ij=1.55D0*rpp(iteli,itelj)
3184             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3185 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3186             if (fcont.gt.0.0D0) then
3187               num_conti=num_conti+1
3188               if (num_conti.gt.maxconts) then
3189 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3190 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3191                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3192                                ' will skip next contacts for this conf.', num_conti
3193               else
3194                 jcont_hb(num_conti,i)=j
3195 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3196 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3197                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3198                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3199 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3200 !  terms.
3201                 d_cont(num_conti,i)=rij
3202 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3203 !     --- Electrostatic-interaction matrix ---
3204                 a_chuj(1,1,num_conti,i)=a22
3205                 a_chuj(1,2,num_conti,i)=a23
3206                 a_chuj(2,1,num_conti,i)=a32
3207                 a_chuj(2,2,num_conti,i)=a33
3208 !     --- Gradient of rij
3209                 do kkk=1,3
3210                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3211                 enddo
3212                 kkll=0
3213                 do k=1,2
3214                   do l=1,2
3215                     kkll=kkll+1
3216                     do m=1,3
3217                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3218                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3219                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3220                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3221                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3222                     enddo
3223                   enddo
3224                 enddo
3225                 ENDIF
3226                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3227 ! Calculate contact energies
3228                 cosa4=4.0D0*cosa
3229                 wij=cosa-3.0D0*cosb*cosg
3230                 cosbg1=cosb+cosg
3231                 cosbg2=cosb-cosg
3232 !               fac3=dsqrt(-ael6i)/r0ij**3
3233                 fac3=dsqrt(-ael6i)*r3ij
3234 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3235                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3236                 if (ees0tmp.gt.0) then
3237                   ees0pij=dsqrt(ees0tmp)
3238                 else
3239                   ees0pij=0
3240                 endif
3241 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3242                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3243                 if (ees0tmp.gt.0) then
3244                   ees0mij=dsqrt(ees0tmp)
3245                 else
3246                   ees0mij=0
3247                 endif
3248 !               ees0mij=0.0D0
3249                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3250                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3251 ! Diagnostics. Comment out or remove after debugging!
3252 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3253 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3254 !               ees0m(num_conti,i)=0.0D0
3255 ! End diagnostics.
3256 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3257 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3258 ! Angular derivatives of the contact function
3259                 ees0pij1=fac3/ees0pij
3260                 ees0mij1=fac3/ees0mij
3261                 fac3p=-3.0D0*fac3*rrmij
3262                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3263                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3264 !               ees0mij1=0.0D0
3265                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3266                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3267                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3268                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3269                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3270                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3271                 ecosap=ecosa1+ecosa2
3272                 ecosbp=ecosb1+ecosb2
3273                 ecosgp=ecosg1+ecosg2
3274                 ecosam=ecosa1-ecosa2
3275                 ecosbm=ecosb1-ecosb2
3276                 ecosgm=ecosg1-ecosg2
3277 ! Diagnostics
3278 !               ecosap=ecosa1
3279 !               ecosbp=ecosb1
3280 !               ecosgp=ecosg1
3281 !               ecosam=0.0D0
3282 !               ecosbm=0.0D0
3283 !               ecosgm=0.0D0
3284 ! End diagnostics
3285                 facont_hb(num_conti,i)=fcont
3286                 fprimcont=fprimcont/rij
3287 !d              facont_hb(num_conti,i)=1.0D0
3288 ! Following line is for diagnostics.
3289 !d              fprimcont=0.0D0
3290                 do k=1,3
3291                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3292                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3293                 enddo
3294                 do k=1,3
3295                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3296                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3297                 enddo
3298                 gggp(1)=gggp(1)+ees0pijp*xj
3299                 gggp(2)=gggp(2)+ees0pijp*yj
3300                 gggp(3)=gggp(3)+ees0pijp*zj
3301                 gggm(1)=gggm(1)+ees0mijp*xj
3302                 gggm(2)=gggm(2)+ees0mijp*yj
3303                 gggm(3)=gggm(3)+ees0mijp*zj
3304 ! Derivatives due to the contact function
3305                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3306                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3307                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3308                 do k=1,3
3309 !
3310 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3311 !          following the change of gradient-summation algorithm.
3312 !
3313 !grad                  ghalfp=0.5D0*gggp(k)
3314 !grad                  ghalfm=0.5D0*gggm(k)
3315                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3316                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3317                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3318                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3319                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3320                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3321                   gacontp_hb3(k,num_conti,i)=gggp(k)
3322                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3323                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3324                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3325                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3326                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3327                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3328                   gacontm_hb3(k,num_conti,i)=gggm(k)
3329                 enddo
3330 ! Diagnostics. Comment out or remove after debugging!
3331 !diag           do k=1,3
3332 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3333 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3334 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3335 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3336 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3337 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3338 !diag           enddo
3339               ENDIF ! wcorr
3340               endif  ! num_conti.le.maxconts
3341             endif  ! fcont.gt.0
3342           endif    ! j.gt.i+1
3343           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3344             do k=1,4
3345               do l=1,3
3346                 ghalf=0.5d0*agg(l,k)
3347                 aggi(l,k)=aggi(l,k)+ghalf
3348                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3349                 aggj(l,k)=aggj(l,k)+ghalf
3350               enddo
3351             enddo
3352             if (j.eq.nres-1 .and. i.lt.j-2) then
3353               do k=1,4
3354                 do l=1,3
3355                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3356                 enddo
3357               enddo
3358             endif
3359           endif
3360 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3361       return
3362       end subroutine eelecij
3363 !-----------------------------------------------------------------------------
3364       subroutine eturn3(i,eello_turn3)
3365 ! Third- and fourth-order contributions from turns
3366
3367       use comm_locel
3368 !      implicit real*8 (a-h,o-z)
3369 !      include 'DIMENSIONS'
3370 !      include 'COMMON.IOUNITS'
3371 !      include 'COMMON.GEO'
3372 !      include 'COMMON.VAR'
3373 !      include 'COMMON.LOCAL'
3374 !      include 'COMMON.CHAIN'
3375 !      include 'COMMON.DERIV'
3376 !      include 'COMMON.INTERACT'
3377 !      include 'COMMON.CONTACTS'
3378 !      include 'COMMON.TORSION'
3379 !      include 'COMMON.VECTORS'
3380 !      include 'COMMON.FFIELD'
3381 !      include 'COMMON.CONTROL'
3382       real(kind=8),dimension(3) :: ggg
3383       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3384         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3385       real(kind=8),dimension(2) :: auxvec,auxvec1
3386 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3387       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3388 !el      integer :: num_conti,j1,j2
3389 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3390 !el        dz_normi,xmedi,ymedi,zmedi
3391
3392 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3393 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3394 !el         num_conti,j1,j2
3395 !el local variables
3396       integer :: i,j,l
3397       real(kind=8) :: eello_turn3
3398
3399       j=i+2
3400 !      write (iout,*) "eturn3",i,j,j1,j2
3401       a_temp(1,1)=a22
3402       a_temp(1,2)=a23
3403       a_temp(2,1)=a32
3404       a_temp(2,2)=a33
3405 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3406 !
3407 !               Third-order contributions
3408 !
3409 !                 (i+2)o----(i+3)
3410 !                      | |
3411 !                      | |
3412 !                 (i+1)o----i
3413 !
3414 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3415 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3416         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3417         call transpose2(auxmat(1,1),auxmat1(1,1))
3418         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3419         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3420         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3421                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3422 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3423 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3424 !d     &    ' eello_turn3_num',4*eello_turn3_num
3425 ! Derivatives in gamma(i)
3426         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3427         call transpose2(auxmat2(1,1),auxmat3(1,1))
3428         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3429         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3430 ! Derivatives in gamma(i+1)
3431         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3432         call transpose2(auxmat2(1,1),auxmat3(1,1))
3433         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3434         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3435           +0.5d0*(pizda(1,1)+pizda(2,2))
3436 ! Cartesian derivatives
3437         do l=1,3
3438 !            ghalf1=0.5d0*agg(l,1)
3439 !            ghalf2=0.5d0*agg(l,2)
3440 !            ghalf3=0.5d0*agg(l,3)
3441 !            ghalf4=0.5d0*agg(l,4)
3442           a_temp(1,1)=aggi(l,1)!+ghalf1
3443           a_temp(1,2)=aggi(l,2)!+ghalf2
3444           a_temp(2,1)=aggi(l,3)!+ghalf3
3445           a_temp(2,2)=aggi(l,4)!+ghalf4
3446           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3447           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3448             +0.5d0*(pizda(1,1)+pizda(2,2))
3449           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3450           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3451           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3452           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3453           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3454           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3455             +0.5d0*(pizda(1,1)+pizda(2,2))
3456           a_temp(1,1)=aggj(l,1)!+ghalf1
3457           a_temp(1,2)=aggj(l,2)!+ghalf2
3458           a_temp(2,1)=aggj(l,3)!+ghalf3
3459           a_temp(2,2)=aggj(l,4)!+ghalf4
3460           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3461           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3462             +0.5d0*(pizda(1,1)+pizda(2,2))
3463           a_temp(1,1)=aggj1(l,1)
3464           a_temp(1,2)=aggj1(l,2)
3465           a_temp(2,1)=aggj1(l,3)
3466           a_temp(2,2)=aggj1(l,4)
3467           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3468           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3469             +0.5d0*(pizda(1,1)+pizda(2,2))
3470         enddo
3471       return
3472       end subroutine eturn3
3473 !-----------------------------------------------------------------------------
3474       subroutine eturn4(i,eello_turn4)
3475 ! Third- and fourth-order contributions from turns
3476
3477       use comm_locel
3478 !      implicit real*8 (a-h,o-z)
3479 !      include 'DIMENSIONS'
3480 !      include 'COMMON.IOUNITS'
3481 !      include 'COMMON.GEO'
3482 !      include 'COMMON.VAR'
3483 !      include 'COMMON.LOCAL'
3484 !      include 'COMMON.CHAIN'
3485 !      include 'COMMON.DERIV'
3486 !      include 'COMMON.INTERACT'
3487 !      include 'COMMON.CONTACTS'
3488 !      include 'COMMON.TORSION'
3489 !      include 'COMMON.VECTORS'
3490 !      include 'COMMON.FFIELD'
3491 !      include 'COMMON.CONTROL'
3492       real(kind=8),dimension(3) :: ggg
3493       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3494         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3495       real(kind=8),dimension(2) :: auxvec,auxvec1
3496 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3497       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3498 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3499 !el        dz_normi,xmedi,ymedi,zmedi
3500 !el      integer :: num_conti,j1,j2
3501 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3502 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3503 !el          num_conti,j1,j2
3504 !el local variables
3505       integer :: i,j,iti1,iti2,iti3,l
3506       real(kind=8) :: eello_turn4,s1,s2,s3
3507
3508       j=i+3
3509 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3510 !
3511 !               Fourth-order contributions
3512 !
3513 !                 (i+3)o----(i+4)
3514 !                     /  |
3515 !               (i+2)o   |
3516 !                     \  |
3517 !                 (i+1)o----i
3518 !
3519 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3520 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3521 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3522         a_temp(1,1)=a22
3523         a_temp(1,2)=a23
3524         a_temp(2,1)=a32
3525         a_temp(2,2)=a33
3526         iti1=itortyp(itype(i+1))
3527         iti2=itortyp(itype(i+2))
3528         iti3=itortyp(itype(i+3))
3529 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3530         call transpose2(EUg(1,1,i+1),e1t(1,1))
3531         call transpose2(Eug(1,1,i+2),e2t(1,1))
3532         call transpose2(Eug(1,1,i+3),e3t(1,1))
3533         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3534         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3535         s1=scalar2(b1(1,iti2),auxvec(1))
3536         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3537         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3538         s2=scalar2(b1(1,iti1),auxvec(1))
3539         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3540         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3541         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3542         eello_turn4=eello_turn4-(s1+s2+s3)
3543         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3544            'eturn4',i,j,-(s1+s2+s3)
3545 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3546 !d     &    ' eello_turn4_num',8*eello_turn4_num
3547 ! Derivatives in gamma(i)
3548         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3549         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3550         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3551         s1=scalar2(b1(1,iti2),auxvec(1))
3552         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3553         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3554         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3555 ! Derivatives in gamma(i+1)
3556         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3557         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3558         s2=scalar2(b1(1,iti1),auxvec(1))
3559         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3560         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3561         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3562         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3563 ! Derivatives in gamma(i+2)
3564         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3565         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3566         s1=scalar2(b1(1,iti2),auxvec(1))
3567         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3568         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3569         s2=scalar2(b1(1,iti1),auxvec(1))
3570         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3571         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3572         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3573         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3574 ! Cartesian derivatives
3575 ! Derivatives of this turn contributions in DC(i+2)
3576         if (j.lt.nres-1) then
3577           do l=1,3
3578             a_temp(1,1)=agg(l,1)
3579             a_temp(1,2)=agg(l,2)
3580             a_temp(2,1)=agg(l,3)
3581             a_temp(2,2)=agg(l,4)
3582             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3583             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3584             s1=scalar2(b1(1,iti2),auxvec(1))
3585             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3586             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3587             s2=scalar2(b1(1,iti1),auxvec(1))
3588             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3589             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3590             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3591             ggg(l)=-(s1+s2+s3)
3592             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3593           enddo
3594         endif
3595 ! Remaining derivatives of this turn contribution
3596         do l=1,3
3597           a_temp(1,1)=aggi(l,1)
3598           a_temp(1,2)=aggi(l,2)
3599           a_temp(2,1)=aggi(l,3)
3600           a_temp(2,2)=aggi(l,4)
3601           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3602           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3603           s1=scalar2(b1(1,iti2),auxvec(1))
3604           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3605           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3606           s2=scalar2(b1(1,iti1),auxvec(1))
3607           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3608           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3609           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3610           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3611           a_temp(1,1)=aggi1(l,1)
3612           a_temp(1,2)=aggi1(l,2)
3613           a_temp(2,1)=aggi1(l,3)
3614           a_temp(2,2)=aggi1(l,4)
3615           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3616           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3617           s1=scalar2(b1(1,iti2),auxvec(1))
3618           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3619           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3620           s2=scalar2(b1(1,iti1),auxvec(1))
3621           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3622           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3623           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3624           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3625           a_temp(1,1)=aggj(l,1)
3626           a_temp(1,2)=aggj(l,2)
3627           a_temp(2,1)=aggj(l,3)
3628           a_temp(2,2)=aggj(l,4)
3629           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3630           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3631           s1=scalar2(b1(1,iti2),auxvec(1))
3632           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3633           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3634           s2=scalar2(b1(1,iti1),auxvec(1))
3635           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3636           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3637           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3638           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3639           a_temp(1,1)=aggj1(l,1)
3640           a_temp(1,2)=aggj1(l,2)
3641           a_temp(2,1)=aggj1(l,3)
3642           a_temp(2,2)=aggj1(l,4)
3643           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3644           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3645           s1=scalar2(b1(1,iti2),auxvec(1))
3646           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3647           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3648           s2=scalar2(b1(1,iti1),auxvec(1))
3649           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3650           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3651           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3652 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3653           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3654         enddo
3655       return
3656       end subroutine eturn4
3657 !-----------------------------------------------------------------------------
3658       subroutine unormderiv(u,ugrad,unorm,ungrad)
3659 ! This subroutine computes the derivatives of a normalized vector u, given
3660 ! the derivatives computed without normalization conditions, ugrad. Returns
3661 ! ungrad.
3662 !      implicit none
3663       real(kind=8),dimension(3) :: u,vec
3664       real(kind=8),dimension(3,3) ::ugrad,ungrad
3665       real(kind=8) :: unorm     !,scalar
3666       integer :: i,j
3667 !      write (2,*) 'ugrad',ugrad
3668 !      write (2,*) 'u',u
3669       do i=1,3
3670         vec(i)=scalar(ugrad(1,i),u(1))
3671       enddo
3672 !      write (2,*) 'vec',vec
3673       do i=1,3
3674         do j=1,3
3675           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3676         enddo
3677       enddo
3678 !      write (2,*) 'ungrad',ungrad
3679       return
3680       end subroutine unormderiv
3681 !-----------------------------------------------------------------------------
3682       subroutine escp_soft_sphere(evdw2,evdw2_14)
3683 !
3684 ! This subroutine calculates the excluded-volume interaction energy between
3685 ! peptide-group centers and side chains and its gradient in virtual-bond and
3686 ! side-chain vectors.
3687 !
3688 !      implicit real*8 (a-h,o-z)
3689 !      include 'DIMENSIONS'
3690 !      include 'COMMON.GEO'
3691 !      include 'COMMON.VAR'
3692 !      include 'COMMON.LOCAL'
3693 !      include 'COMMON.CHAIN'
3694 !      include 'COMMON.DERIV'
3695 !      include 'COMMON.INTERACT'
3696 !      include 'COMMON.FFIELD'
3697 !      include 'COMMON.IOUNITS'
3698 !      include 'COMMON.CONTROL'
3699       real(kind=8),dimension(3) :: ggg
3700 !el local variables
3701       integer :: i,iint,j,k,iteli,itypj
3702       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3703                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3704
3705       evdw2=0.0D0
3706       evdw2_14=0.0d0
3707       r0_scp=4.5d0
3708 !d    print '(a)','Enter ESCP'
3709 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3710       do i=iatscp_s,iatscp_e
3711         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3712         iteli=itel(i)
3713         xi=0.5D0*(c(1,i)+c(1,i+1))
3714         yi=0.5D0*(c(2,i)+c(2,i+1))
3715         zi=0.5D0*(c(3,i)+c(3,i+1))
3716
3717         do iint=1,nscp_gr(i)
3718
3719         do j=iscpstart(i,iint),iscpend(i,iint)
3720           if (itype(j).eq.ntyp1) cycle
3721           itypj=iabs(itype(j))
3722 ! Uncomment following three lines for SC-p interactions
3723 !         xj=c(1,nres+j)-xi
3724 !         yj=c(2,nres+j)-yi
3725 !         zj=c(3,nres+j)-zi
3726 ! Uncomment following three lines for Ca-p interactions
3727           xj=c(1,j)-xi
3728           yj=c(2,j)-yi
3729           zj=c(3,j)-zi
3730           rij=xj*xj+yj*yj+zj*zj
3731           r0ij=r0_scp
3732           r0ijsq=r0ij*r0ij
3733           if (rij.lt.r0ijsq) then
3734             evdwij=0.25d0*(rij-r0ijsq)**2
3735             fac=rij-r0ijsq
3736           else
3737             evdwij=0.0d0
3738             fac=0.0d0
3739           endif
3740           evdw2=evdw2+evdwij
3741 !
3742 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3743 !
3744           ggg(1)=xj*fac
3745           ggg(2)=yj*fac
3746           ggg(3)=zj*fac
3747 !grad          if (j.lt.i) then
3748 !d          write (iout,*) 'j<i'
3749 ! Uncomment following three lines for SC-p interactions
3750 !           do k=1,3
3751 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3752 !           enddo
3753 !grad          else
3754 !d          write (iout,*) 'j>i'
3755 !grad            do k=1,3
3756 !grad              ggg(k)=-ggg(k)
3757 ! Uncomment following line for SC-p interactions
3758 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3759 !grad            enddo
3760 !grad          endif
3761 !grad          do k=1,3
3762 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3763 !grad          enddo
3764 !grad          kstart=min0(i+1,j)
3765 !grad          kend=max0(i-1,j-1)
3766 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3767 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3768 !grad          do k=kstart,kend
3769 !grad            do l=1,3
3770 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3771 !grad            enddo
3772 !grad          enddo
3773           do k=1,3
3774             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3775             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3776           enddo
3777         enddo
3778
3779         enddo ! iint
3780       enddo ! i
3781       return
3782       end subroutine escp_soft_sphere
3783 !-----------------------------------------------------------------------------
3784       subroutine escp(evdw2,evdw2_14)
3785 !
3786 ! This subroutine calculates the excluded-volume interaction energy between
3787 ! peptide-group centers and side chains and its gradient in virtual-bond and
3788 ! side-chain vectors.
3789 !
3790 !      implicit real*8 (a-h,o-z)
3791 !      include 'DIMENSIONS'
3792 !      include 'COMMON.GEO'
3793 !      include 'COMMON.VAR'
3794 !      include 'COMMON.LOCAL'
3795 !      include 'COMMON.CHAIN'
3796 !      include 'COMMON.DERIV'
3797 !      include 'COMMON.INTERACT'
3798 !      include 'COMMON.FFIELD'
3799 !      include 'COMMON.IOUNITS'
3800 !      include 'COMMON.CONTROL'
3801       real(kind=8),dimension(3) :: ggg
3802 !el local variables
3803       integer :: i,iint,j,k,iteli,itypj
3804       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3805                    e1,e2,evdwij
3806
3807       evdw2=0.0D0
3808       evdw2_14=0.0d0
3809 !d    print '(a)','Enter ESCP'
3810 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3811       do i=iatscp_s,iatscp_e
3812         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3813         iteli=itel(i)
3814         xi=0.5D0*(c(1,i)+c(1,i+1))
3815         yi=0.5D0*(c(2,i)+c(2,i+1))
3816         zi=0.5D0*(c(3,i)+c(3,i+1))
3817
3818         do iint=1,nscp_gr(i)
3819
3820         do j=iscpstart(i,iint),iscpend(i,iint)
3821           itypj=iabs(itype(j))
3822           if (itypj.eq.ntyp1) cycle
3823 ! Uncomment following three lines for SC-p interactions
3824 !         xj=c(1,nres+j)-xi
3825 !         yj=c(2,nres+j)-yi
3826 !         zj=c(3,nres+j)-zi
3827 ! Uncomment following three lines for Ca-p interactions
3828           xj=c(1,j)-xi
3829           yj=c(2,j)-yi
3830           zj=c(3,j)-zi
3831           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3832           fac=rrij**expon2
3833           e1=fac*fac*aad(itypj,iteli)
3834           e2=fac*bad(itypj,iteli)
3835           if (iabs(j-i) .le. 2) then
3836             e1=scal14*e1
3837             e2=scal14*e2
3838             evdw2_14=evdw2_14+e1+e2
3839           endif
3840           evdwij=e1+e2
3841           evdw2=evdw2+evdwij
3842           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3843              'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3844             bad(itypj,iteli)
3845 !
3846 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3847 !
3848           fac=-(evdwij+e1)*rrij
3849           ggg(1)=xj*fac
3850           ggg(2)=yj*fac
3851           ggg(3)=zj*fac
3852 !grad          if (j.lt.i) then
3853 !d          write (iout,*) 'j<i'
3854 ! Uncomment following three lines for SC-p interactions
3855 !           do k=1,3
3856 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3857 !           enddo
3858 !grad          else
3859 !d          write (iout,*) 'j>i'
3860 !grad            do k=1,3
3861 !grad              ggg(k)=-ggg(k)
3862 ! Uncomment following line for SC-p interactions
3863 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3864 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3865 !grad            enddo
3866 !grad          endif
3867 !grad          do k=1,3
3868 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3869 !grad          enddo
3870 !grad          kstart=min0(i+1,j)
3871 !grad          kend=max0(i-1,j-1)
3872 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3873 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3874 !grad          do k=kstart,kend
3875 !grad            do l=1,3
3876 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3877 !grad            enddo
3878 !grad          enddo
3879           do k=1,3
3880             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3881             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3882           enddo
3883         enddo
3884
3885         enddo ! iint
3886       enddo ! i
3887       do i=1,nct
3888         do j=1,3
3889           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3890           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3891           gradx_scp(j,i)=expon*gradx_scp(j,i)
3892         enddo
3893       enddo
3894 !******************************************************************************
3895 !
3896 !                              N O T E !!!
3897 !
3898 ! To save time the factor EXPON has been extracted from ALL components
3899 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3900 ! use!
3901 !
3902 !******************************************************************************
3903       return
3904       end subroutine escp
3905 !-----------------------------------------------------------------------------
3906       subroutine edis(ehpb)
3907 !
3908 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3909 !
3910 !      implicit real*8 (a-h,o-z)
3911 !      include 'DIMENSIONS'
3912 !      include 'COMMON.SBRIDGE'
3913 !      include 'COMMON.CHAIN'
3914 !      include 'COMMON.DERIV'
3915 !      include 'COMMON.VAR'
3916 !      include 'COMMON.INTERACT'
3917 !      include 'COMMON.IOUNITS'
3918       real(kind=8),dimension(3) :: ggg
3919 !el local variables
3920       integer :: i,j,ii,jj,iii,jjj,k
3921       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3922
3923       ehpb=0.0D0
3924 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3925 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3926       if (link_end.eq.0) return
3927       do i=link_start,link_end
3928 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3929 ! CA-CA distance used in regularization of structure.
3930         ii=ihpb(i)
3931         jj=jhpb(i)
3932 ! iii and jjj point to the residues for which the distance is assigned.
3933         if (ii.gt.nres) then
3934           iii=ii-nres
3935           jjj=jj-nres
3936         else
3937           iii=ii
3938           jjj=jj
3939         endif
3940 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3941 !     &    dhpb(i),dhpb1(i),forcon(i)
3942 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
3943 !    distance and angle dependent SS bond potential.
3944 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3945 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3946         if (.not.dyn_ss .and. i.le.nss) then
3947 ! 15/02/13 CC dynamic SSbond - additional check
3948          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
3949         iabs(itype(jjj)).eq.1) then
3950           call ssbond_ene(iii,jjj,eij)
3951           ehpb=ehpb+2*eij
3952 !d          write (iout,*) "eij",eij
3953          endif
3954         else
3955 ! Calculate the distance between the two points and its difference from the
3956 ! target distance.
3957         dd=dist(ii,jj)
3958         rdis=dd-dhpb(i)
3959 ! Get the force constant corresponding to this distance.
3960         waga=forcon(i)
3961 ! Calculate the contribution to energy.
3962         ehpb=ehpb+waga*rdis*rdis
3963 !
3964 ! Evaluate gradient.
3965 !
3966         fac=waga*rdis/dd
3967 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3968 !d   &   ' waga=',waga,' fac=',fac
3969         do j=1,3
3970           ggg(j)=fac*(c(j,jj)-c(j,ii))
3971         enddo
3972 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3973 ! If this is a SC-SC distance, we need to calculate the contributions to the
3974 ! Cartesian gradient in the SC vectors (ghpbx).
3975         if (iii.lt.ii) then
3976           do j=1,3
3977             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3978             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3979           enddo
3980         endif
3981 !grad        do j=iii,jjj-1
3982 !grad          do k=1,3
3983 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3984 !grad          enddo
3985 !grad        enddo
3986         do k=1,3
3987           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3988           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3989         enddo
3990         endif
3991       enddo
3992       ehpb=0.5D0*ehpb
3993       return
3994       end subroutine edis
3995 !-----------------------------------------------------------------------------
3996       subroutine ssbond_ene(i,j,eij)
3997 !
3998 ! Calculate the distance and angle dependent SS-bond potential energy
3999 ! using a free-energy function derived based on RHF/6-31G** ab initio
4000 ! calculations of diethyl disulfide.
4001 !
4002 ! A. Liwo and U. Kozlowska, 11/24/03
4003 !
4004 !      implicit real*8 (a-h,o-z)
4005 !      include 'DIMENSIONS'
4006 !      include 'COMMON.SBRIDGE'
4007 !      include 'COMMON.CHAIN'
4008 !      include 'COMMON.DERIV'
4009 !      include 'COMMON.LOCAL'
4010 !      include 'COMMON.INTERACT'
4011 !      include 'COMMON.VAR'
4012 !      include 'COMMON.IOUNITS'
4013       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4014 !el local variables
4015       integer :: i,j,itypi,itypj,k
4016       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4017                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4018                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4019                    cosphi,ggk
4020
4021       itypi=iabs(itype(i))
4022       xi=c(1,nres+i)
4023       yi=c(2,nres+i)
4024       zi=c(3,nres+i)
4025       dxi=dc_norm(1,nres+i)
4026       dyi=dc_norm(2,nres+i)
4027       dzi=dc_norm(3,nres+i)
4028 !      dsci_inv=dsc_inv(itypi)
4029       dsci_inv=vbld_inv(nres+i)
4030       itypj=iabs(itype(j))
4031 !      dscj_inv=dsc_inv(itypj)
4032       dscj_inv=vbld_inv(nres+j)
4033       xj=c(1,nres+j)-xi
4034       yj=c(2,nres+j)-yi
4035       zj=c(3,nres+j)-zi
4036       dxj=dc_norm(1,nres+j)
4037       dyj=dc_norm(2,nres+j)
4038       dzj=dc_norm(3,nres+j)
4039       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4040       rij=dsqrt(rrij)
4041       erij(1)=xj*rij
4042       erij(2)=yj*rij
4043       erij(3)=zj*rij
4044       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4045       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4046       om12=dxi*dxj+dyi*dyj+dzi*dzj
4047       do k=1,3
4048         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4049         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4050       enddo
4051       rij=1.0d0/rij
4052       deltad=rij-d0cm
4053       deltat1=1.0d0-om1
4054       deltat2=1.0d0+om2
4055       deltat12=om2-om1+2.0d0
4056       cosphi=om12-om1*om2
4057       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4058         +akct*deltad*deltat12 &
4059         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4060 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4061 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4062 !     &  " deltat12",deltat12," eij",eij
4063       ed=2*akcm*deltad+akct*deltat12
4064       pom1=akct*deltad
4065       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4066       eom1=-2*akth*deltat1-pom1-om2*pom2
4067       eom2= 2*akth*deltat2+pom1-om1*pom2
4068       eom12=pom2
4069       do k=1,3
4070         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4071         ghpbx(k,i)=ghpbx(k,i)-ggk &
4072                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4073                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4074         ghpbx(k,j)=ghpbx(k,j)+ggk &
4075                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4076                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4077         ghpbc(k,i)=ghpbc(k,i)-ggk
4078         ghpbc(k,j)=ghpbc(k,j)+ggk
4079       enddo
4080 !
4081 ! Calculate the components of the gradient in DC and X
4082 !
4083 !grad      do k=i,j-1
4084 !grad        do l=1,3
4085 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4086 !grad        enddo
4087 !grad      enddo
4088       return
4089       end subroutine ssbond_ene
4090 !-----------------------------------------------------------------------------
4091       subroutine ebond(estr)
4092 !
4093 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4094 !
4095 !      implicit real*8 (a-h,o-z)
4096 !      include 'DIMENSIONS'
4097 !      include 'COMMON.LOCAL'
4098 !      include 'COMMON.GEO'
4099 !      include 'COMMON.INTERACT'
4100 !      include 'COMMON.DERIV'
4101 !      include 'COMMON.VAR'
4102 !      include 'COMMON.CHAIN'
4103 !      include 'COMMON.IOUNITS'
4104 !      include 'COMMON.NAMES'
4105 !      include 'COMMON.FFIELD'
4106 !      include 'COMMON.CONTROL'
4107 !      include 'COMMON.SETUP'
4108       real(kind=8),dimension(3) :: u,ud
4109 !el local variables
4110       integer :: i,j,iti,nbi,k
4111       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4112                    uprod1,uprod2
4113
4114       estr=0.0d0
4115       estr1=0.0d0
4116 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4117 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4118
4119       do i=ibondp_start,ibondp_end
4120         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4121           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4122           do j=1,3
4123           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4124             *dc(j,i-1)/vbld(i)
4125           enddo
4126           if (energy_dec) write(iout,*) &
4127              "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4128         else
4129         diff = vbld(i)-vbldp0
4130         if (energy_dec) write (iout,*) &
4131            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4132         estr=estr+diff*diff
4133         do j=1,3
4134           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4135         enddo
4136 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4137         endif
4138       enddo
4139       estr=0.5d0*AKP*estr+estr1
4140 !
4141 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4142 !
4143       do i=ibond_start,ibond_end
4144         iti=iabs(itype(i))
4145         if (iti.ne.10 .and. iti.ne.ntyp1) then
4146           nbi=nbondterm(iti)
4147           if (nbi.eq.1) then
4148             diff=vbld(i+nres)-vbldsc0(1,iti)
4149             if (energy_dec) write (iout,*) &
4150             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4151             AKSC(1,iti),AKSC(1,iti)*diff*diff
4152             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4153             do j=1,3
4154               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4155             enddo
4156           else
4157             do j=1,nbi
4158               diff=vbld(i+nres)-vbldsc0(j,iti)
4159               ud(j)=aksc(j,iti)*diff
4160               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4161             enddo
4162             uprod=u(1)
4163             do j=2,nbi
4164               uprod=uprod*u(j)
4165             enddo
4166             usum=0.0d0
4167             usumsqder=0.0d0
4168             do j=1,nbi
4169               uprod1=1.0d0
4170               uprod2=1.0d0
4171               do k=1,nbi
4172                 if (k.ne.j) then
4173                   uprod1=uprod1*u(k)
4174                   uprod2=uprod2*u(k)*u(k)
4175                 endif
4176               enddo
4177               usum=usum+uprod1
4178               usumsqder=usumsqder+ud(j)*uprod2
4179             enddo
4180             estr=estr+uprod/usum
4181             do j=1,3
4182              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4183             enddo
4184           endif
4185         endif
4186       enddo
4187       return
4188       end subroutine ebond
4189 #ifdef CRYST_THETA
4190 !-----------------------------------------------------------------------------
4191       subroutine ebend(etheta)
4192 !
4193 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4194 ! angles gamma and its derivatives in consecutive thetas and gammas.
4195 !
4196       use comm_calcthet
4197 !      implicit real*8 (a-h,o-z)
4198 !      include 'DIMENSIONS'
4199 !      include 'COMMON.LOCAL'
4200 !      include 'COMMON.GEO'
4201 !      include 'COMMON.INTERACT'
4202 !      include 'COMMON.DERIV'
4203 !      include 'COMMON.VAR'
4204 !      include 'COMMON.CHAIN'
4205 !      include 'COMMON.IOUNITS'
4206 !      include 'COMMON.NAMES'
4207 !      include 'COMMON.FFIELD'
4208 !      include 'COMMON.CONTROL'
4209 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4210 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4211 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4212 !el      integer :: it
4213 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4214 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4215 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4216 !el local variables
4217       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4218        ichir21,ichir22
4219       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4220        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4221        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4222       real(kind=8),dimension(2) :: y,z
4223
4224       delta=0.02d0*pi
4225 !      time11=dexp(-2*time)
4226 !      time12=1.0d0
4227       etheta=0.0D0
4228 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4229       do i=ithet_start,ithet_end
4230         if (itype(i-1).eq.ntyp1) cycle
4231 ! Zero the energy function and its derivative at 0 or pi.
4232         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4233         it=itype(i-1)
4234         ichir1=isign(1,itype(i-2))
4235         ichir2=isign(1,itype(i))
4236          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4237          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4238          if (itype(i-1).eq.10) then
4239           itype1=isign(10,itype(i-2))
4240           ichir11=isign(1,itype(i-2))
4241           ichir12=isign(1,itype(i-2))
4242           itype2=isign(10,itype(i))
4243           ichir21=isign(1,itype(i))
4244           ichir22=isign(1,itype(i))
4245          endif
4246
4247         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4248 #ifdef OSF
4249           phii=phi(i)
4250           if (phii.ne.phii) phii=150.0
4251 #else
4252           phii=phi(i)
4253 #endif
4254           y(1)=dcos(phii)
4255           y(2)=dsin(phii)
4256         else
4257           y(1)=0.0D0
4258           y(2)=0.0D0
4259         endif
4260         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4261 #ifdef OSF
4262           phii1=phi(i+1)
4263           if (phii1.ne.phii1) phii1=150.0
4264           phii1=pinorm(phii1)
4265           z(1)=cos(phii1)
4266 #else
4267           phii1=phi(i+1)
4268           z(1)=dcos(phii1)
4269 #endif
4270           z(2)=dsin(phii1)
4271         else
4272           z(1)=0.0D0
4273           z(2)=0.0D0
4274         endif
4275 ! Calculate the "mean" value of theta from the part of the distribution
4276 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4277 ! In following comments this theta will be referred to as t_c.
4278         thet_pred_mean=0.0d0
4279         do k=1,2
4280             athetk=athet(k,it,ichir1,ichir2)
4281             bthetk=bthet(k,it,ichir1,ichir2)
4282           if (it.eq.10) then
4283              athetk=athet(k,itype1,ichir11,ichir12)
4284              bthetk=bthet(k,itype2,ichir21,ichir22)
4285           endif
4286          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4287         enddo
4288         dthett=thet_pred_mean*ssd
4289         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4290 ! Derivatives of the "mean" values in gamma1 and gamma2.
4291         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4292                +athet(2,it,ichir1,ichir2)*y(1))*ss
4293         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4294                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4295          if (it.eq.10) then
4296         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4297              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4298         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4299                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4300          endif
4301         if (theta(i).gt.pi-delta) then
4302           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4303                E_tc0)
4304           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4305           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4306           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4307               E_theta)
4308           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4309               E_tc)
4310         else if (theta(i).lt.delta) then
4311           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4312           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4313           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4314               E_theta)
4315           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4316           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4317               E_tc)
4318         else
4319           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4320               E_theta,E_tc)
4321         endif
4322         etheta=etheta+ethetai
4323         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4324             'ebend',i,ethetai
4325         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4326         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4327         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4328       enddo
4329 ! Ufff.... We've done all this!!!
4330       return
4331       end subroutine ebend
4332 !-----------------------------------------------------------------------------
4333       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4334
4335       use comm_calcthet
4336 !      implicit real*8 (a-h,o-z)
4337 !      include 'DIMENSIONS'
4338 !      include 'COMMON.LOCAL'
4339 !      include 'COMMON.IOUNITS'
4340 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4341 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4342 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4343       integer :: i,j,k
4344       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4345 !el      integer :: it
4346 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4347 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4348 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4349 !el local variables
4350       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4351        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4352
4353 ! Calculate the contributions to both Gaussian lobes.
4354 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4355 ! The "polynomial part" of the "standard deviation" of this part of
4356 ! the distribution.
4357         sig=polthet(3,it)
4358         do j=2,0,-1
4359           sig=sig*thet_pred_mean+polthet(j,it)
4360         enddo
4361 ! Derivative of the "interior part" of the "standard deviation of the"
4362 ! gamma-dependent Gaussian lobe in t_c.
4363         sigtc=3*polthet(3,it)
4364         do j=2,1,-1
4365           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4366         enddo
4367         sigtc=sig*sigtc
4368 ! Set the parameters of both Gaussian lobes of the distribution.
4369 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4370         fac=sig*sig+sigc0(it)
4371         sigcsq=fac+fac
4372         sigc=1.0D0/sigcsq
4373 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4374         sigsqtc=-4.0D0*sigcsq*sigtc
4375 !       print *,i,sig,sigtc,sigsqtc
4376 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4377         sigtc=-sigtc/(fac*fac)
4378 ! Following variable is sigma(t_c)**(-2)
4379         sigcsq=sigcsq*sigcsq
4380         sig0i=sig0(it)
4381         sig0inv=1.0D0/sig0i**2
4382         delthec=thetai-thet_pred_mean
4383         delthe0=thetai-theta0i
4384         term1=-0.5D0*sigcsq*delthec*delthec
4385         term2=-0.5D0*sig0inv*delthe0*delthe0
4386 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4387 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4388 ! to the energy (this being the log of the distribution) at the end of energy
4389 ! term evaluation for this virtual-bond angle.
4390         if (term1.gt.term2) then
4391           termm=term1
4392           term2=dexp(term2-termm)
4393           term1=1.0d0
4394         else
4395           termm=term2
4396           term1=dexp(term1-termm)
4397           term2=1.0d0
4398         endif
4399 ! The ratio between the gamma-independent and gamma-dependent lobes of
4400 ! the distribution is a Gaussian function of thet_pred_mean too.
4401         diffak=gthet(2,it)-thet_pred_mean
4402         ratak=diffak/gthet(3,it)**2
4403         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4404 ! Let's differentiate it in thet_pred_mean NOW.
4405         aktc=ak*ratak
4406 ! Now put together the distribution terms to make complete distribution.
4407         termexp=term1+ak*term2
4408         termpre=sigc+ak*sig0i
4409 ! Contribution of the bending energy from this theta is just the -log of
4410 ! the sum of the contributions from the two lobes and the pre-exponential
4411 ! factor. Simple enough, isn't it?
4412         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4413 ! NOW the derivatives!!!
4414 ! 6/6/97 Take into account the deformation.
4415         E_theta=(delthec*sigcsq*term1 &
4416              +ak*delthe0*sig0inv*term2)/termexp
4417         E_tc=((sigtc+aktc*sig0i)/termpre &
4418             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4419              aktc*term2)/termexp)
4420       return
4421       end subroutine theteng
4422 #else
4423 !-----------------------------------------------------------------------------
4424       subroutine ebend(etheta)
4425 !
4426 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4427 ! angles gamma and its derivatives in consecutive thetas and gammas.
4428 ! ab initio-derived potentials from
4429 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4430 !
4431 !      implicit real*8 (a-h,o-z)
4432 !      include 'DIMENSIONS'
4433 !      include 'COMMON.LOCAL'
4434 !      include 'COMMON.GEO'
4435 !      include 'COMMON.INTERACT'
4436 !      include 'COMMON.DERIV'
4437 !      include 'COMMON.VAR'
4438 !      include 'COMMON.CHAIN'
4439 !      include 'COMMON.IOUNITS'
4440 !      include 'COMMON.NAMES'
4441 !      include 'COMMON.FFIELD'
4442 !      include 'COMMON.CONTROL'
4443       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4444       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4445       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4446       logical :: lprn=.false., lprn1=.false.
4447 !el local variables
4448       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4449       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4450       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4451
4452       etheta=0.0D0
4453       do i=ithet_start,ithet_end
4454         if (itype(i-1).eq.ntyp1) cycle
4455         if (iabs(itype(i+1)).eq.20) iblock=2
4456         if (iabs(itype(i+1)).ne.20) iblock=1
4457         dethetai=0.0d0
4458         dephii=0.0d0
4459         dephii1=0.0d0
4460         theti2=0.5d0*theta(i)
4461         ityp2=ithetyp((itype(i-1)))
4462         do k=1,nntheterm
4463           coskt(k)=dcos(k*theti2)
4464           sinkt(k)=dsin(k*theti2)
4465         enddo
4466         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4467 #ifdef OSF
4468           phii=phi(i)
4469           if (phii.ne.phii) phii=150.0
4470 #else
4471           phii=phi(i)
4472 #endif
4473           ityp1=ithetyp((itype(i-2)))
4474 ! propagation of chirality for glycine type
4475           do k=1,nsingle
4476             cosph1(k)=dcos(k*phii)
4477             sinph1(k)=dsin(k*phii)
4478           enddo
4479         else
4480           phii=0.0d0
4481           ityp1=nthetyp+1
4482           do k=1,nsingle
4483             cosph1(k)=0.0d0
4484             sinph1(k)=0.0d0
4485           enddo
4486         endif
4487         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4488 #ifdef OSF
4489           phii1=phi(i+1)
4490           if (phii1.ne.phii1) phii1=150.0
4491           phii1=pinorm(phii1)
4492 #else
4493           phii1=phi(i+1)
4494 #endif
4495           ityp3=ithetyp((itype(i)))
4496           do k=1,nsingle
4497             cosph2(k)=dcos(k*phii1)
4498             sinph2(k)=dsin(k*phii1)
4499           enddo
4500         else
4501           phii1=0.0d0
4502           ityp3=nthetyp+1
4503           do k=1,nsingle
4504             cosph2(k)=0.0d0
4505             sinph2(k)=0.0d0
4506           enddo
4507         endif
4508         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4509         do k=1,ndouble
4510           do l=1,k-1
4511             ccl=cosph1(l)*cosph2(k-l)
4512             ssl=sinph1(l)*sinph2(k-l)
4513             scl=sinph1(l)*cosph2(k-l)
4514             csl=cosph1(l)*sinph2(k-l)
4515             cosph1ph2(l,k)=ccl-ssl
4516             cosph1ph2(k,l)=ccl+ssl
4517             sinph1ph2(l,k)=scl+csl
4518             sinph1ph2(k,l)=scl-csl
4519           enddo
4520         enddo
4521         if (lprn) then
4522         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4523           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4524         write (iout,*) "coskt and sinkt"
4525         do k=1,nntheterm
4526           write (iout,*) k,coskt(k),sinkt(k)
4527         enddo
4528         endif
4529         do k=1,ntheterm
4530           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4531           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4532             *coskt(k)
4533           if (lprn) &
4534           write (iout,*) "k",k,&
4535            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4536            " ethetai",ethetai
4537         enddo
4538         if (lprn) then
4539         write (iout,*) "cosph and sinph"
4540         do k=1,nsingle
4541           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4542         enddo
4543         write (iout,*) "cosph1ph2 and sinph2ph2"
4544         do k=2,ndouble
4545           do l=1,k-1
4546             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4547                sinph1ph2(l,k),sinph1ph2(k,l)
4548           enddo
4549         enddo
4550         write(iout,*) "ethetai",ethetai
4551         endif
4552         do m=1,ntheterm2
4553           do k=1,nsingle
4554             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4555                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4556                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4557                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4558             ethetai=ethetai+sinkt(m)*aux
4559             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4560             dephii=dephii+k*sinkt(m)* &
4561                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4562                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4563             dephii1=dephii1+k*sinkt(m)* &
4564                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4565                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4566             if (lprn) &
4567             write (iout,*) "m",m," k",k," bbthet", &
4568                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4569                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4570                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4571                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4572           enddo
4573         enddo
4574         if (lprn) &
4575         write(iout,*) "ethetai",ethetai
4576         do m=1,ntheterm3
4577           do k=2,ndouble
4578             do l=1,k-1
4579               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4580                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4581                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4582                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4583               ethetai=ethetai+sinkt(m)*aux
4584               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4585               dephii=dephii+l*sinkt(m)* &
4586                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4587                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4588                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4589                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4590               dephii1=dephii1+(k-l)*sinkt(m)* &
4591                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4592                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4593                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4594                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4595               if (lprn) then
4596               write (iout,*) "m",m," k",k," l",l," ffthet",&
4597                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4598                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4599                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4600                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4601                   " ethetai",ethetai
4602               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4603                   cosph1ph2(k,l)*sinkt(m),&
4604                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4605               endif
4606             enddo
4607           enddo
4608         enddo
4609 10      continue
4610 !        lprn1=.true.
4611         if (lprn1) &
4612           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4613          i,theta(i)*rad2deg,phii*rad2deg,&
4614          phii1*rad2deg,ethetai
4615 !        lprn1=.false.
4616         etheta=etheta+ethetai
4617         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4618         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4619         gloc(nphi+i-2,icg)=wang*dethetai
4620       enddo
4621       return
4622       end subroutine ebend
4623 #endif
4624 #ifdef CRYST_SC
4625 !-----------------------------------------------------------------------------
4626       subroutine esc(escloc)
4627 ! Calculate the local energy of a side chain and its derivatives in the
4628 ! corresponding virtual-bond valence angles THETA and the spherical angles
4629 ! ALPHA and OMEGA.
4630 !
4631       use comm_sccalc
4632 !      implicit real*8 (a-h,o-z)
4633 !      include 'DIMENSIONS'
4634 !      include 'COMMON.GEO'
4635 !      include 'COMMON.LOCAL'
4636 !      include 'COMMON.VAR'
4637 !      include 'COMMON.INTERACT'
4638 !      include 'COMMON.DERIV'
4639 !      include 'COMMON.CHAIN'
4640 !      include 'COMMON.IOUNITS'
4641 !      include 'COMMON.NAMES'
4642 !      include 'COMMON.FFIELD'
4643 !      include 'COMMON.CONTROL'
4644       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4645          ddersc0,ddummy,xtemp,temp
4646 !el      real(kind=8) :: time11,time12,time112,theti
4647       real(kind=8) :: escloc,delta
4648 !el      integer :: it,nlobit
4649 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4650 !el local variables
4651       integer :: i,k
4652       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4653        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4654       delta=0.02d0*pi
4655       escloc=0.0D0
4656 !     write (iout,'(a)') 'ESC'
4657       do i=loc_start,loc_end
4658         it=itype(i)
4659         if (it.eq.ntyp1) cycle
4660         if (it.eq.10) goto 1
4661         nlobit=nlob(iabs(it))
4662 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4663 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4664         theti=theta(i+1)-pipol
4665         x(1)=dtan(theti)
4666         x(2)=alph(i)
4667         x(3)=omeg(i)
4668
4669         if (x(2).gt.pi-delta) then
4670           xtemp(1)=x(1)
4671           xtemp(2)=pi-delta
4672           xtemp(3)=x(3)
4673           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4674           xtemp(2)=pi
4675           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4676           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4677               escloci,dersc(2))
4678           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4679               ddersc0(1),dersc(1))
4680           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4681               ddersc0(3),dersc(3))
4682           xtemp(2)=pi-delta
4683           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4684           xtemp(2)=pi
4685           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4686           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4687                   dersc0(2),esclocbi,dersc02)
4688           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4689                   dersc12,dersc01)
4690           call splinthet(x(2),0.5d0*delta,ss,ssd)
4691           dersc0(1)=dersc01
4692           dersc0(2)=dersc02
4693           dersc0(3)=0.0d0
4694           do k=1,3
4695             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4696           enddo
4697           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4698 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4699 !    &             esclocbi,ss,ssd
4700           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4701 !         escloci=esclocbi
4702 !         write (iout,*) escloci
4703         else if (x(2).lt.delta) then
4704           xtemp(1)=x(1)
4705           xtemp(2)=delta
4706           xtemp(3)=x(3)
4707           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4708           xtemp(2)=0.0d0
4709           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4710           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4711               escloci,dersc(2))
4712           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4713               ddersc0(1),dersc(1))
4714           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4715               ddersc0(3),dersc(3))
4716           xtemp(2)=delta
4717           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4718           xtemp(2)=0.0d0
4719           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4720           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4721                   dersc0(2),esclocbi,dersc02)
4722           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4723                   dersc12,dersc01)
4724           dersc0(1)=dersc01
4725           dersc0(2)=dersc02
4726           dersc0(3)=0.0d0
4727           call splinthet(x(2),0.5d0*delta,ss,ssd)
4728           do k=1,3
4729             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4730           enddo
4731           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4732 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4733 !    &             esclocbi,ss,ssd
4734           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4735 !         write (iout,*) escloci
4736         else
4737           call enesc(x,escloci,dersc,ddummy,.false.)
4738         endif
4739
4740         escloc=escloc+escloci
4741         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4742            'escloc',i,escloci
4743 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4744
4745         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4746          wscloc*dersc(1)
4747         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4748         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4749     1   continue
4750       enddo
4751       return
4752       end subroutine esc
4753 !-----------------------------------------------------------------------------
4754       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4755
4756       use comm_sccalc
4757 !      implicit real*8 (a-h,o-z)
4758 !      include 'DIMENSIONS'
4759 !      include 'COMMON.GEO'
4760 !      include 'COMMON.LOCAL'
4761 !      include 'COMMON.IOUNITS'
4762 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4763       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4764       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4765       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4766       real(kind=8) :: escloci
4767       logical :: mixed
4768 !el local variables
4769       integer :: j,iii,l,k !el,it,nlobit
4770       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4771 !el       time11,time12,time112
4772 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4773         escloc_i=0.0D0
4774         do j=1,3
4775           dersc(j)=0.0D0
4776           if (mixed) ddersc(j)=0.0d0
4777         enddo
4778         x3=x(3)
4779
4780 ! Because of periodicity of the dependence of the SC energy in omega we have
4781 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4782 ! To avoid underflows, first compute & store the exponents.
4783
4784         do iii=-1,1
4785
4786           x(3)=x3+iii*dwapi
4787
4788           do j=1,nlobit
4789             do k=1,3
4790               z(k)=x(k)-censc(k,j,it)
4791             enddo
4792             do k=1,3
4793               Axk=0.0D0
4794               do l=1,3
4795                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4796               enddo
4797               Ax(k,j,iii)=Axk
4798             enddo
4799             expfac=0.0D0
4800             do k=1,3
4801               expfac=expfac+Ax(k,j,iii)*z(k)
4802             enddo
4803             contr(j,iii)=expfac
4804           enddo ! j
4805
4806         enddo ! iii
4807
4808         x(3)=x3
4809 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4810 ! subsequent NaNs and INFs in energy calculation.
4811 ! Find the largest exponent
4812         emin=contr(1,-1)
4813         do iii=-1,1
4814           do j=1,nlobit
4815             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4816           enddo
4817         enddo
4818         emin=0.5D0*emin
4819 !d      print *,'it=',it,' emin=',emin
4820
4821 ! Compute the contribution to SC energy and derivatives
4822         do iii=-1,1
4823
4824           do j=1,nlobit
4825 #ifdef OSF
4826             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4827             if(adexp.ne.adexp) adexp=1.0
4828             expfac=dexp(adexp)
4829 #else
4830             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4831 #endif
4832 !d          print *,'j=',j,' expfac=',expfac
4833             escloc_i=escloc_i+expfac
4834             do k=1,3
4835               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4836             enddo
4837             if (mixed) then
4838               do k=1,3,2
4839                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4840                   +gaussc(k,2,j,it))*expfac
4841               enddo
4842             endif
4843           enddo
4844
4845         enddo ! iii
4846
4847         dersc(1)=dersc(1)/cos(theti)**2
4848         ddersc(1)=ddersc(1)/cos(theti)**2
4849         ddersc(3)=ddersc(3)
4850
4851         escloci=-(dlog(escloc_i)-emin)
4852         do j=1,3
4853           dersc(j)=dersc(j)/escloc_i
4854         enddo
4855         if (mixed) then
4856           do j=1,3,2
4857             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4858           enddo
4859         endif
4860       return
4861       end subroutine enesc
4862 !-----------------------------------------------------------------------------
4863       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4864
4865       use comm_sccalc
4866 !      implicit real*8 (a-h,o-z)
4867 !      include 'DIMENSIONS'
4868 !      include 'COMMON.GEO'
4869 !      include 'COMMON.LOCAL'
4870 !      include 'COMMON.IOUNITS'
4871 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4872       real(kind=8),dimension(3) :: x,z,dersc
4873       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4874       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4875       real(kind=8) :: escloci,dersc12,emin
4876       logical :: mixed
4877 !el local varables
4878       integer :: j,k,l !el,it,nlobit
4879       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4880
4881       escloc_i=0.0D0
4882
4883       do j=1,3
4884         dersc(j)=0.0D0
4885       enddo
4886
4887       do j=1,nlobit
4888         do k=1,2
4889           z(k)=x(k)-censc(k,j,it)
4890         enddo
4891         z(3)=dwapi
4892         do k=1,3
4893           Axk=0.0D0
4894           do l=1,3
4895             Axk=Axk+gaussc(l,k,j,it)*z(l)
4896           enddo
4897           Ax(k,j)=Axk
4898         enddo
4899         expfac=0.0D0
4900         do k=1,3
4901           expfac=expfac+Ax(k,j)*z(k)
4902         enddo
4903         contr(j)=expfac
4904       enddo ! j
4905
4906 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4907 ! subsequent NaNs and INFs in energy calculation.
4908 ! Find the largest exponent
4909       emin=contr(1)
4910       do j=1,nlobit
4911         if (emin.gt.contr(j)) emin=contr(j)
4912       enddo
4913       emin=0.5D0*emin
4914
4915 ! Compute the contribution to SC energy and derivatives
4916
4917       dersc12=0.0d0
4918       do j=1,nlobit
4919         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4920         escloc_i=escloc_i+expfac
4921         do k=1,2
4922           dersc(k)=dersc(k)+Ax(k,j)*expfac
4923         enddo
4924         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4925                   +gaussc(1,2,j,it))*expfac
4926         dersc(3)=0.0d0
4927       enddo
4928
4929       dersc(1)=dersc(1)/cos(theti)**2
4930       dersc12=dersc12/cos(theti)**2
4931       escloci=-(dlog(escloc_i)-emin)
4932       do j=1,2
4933         dersc(j)=dersc(j)/escloc_i
4934       enddo
4935       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4936       return
4937       end subroutine enesc_bound
4938 #else
4939 !-----------------------------------------------------------------------------
4940       subroutine esc(escloc)
4941 ! Calculate the local energy of a side chain and its derivatives in the
4942 ! corresponding virtual-bond valence angles THETA and the spherical angles
4943 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
4944 ! added by Urszula Kozlowska. 07/11/2007
4945 !
4946       use comm_sccalc
4947 !      implicit real*8 (a-h,o-z)
4948 !      include 'DIMENSIONS'
4949 !      include 'COMMON.GEO'
4950 !      include 'COMMON.LOCAL'
4951 !      include 'COMMON.VAR'
4952 !      include 'COMMON.SCROT'
4953 !      include 'COMMON.INTERACT'
4954 !      include 'COMMON.DERIV'
4955 !      include 'COMMON.CHAIN'
4956 !      include 'COMMON.IOUNITS'
4957 !      include 'COMMON.NAMES'
4958 !      include 'COMMON.FFIELD'
4959 !      include 'COMMON.CONTROL'
4960 !      include 'COMMON.VECTORS'
4961       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
4962       real(kind=8),dimension(65) :: x
4963       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
4964          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
4965       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
4966       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
4967          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
4968 !el local variables
4969       integer :: i,j,k !el,it,nlobit
4970       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
4971 !el      real(kind=8) :: time11,time12,time112,theti
4972 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4973       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
4974                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
4975                    sumene1x,sumene2x,sumene3x,sumene4x,&
4976                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
4977                    cosfac2xx,sinfac2yy
4978 #ifdef DEBUG
4979       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
4980                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
4981                    de_dt_num
4982 #endif
4983 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
4984
4985       delta=0.02d0*pi
4986       escloc=0.0D0
4987       do i=loc_start,loc_end
4988         if (itype(i).eq.ntyp1) cycle
4989         costtab(i+1) =dcos(theta(i+1))
4990         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4991         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4992         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4993         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4994         cosfac=dsqrt(cosfac2)
4995         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4996         sinfac=dsqrt(sinfac2)
4997         it=iabs(itype(i))
4998         if (it.eq.10) goto 1
4999 !
5000 !  Compute the axes of tghe local cartesian coordinates system; store in
5001 !   x_prime, y_prime and z_prime
5002 !
5003         do j=1,3
5004           x_prime(j) = 0.00
5005           y_prime(j) = 0.00
5006           z_prime(j) = 0.00
5007         enddo
5008 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5009 !     &   dc_norm(3,i+nres)
5010         do j = 1,3
5011           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5012           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5013         enddo
5014         do j = 1,3
5015           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5016         enddo
5017 !       write (2,*) "i",i
5018 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5019 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5020 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5021 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5022 !      & " xy",scalar(x_prime(1),y_prime(1)),
5023 !      & " xz",scalar(x_prime(1),z_prime(1)),
5024 !      & " yy",scalar(y_prime(1),y_prime(1)),
5025 !      & " yz",scalar(y_prime(1),z_prime(1)),
5026 !      & " zz",scalar(z_prime(1),z_prime(1))
5027 !
5028 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5029 ! to local coordinate system. Store in xx, yy, zz.
5030 !
5031         xx=0.0d0
5032         yy=0.0d0
5033         zz=0.0d0
5034         do j = 1,3
5035           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5036           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5037           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5038         enddo
5039
5040         xxtab(i)=xx
5041         yytab(i)=yy
5042         zztab(i)=zz
5043 !
5044 ! Compute the energy of the ith side cbain
5045 !
5046 !        write (2,*) "xx",xx," yy",yy," zz",zz
5047         it=iabs(itype(i))
5048         do j = 1,65
5049           x(j) = sc_parmin(j,it)
5050         enddo
5051 #ifdef CHECK_COORD
5052 !c diagnostics - remove later
5053         xx1 = dcos(alph(2))
5054         yy1 = dsin(alph(2))*dcos(omeg(2))
5055         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5056         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5057           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5058           xx1,yy1,zz1
5059 !,"  --- ", xx_w,yy_w,zz_w
5060 ! end diagnostics
5061 #endif
5062         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5063          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5064          + x(10)*yy*zz
5065         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5066          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5067          + x(20)*yy*zz
5068         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5069          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5070          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5071          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5072          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5073          +x(40)*xx*yy*zz
5074         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5075          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5076          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5077          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5078          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5079          +x(60)*xx*yy*zz
5080         dsc_i   = 0.743d0+x(61)
5081         dp2_i   = 1.9d0+x(62)
5082         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5083                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5084         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5085                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5086         s1=(1+x(63))/(0.1d0 + dscp1)
5087         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5088         s2=(1+x(65))/(0.1d0 + dscp2)
5089         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5090         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5091       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5092 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5093 !     &   sumene4,
5094 !     &   dscp1,dscp2,sumene
5095 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5096         escloc = escloc + sumene
5097 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5098 !     & ,zz,xx,yy
5099 !#define DEBUG
5100 #ifdef DEBUG
5101 !
5102 ! This section to check the numerical derivatives of the energy of ith side
5103 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5104 ! #define DEBUG in the code to turn it on.
5105 !
5106         write (2,*) "sumene               =",sumene
5107         aincr=1.0d-7
5108         xxsave=xx
5109         xx=xx+aincr
5110         write (2,*) xx,yy,zz
5111         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5112         de_dxx_num=(sumenep-sumene)/aincr
5113         xx=xxsave
5114         write (2,*) "xx+ sumene from enesc=",sumenep
5115         yysave=yy
5116         yy=yy+aincr
5117         write (2,*) xx,yy,zz
5118         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5119         de_dyy_num=(sumenep-sumene)/aincr
5120         yy=yysave
5121         write (2,*) "yy+ sumene from enesc=",sumenep
5122         zzsave=zz
5123         zz=zz+aincr
5124         write (2,*) xx,yy,zz
5125         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5126         de_dzz_num=(sumenep-sumene)/aincr
5127         zz=zzsave
5128         write (2,*) "zz+ sumene from enesc=",sumenep
5129         costsave=cost2tab(i+1)
5130         sintsave=sint2tab(i+1)
5131         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5132         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5133         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5134         de_dt_num=(sumenep-sumene)/aincr
5135         write (2,*) " t+ sumene from enesc=",sumenep
5136         cost2tab(i+1)=costsave
5137         sint2tab(i+1)=sintsave
5138 ! End of diagnostics section.
5139 #endif
5140 !
5141 ! Compute the gradient of esc
5142 !
5143 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5144         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5145         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5146         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5147         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5148         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5149         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5150         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5151         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5152         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5153            *(pom_s1/dscp1+pom_s16*dscp1**4)
5154         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5155            *(pom_s2/dscp2+pom_s26*dscp2**4)
5156         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5157         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5158         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5159         +x(40)*yy*zz
5160         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5161         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5162         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5163         +x(60)*yy*zz
5164         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5165               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5166               +(pom1+pom2)*pom_dx
5167 #ifdef DEBUG
5168         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5169 #endif
5170 !
5171         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5172         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5173         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5174         +x(40)*xx*zz
5175         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5176         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5177         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5178         +x(59)*zz**2 +x(60)*xx*zz
5179         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5180               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5181               +(pom1-pom2)*pom_dy
5182 #ifdef DEBUG
5183         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5184 #endif
5185 !
5186         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5187         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5188         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5189         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5190         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5191         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5192         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5193         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5194 #ifdef DEBUG
5195         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5196 #endif
5197 !
5198         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5199         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5200         +pom1*pom_dt1+pom2*pom_dt2
5201 #ifdef DEBUG
5202         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5203 #endif
5204 !
5205 !
5206        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5207        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5208        cosfac2xx=cosfac2*xx
5209        sinfac2yy=sinfac2*yy
5210        do k = 1,3
5211          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5212             vbld_inv(i+1)
5213          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5214             vbld_inv(i)
5215          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5216          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5217 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5218 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5219 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5220 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5221          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5222          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5223          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5224          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5225          dZZ_Ci1(k)=0.0d0
5226          dZZ_Ci(k)=0.0d0
5227          do j=1,3
5228            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5229            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5230            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5231            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5232          enddo
5233
5234          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5235          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5236          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5237          (z_prime(k)-zz*dC_norm(k,i+nres))
5238 !
5239          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5240          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5241        enddo
5242
5243        do k=1,3
5244          dXX_Ctab(k,i)=dXX_Ci(k)
5245          dXX_C1tab(k,i)=dXX_Ci1(k)
5246          dYY_Ctab(k,i)=dYY_Ci(k)
5247          dYY_C1tab(k,i)=dYY_Ci1(k)
5248          dZZ_Ctab(k,i)=dZZ_Ci(k)
5249          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5250          dXX_XYZtab(k,i)=dXX_XYZ(k)
5251          dYY_XYZtab(k,i)=dYY_XYZ(k)
5252          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5253        enddo
5254
5255        do k = 1,3
5256 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5257 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5258 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5259 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5260 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5261 !     &    dt_dci(k)
5262 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5263 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5264          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5265           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5266          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5267           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5268          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5269           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5270        enddo
5271 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5272 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5273
5274 ! to check gradient call subroutine check_grad
5275
5276     1 continue
5277       enddo
5278       return
5279       end subroutine esc
5280 !-----------------------------------------------------------------------------
5281       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5282 !      implicit none
5283       real(kind=8),dimension(65) :: x
5284       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5285         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5286
5287       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5288         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5289         + x(10)*yy*zz
5290       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5291         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5292         + x(20)*yy*zz
5293       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5294         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5295         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5296         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5297         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5298         +x(40)*xx*yy*zz
5299       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5300         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5301         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5302         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5303         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5304         +x(60)*xx*yy*zz
5305       dsc_i   = 0.743d0+x(61)
5306       dp2_i   = 1.9d0+x(62)
5307       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5308                 *(xx*cost2+yy*sint2))
5309       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5310                 *(xx*cost2-yy*sint2))
5311       s1=(1+x(63))/(0.1d0 + dscp1)
5312       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5313       s2=(1+x(65))/(0.1d0 + dscp2)
5314       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5315       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5316        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5317       enesc=sumene
5318       return
5319       end function enesc
5320 #endif
5321 !-----------------------------------------------------------------------------
5322       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5323 !
5324 ! This procedure calculates two-body contact function g(rij) and its derivative:
5325 !
5326 !           eps0ij                                     !       x < -1
5327 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5328 !            0                                         !       x > 1
5329 !
5330 ! where x=(rij-r0ij)/delta
5331 !
5332 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5333 !
5334 !      implicit none
5335       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5336       real(kind=8) :: x,x2,x4,delta
5337 !     delta=0.02D0*r0ij
5338 !      delta=0.2D0*r0ij
5339       x=(rij-r0ij)/delta
5340       if (x.lt.-1.0D0) then
5341         fcont=eps0ij
5342         fprimcont=0.0D0
5343       else if (x.le.1.0D0) then
5344         x2=x*x
5345         x4=x2*x2
5346         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5347         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5348       else
5349         fcont=0.0D0
5350         fprimcont=0.0D0
5351       endif
5352       return
5353       end subroutine gcont
5354 !-----------------------------------------------------------------------------
5355       subroutine splinthet(theti,delta,ss,ssder)
5356 !      implicit real*8 (a-h,o-z)
5357 !      include 'DIMENSIONS'
5358 !      include 'COMMON.VAR'
5359 !      include 'COMMON.GEO'
5360       real(kind=8) :: theti,delta,ss,ssder
5361       real(kind=8) :: thetup,thetlow
5362       thetup=pi-delta
5363       thetlow=delta
5364       if (theti.gt.pipol) then
5365         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5366       else
5367         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5368         ssder=-ssder
5369       endif
5370       return
5371       end subroutine splinthet
5372 !-----------------------------------------------------------------------------
5373       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5374 !      implicit none
5375       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5376       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5377       a1=fprim0*delta/(f1-f0)
5378       a2=3.0d0-2.0d0*a1
5379       a3=a1-2.0d0
5380       ksi=(x-x0)/delta
5381       ksi2=ksi*ksi
5382       ksi3=ksi2*ksi
5383       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5384       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5385       return
5386       end subroutine spline1
5387 !-----------------------------------------------------------------------------
5388       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5389 !      implicit none
5390       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5391       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5392       ksi=(x-x0)/delta
5393       ksi2=ksi*ksi
5394       ksi3=ksi2*ksi
5395       a1=fprim0x*delta
5396       a2=3*(f1x-f0x)-2*fprim0x*delta
5397       a3=fprim0x*delta-2*(f1x-f0x)
5398       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5399       return
5400       end subroutine spline2
5401 !-----------------------------------------------------------------------------
5402 #ifdef CRYST_TOR
5403 !-----------------------------------------------------------------------------
5404       subroutine etor(etors,edihcnstr)
5405 !      implicit real*8 (a-h,o-z)
5406 !      include 'DIMENSIONS'
5407 !      include 'COMMON.VAR'
5408 !      include 'COMMON.GEO'
5409 !      include 'COMMON.LOCAL'
5410 !      include 'COMMON.TORSION'
5411 !      include 'COMMON.INTERACT'
5412 !      include 'COMMON.DERIV'
5413 !      include 'COMMON.CHAIN'
5414 !      include 'COMMON.NAMES'
5415 !      include 'COMMON.IOUNITS'
5416 !      include 'COMMON.FFIELD'
5417 !      include 'COMMON.TORCNSTR'
5418 !      include 'COMMON.CONTROL'
5419       real(kind=8) :: etors,edihcnstr
5420       logical :: lprn
5421 !el local variables
5422       integer :: i,j,
5423       real(kind=8) :: phii,fac,etors_ii
5424
5425 ! Set lprn=.true. for debugging
5426       lprn=.false.
5427 !      lprn=.true.
5428       etors=0.0D0
5429       do i=iphi_start,iphi_end
5430       etors_ii=0.0D0
5431         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5432             .or. itype(i).eq.ntyp1) cycle
5433         itori=itortyp(itype(i-2))
5434         itori1=itortyp(itype(i-1))
5435         phii=phi(i)
5436         gloci=0.0D0
5437 ! Proline-Proline pair is a special case...
5438         if (itori.eq.3 .and. itori1.eq.3) then
5439           if (phii.gt.-dwapi3) then
5440             cosphi=dcos(3*phii)
5441             fac=1.0D0/(1.0D0-cosphi)
5442             etorsi=v1(1,3,3)*fac
5443             etorsi=etorsi+etorsi
5444             etors=etors+etorsi-v1(1,3,3)
5445             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5446             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5447           endif
5448           do j=1,3
5449             v1ij=v1(j+1,itori,itori1)
5450             v2ij=v2(j+1,itori,itori1)
5451             cosphi=dcos(j*phii)
5452             sinphi=dsin(j*phii)
5453             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5454             if (energy_dec) etors_ii=etors_ii+ &
5455                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5456             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5457           enddo
5458         else
5459           do j=1,nterm_old
5460             v1ij=v1(j,itori,itori1)
5461             v2ij=v2(j,itori,itori1)
5462             cosphi=dcos(j*phii)
5463             sinphi=dsin(j*phii)
5464             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5465             if (energy_dec) etors_ii=etors_ii+ &
5466                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5467             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5468           enddo
5469         endif
5470         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5471              'etor',i,etors_ii
5472         if (lprn) &
5473         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5474         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5475         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5476         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5477 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5478       enddo
5479 ! 6/20/98 - dihedral angle constraints
5480       edihcnstr=0.0d0
5481       do i=1,ndih_constr
5482         itori=idih_constr(i)
5483         phii=phi(itori)
5484         difi=phii-phi0(i)
5485         if (difi.gt.drange(i)) then
5486           difi=difi-drange(i)
5487           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5488           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5489         else if (difi.lt.-drange(i)) then
5490           difi=difi+drange(i)
5491           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5492           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5493         endif
5494 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5495 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5496       enddo
5497 !      write (iout,*) 'edihcnstr',edihcnstr
5498       return
5499       end subroutine etor
5500 !-----------------------------------------------------------------------------
5501       subroutine etor_d(etors_d)
5502       real(kind=8) :: etors_d
5503       etors_d=0.0d0
5504       return
5505       end subroutine etor_d
5506 #else
5507 !-----------------------------------------------------------------------------
5508       subroutine etor(etors,edihcnstr)
5509 !      implicit real*8 (a-h,o-z)
5510 !      include 'DIMENSIONS'
5511 !      include 'COMMON.VAR'
5512 !      include 'COMMON.GEO'
5513 !      include 'COMMON.LOCAL'
5514 !      include 'COMMON.TORSION'
5515 !      include 'COMMON.INTERACT'
5516 !      include 'COMMON.DERIV'
5517 !      include 'COMMON.CHAIN'
5518 !      include 'COMMON.NAMES'
5519 !      include 'COMMON.IOUNITS'
5520 !      include 'COMMON.FFIELD'
5521 !      include 'COMMON.TORCNSTR'
5522 !      include 'COMMON.CONTROL'
5523       real(kind=8) :: etors,edihcnstr
5524       logical :: lprn
5525 !el local variables
5526       integer :: i,j,iblock,itori,itori1
5527       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5528                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5529 ! Set lprn=.true. for debugging
5530       lprn=.false.
5531 !     lprn=.true.
5532       etors=0.0D0
5533       do i=iphi_start,iphi_end
5534         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5535              .or. itype(i).eq.ntyp1) cycle
5536         etors_ii=0.0D0
5537          if (iabs(itype(i)).eq.20) then
5538          iblock=2
5539          else
5540          iblock=1
5541          endif
5542         itori=itortyp(itype(i-2))
5543         itori1=itortyp(itype(i-1))
5544         phii=phi(i)
5545         gloci=0.0D0
5546 ! Regular cosine and sine terms
5547         do j=1,nterm(itori,itori1,iblock)
5548           v1ij=v1(j,itori,itori1,iblock)
5549           v2ij=v2(j,itori,itori1,iblock)
5550           cosphi=dcos(j*phii)
5551           sinphi=dsin(j*phii)
5552           etors=etors+v1ij*cosphi+v2ij*sinphi
5553           if (energy_dec) etors_ii=etors_ii+ &
5554                      v1ij*cosphi+v2ij*sinphi
5555           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5556         enddo
5557 ! Lorentz terms
5558 !                         v1
5559 !  E = SUM ----------------------------------- - v1
5560 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5561 !
5562         cosphi=dcos(0.5d0*phii)
5563         sinphi=dsin(0.5d0*phii)
5564         do j=1,nlor(itori,itori1,iblock)
5565           vl1ij=vlor1(j,itori,itori1)
5566           vl2ij=vlor2(j,itori,itori1)
5567           vl3ij=vlor3(j,itori,itori1)
5568           pom=vl2ij*cosphi+vl3ij*sinphi
5569           pom1=1.0d0/(pom*pom+1.0d0)
5570           etors=etors+vl1ij*pom1
5571           if (energy_dec) etors_ii=etors_ii+ &
5572                      vl1ij*pom1
5573           pom=-pom*pom1*pom1
5574           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5575         enddo
5576 ! Subtract the constant term
5577         etors=etors-v0(itori,itori1,iblock)
5578           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5579                'etor',i,etors_ii-v0(itori,itori1,iblock)
5580         if (lprn) &
5581         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5582         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5583         (v1(j,itori,itori1,iblock),j=1,6),&
5584         (v2(j,itori,itori1,iblock),j=1,6)
5585         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5586 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5587       enddo
5588 ! 6/20/98 - dihedral angle constraints
5589       edihcnstr=0.0d0
5590 !      do i=1,ndih_constr
5591       do i=idihconstr_start,idihconstr_end
5592         itori=idih_constr(i)
5593         phii=phi(itori)
5594         difi=pinorm(phii-phi0(i))
5595         if (difi.gt.drange(i)) then
5596           difi=difi-drange(i)
5597           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5598           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5599         else if (difi.lt.-drange(i)) then
5600           difi=difi+drange(i)
5601           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5602           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5603         else
5604           difi=0.0
5605         endif
5606 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5607 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5608 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5609       enddo
5610 !d       write (iout,*) 'edihcnstr',edihcnstr
5611       return
5612       end subroutine etor
5613 !-----------------------------------------------------------------------------
5614       subroutine etor_d(etors_d)
5615 ! 6/23/01 Compute double torsional energy
5616 !      implicit real*8 (a-h,o-z)
5617 !      include 'DIMENSIONS'
5618 !      include 'COMMON.VAR'
5619 !      include 'COMMON.GEO'
5620 !      include 'COMMON.LOCAL'
5621 !      include 'COMMON.TORSION'
5622 !      include 'COMMON.INTERACT'
5623 !      include 'COMMON.DERIV'
5624 !      include 'COMMON.CHAIN'
5625 !      include 'COMMON.NAMES'
5626 !      include 'COMMON.IOUNITS'
5627 !      include 'COMMON.FFIELD'
5628 !      include 'COMMON.TORCNSTR'
5629       real(kind=8) :: etors_d
5630       logical :: lprn
5631 !el local variables
5632       integer :: i,j,k,l,itori,itori1,itori2,iblock
5633       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5634                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5635                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5636                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5637 ! Set lprn=.true. for debugging
5638       lprn=.false.
5639 !     lprn=.true.
5640       etors_d=0.0D0
5641 !      write(iout,*) "a tu??"
5642       do i=iphid_start,iphid_end
5643         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5644             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5645         itori=itortyp(itype(i-2))
5646         itori1=itortyp(itype(i-1))
5647         itori2=itortyp(itype(i))
5648         phii=phi(i)
5649         phii1=phi(i+1)
5650         gloci1=0.0D0
5651         gloci2=0.0D0
5652         iblock=1
5653         if (iabs(itype(i+1)).eq.20) iblock=2
5654
5655 ! Regular cosine and sine terms
5656         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5657           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5658           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5659           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5660           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5661           cosphi1=dcos(j*phii)
5662           sinphi1=dsin(j*phii)
5663           cosphi2=dcos(j*phii1)
5664           sinphi2=dsin(j*phii1)
5665           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5666            v2cij*cosphi2+v2sij*sinphi2
5667           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5668           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5669         enddo
5670         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5671           do l=1,k-1
5672             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5673             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5674             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5675             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5676             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5677             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5678             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5679             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5680             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5681               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5682             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5683               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5684             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5685               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5686           enddo
5687         enddo
5688         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5689         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5690       enddo
5691       return
5692       end subroutine etor_d
5693 #endif
5694 !-----------------------------------------------------------------------------
5695       subroutine eback_sc_corr(esccor)
5696 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5697 !        conformational states; temporarily implemented as differences
5698 !        between UNRES torsional potentials (dependent on three types of
5699 !        residues) and the torsional potentials dependent on all 20 types
5700 !        of residues computed from AM1  energy surfaces of terminally-blocked
5701 !        amino-acid residues.
5702 !      implicit real*8 (a-h,o-z)
5703 !      include 'DIMENSIONS'
5704 !      include 'COMMON.VAR'
5705 !      include 'COMMON.GEO'
5706 !      include 'COMMON.LOCAL'
5707 !      include 'COMMON.TORSION'
5708 !      include 'COMMON.SCCOR'
5709 !      include 'COMMON.INTERACT'
5710 !      include 'COMMON.DERIV'
5711 !      include 'COMMON.CHAIN'
5712 !      include 'COMMON.NAMES'
5713 !      include 'COMMON.IOUNITS'
5714 !      include 'COMMON.FFIELD'
5715 !      include 'COMMON.CONTROL'
5716       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5717                    cosphi,sinphi
5718       logical :: lprn
5719       integer :: i,interty,j,isccori,isccori1,intertyp
5720 ! Set lprn=.true. for debugging
5721       lprn=.false.
5722 !      lprn=.true.
5723 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5724       esccor=0.0D0
5725       do i=itau_start,itau_end
5726         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5727         esccor_ii=0.0D0
5728         isccori=isccortyp(itype(i-2))
5729         isccori1=isccortyp(itype(i-1))
5730
5731 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5732         phii=phi(i)
5733         do intertyp=1,3 !intertyp
5734 !c Added 09 May 2012 (Adasko)
5735 !c  Intertyp means interaction type of backbone mainchain correlation:
5736 !   1 = SC...Ca...Ca...Ca
5737 !   2 = Ca...Ca...Ca...SC
5738 !   3 = SC...Ca...Ca...SCi
5739         gloci=0.0D0
5740         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5741             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5742             (itype(i-1).eq.ntyp1))) &
5743           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5744            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5745            .or.(itype(i).eq.ntyp1))) &
5746           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5747             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5748             (itype(i-3).eq.ntyp1)))) cycle
5749         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5750         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5751        cycle
5752        do j=1,nterm_sccor(isccori,isccori1)
5753           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5754           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5755           cosphi=dcos(j*tauangle(intertyp,i))
5756           sinphi=dsin(j*tauangle(intertyp,i))
5757           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5758           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5759         enddo
5760 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5761         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5762         if (lprn) &
5763         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5764         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5765         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5766         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5767         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5768        enddo !intertyp
5769       enddo
5770
5771       return
5772       end subroutine eback_sc_corr
5773 !-----------------------------------------------------------------------------
5774       subroutine multibody(ecorr)
5775 ! This subroutine calculates multi-body contributions to energy following
5776 ! the idea of Skolnick et al. If side chains I and J make a contact and
5777 ! at the same time side chains I+1 and J+1 make a contact, an extra
5778 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5779 !      implicit real*8 (a-h,o-z)
5780 !      include 'DIMENSIONS'
5781 !      include 'COMMON.IOUNITS'
5782 !      include 'COMMON.DERIV'
5783 !      include 'COMMON.INTERACT'
5784 !      include 'COMMON.CONTACTS'
5785       real(kind=8),dimension(3) :: gx,gx1
5786       logical :: lprn
5787       real(kind=8) :: ecorr
5788       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5789 ! Set lprn=.true. for debugging
5790       lprn=.false.
5791
5792       if (lprn) then
5793         write (iout,'(a)') 'Contact function values:'
5794         do i=nnt,nct-2
5795           write (iout,'(i2,20(1x,i2,f10.5))') &
5796               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5797         enddo
5798       endif
5799       ecorr=0.0D0
5800
5801 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5802 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5803       do i=nnt,nct
5804         do j=1,3
5805           gradcorr(j,i)=0.0D0
5806           gradxorr(j,i)=0.0D0
5807         enddo
5808       enddo
5809       do i=nnt,nct-2
5810
5811         DO ISHIFT = 3,4
5812
5813         i1=i+ishift
5814         num_conti=num_cont(i)
5815         num_conti1=num_cont(i1)
5816         do jj=1,num_conti
5817           j=jcont(jj,i)
5818           do kk=1,num_conti1
5819             j1=jcont(kk,i1)
5820             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5821 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5822 !d   &                   ' ishift=',ishift
5823 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5824 ! The system gains extra energy.
5825               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5826             endif   ! j1==j+-ishift
5827           enddo     ! kk
5828         enddo       ! jj
5829
5830         ENDDO ! ISHIFT
5831
5832       enddo         ! i
5833       return
5834       end subroutine multibody
5835 !-----------------------------------------------------------------------------
5836       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5837 !      implicit real*8 (a-h,o-z)
5838 !      include 'DIMENSIONS'
5839 !      include 'COMMON.IOUNITS'
5840 !      include 'COMMON.DERIV'
5841 !      include 'COMMON.INTERACT'
5842 !      include 'COMMON.CONTACTS'
5843       real(kind=8),dimension(3) :: gx,gx1
5844       logical :: lprn
5845       integer :: i,j,k,l,jj,kk,m,ll
5846       real(kind=8) :: eij,ekl
5847       lprn=.false.
5848       eij=facont(jj,i)
5849       ekl=facont(kk,k)
5850 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5851 ! Calculate the multi-body contribution to energy.
5852 ! Calculate multi-body contributions to the gradient.
5853 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5854 !d   & k,l,(gacont(m,kk,k),m=1,3)
5855       do m=1,3
5856         gx(m) =ekl*gacont(m,jj,i)
5857         gx1(m)=eij*gacont(m,kk,k)
5858         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5859         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5860         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5861         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5862       enddo
5863       do m=i,j-1
5864         do ll=1,3
5865           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5866         enddo
5867       enddo
5868       do m=k,l-1
5869         do ll=1,3
5870           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5871         enddo
5872       enddo
5873       esccorr=-eij*ekl
5874       return
5875       end function esccorr
5876 !-----------------------------------------------------------------------------
5877       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5878 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5879 !      implicit real*8 (a-h,o-z)
5880 !      include 'DIMENSIONS'
5881 !      include 'COMMON.IOUNITS'
5882 #ifdef MPI
5883       include "mpif.h"
5884 !      integer :: maxconts !max_cont=maxconts  =nres/4
5885       integer,parameter :: max_dim=26
5886       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5887       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5888 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5889 !el      common /przechowalnia/ zapas
5890       integer :: status(MPI_STATUS_SIZE)
5891       integer,dimension((nres/4)*2) :: req !maxconts*2
5892       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5893 #endif
5894 !      include 'COMMON.SETUP'
5895 !      include 'COMMON.FFIELD'
5896 !      include 'COMMON.DERIV'
5897 !      include 'COMMON.INTERACT'
5898 !      include 'COMMON.CONTACTS'
5899 !      include 'COMMON.CONTROL'
5900 !      include 'COMMON.LOCAL'
5901       real(kind=8),dimension(3) :: gx,gx1
5902       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5903       logical :: lprn,ldone
5904 !el local variables
5905       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5906               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5907
5908 ! Set lprn=.true. for debugging
5909       lprn=.false.
5910 #ifdef MPI
5911 !      maxconts=nres/4
5912       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
5913       n_corr=0
5914       n_corr1=0
5915       if (nfgtasks.le.1) goto 30
5916       if (lprn) then
5917         write (iout,'(a)') 'Contact function values before RECEIVE:'
5918         do i=nnt,nct-2
5919           write (iout,'(2i3,50(1x,i2,f5.2))') &
5920           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
5921           j=1,num_cont_hb(i))
5922         enddo
5923       endif
5924       call flush(iout)
5925       do i=1,ntask_cont_from
5926         ncont_recv(i)=0
5927       enddo
5928       do i=1,ntask_cont_to
5929         ncont_sent(i)=0
5930       enddo
5931 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5932 !     & ntask_cont_to
5933 ! Make the list of contacts to send to send to other procesors
5934 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5935 !      call flush(iout)
5936       do i=iturn3_start,iturn3_end
5937 !        write (iout,*) "make contact list turn3",i," num_cont",
5938 !     &    num_cont_hb(i)
5939         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5940       enddo
5941       do i=iturn4_start,iturn4_end
5942 !        write (iout,*) "make contact list turn4",i," num_cont",
5943 !     &   num_cont_hb(i)
5944         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5945       enddo
5946       do ii=1,nat_sent
5947         i=iat_sent(ii)
5948 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
5949 !     &    num_cont_hb(i)
5950         do j=1,num_cont_hb(i)
5951         do k=1,4
5952           jjc=jcont_hb(j,i)
5953           iproc=iint_sent_local(k,jjc,ii)
5954 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5955           if (iproc.gt.0) then
5956             ncont_sent(iproc)=ncont_sent(iproc)+1
5957             nn=ncont_sent(iproc)
5958             zapas(1,nn,iproc)=i
5959             zapas(2,nn,iproc)=jjc
5960             zapas(3,nn,iproc)=facont_hb(j,i)
5961             zapas(4,nn,iproc)=ees0p(j,i)
5962             zapas(5,nn,iproc)=ees0m(j,i)
5963             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5964             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5965             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5966             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5967             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5968             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5969             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5970             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5971             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5972             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5973             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5974             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5975             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5976             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5977             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5978             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5979             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5980             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5981             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5982             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5983             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5984           endif
5985         enddo
5986         enddo
5987       enddo
5988       if (lprn) then
5989       write (iout,*) &
5990         "Numbers of contacts to be sent to other processors",&
5991         (ncont_sent(i),i=1,ntask_cont_to)
5992       write (iout,*) "Contacts sent"
5993       do ii=1,ntask_cont_to
5994         nn=ncont_sent(ii)
5995         iproc=itask_cont_to(ii)
5996         write (iout,*) nn," contacts to processor",iproc,&
5997          " of CONT_TO_COMM group"
5998         do i=1,nn
5999           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6000         enddo
6001       enddo
6002       call flush(iout)
6003       endif
6004       CorrelType=477
6005       CorrelID=fg_rank+1
6006       CorrelType1=478
6007       CorrelID1=nfgtasks+fg_rank+1
6008       ireq=0
6009 ! Receive the numbers of needed contacts from other processors
6010       do ii=1,ntask_cont_from
6011         iproc=itask_cont_from(ii)
6012         ireq=ireq+1
6013         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6014           FG_COMM,req(ireq),IERR)
6015       enddo
6016 !      write (iout,*) "IRECV ended"
6017 !      call flush(iout)
6018 ! Send the number of contacts needed by other processors
6019       do ii=1,ntask_cont_to
6020         iproc=itask_cont_to(ii)
6021         ireq=ireq+1
6022         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6023           FG_COMM,req(ireq),IERR)
6024       enddo
6025 !      write (iout,*) "ISEND ended"
6026 !      write (iout,*) "number of requests (nn)",ireq
6027       call flush(iout)
6028       if (ireq.gt.0) &
6029         call MPI_Waitall(ireq,req,status_array,ierr)
6030 !      write (iout,*)
6031 !     &  "Numbers of contacts to be received from other processors",
6032 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6033 !      call flush(iout)
6034 ! Receive contacts
6035       ireq=0
6036       do ii=1,ntask_cont_from
6037         iproc=itask_cont_from(ii)
6038         nn=ncont_recv(ii)
6039 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6040 !     &   " of CONT_TO_COMM group"
6041         call flush(iout)
6042         if (nn.gt.0) then
6043           ireq=ireq+1
6044           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6045           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6046 !          write (iout,*) "ireq,req",ireq,req(ireq)
6047         endif
6048       enddo
6049 ! Send the contacts to processors that need them
6050       do ii=1,ntask_cont_to
6051         iproc=itask_cont_to(ii)
6052         nn=ncont_sent(ii)
6053 !        write (iout,*) nn," contacts to processor",iproc,
6054 !     &   " of CONT_TO_COMM group"
6055         if (nn.gt.0) then
6056           ireq=ireq+1
6057           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6058             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6059 !          write (iout,*) "ireq,req",ireq,req(ireq)
6060 !          do i=1,nn
6061 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6062 !          enddo
6063         endif
6064       enddo
6065 !      write (iout,*) "number of requests (contacts)",ireq
6066 !      write (iout,*) "req",(req(i),i=1,4)
6067 !      call flush(iout)
6068       if (ireq.gt.0) &
6069        call MPI_Waitall(ireq,req,status_array,ierr)
6070       do iii=1,ntask_cont_from
6071         iproc=itask_cont_from(iii)
6072         nn=ncont_recv(iii)
6073         if (lprn) then
6074         write (iout,*) "Received",nn," contacts from processor",iproc,&
6075          " of CONT_FROM_COMM group"
6076         call flush(iout)
6077         do i=1,nn
6078           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6079         enddo
6080         call flush(iout)
6081         endif
6082         do i=1,nn
6083           ii=zapas_recv(1,i,iii)
6084 ! Flag the received contacts to prevent double-counting
6085           jj=-zapas_recv(2,i,iii)
6086 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6087 !          call flush(iout)
6088           nnn=num_cont_hb(ii)+1
6089           num_cont_hb(ii)=nnn
6090           jcont_hb(nnn,ii)=jj
6091           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6092           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6093           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6094           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6095           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6096           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6097           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6098           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6099           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6100           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6101           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6102           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6103           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6104           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6105           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6106           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6107           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6108           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6109           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6110           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6111           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6112           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6113           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6114           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6115         enddo
6116       enddo
6117       call flush(iout)
6118       if (lprn) then
6119         write (iout,'(a)') 'Contact function values after receive:'
6120         do i=nnt,nct-2
6121           write (iout,'(2i3,50(1x,i3,f5.2))') &
6122           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6123           j=1,num_cont_hb(i))
6124         enddo
6125         call flush(iout)
6126       endif
6127    30 continue
6128 #endif
6129       if (lprn) then
6130         write (iout,'(a)') 'Contact function values:'
6131         do i=nnt,nct-2
6132           write (iout,'(2i3,50(1x,i3,f5.2))') &
6133           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6134           j=1,num_cont_hb(i))
6135         enddo
6136       endif
6137       ecorr=0.0D0
6138
6139 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6140 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6141 ! Remove the loop below after debugging !!!
6142       do i=nnt,nct
6143         do j=1,3
6144           gradcorr(j,i)=0.0D0
6145           gradxorr(j,i)=0.0D0
6146         enddo
6147       enddo
6148 ! Calculate the local-electrostatic correlation terms
6149       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6150         i1=i+1
6151         num_conti=num_cont_hb(i)
6152         num_conti1=num_cont_hb(i+1)
6153         do jj=1,num_conti
6154           j=jcont_hb(jj,i)
6155           jp=iabs(j)
6156           do kk=1,num_conti1
6157             j1=jcont_hb(kk,i1)
6158             jp1=iabs(j1)
6159 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6160 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6161             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6162                 .or. j.lt.0 .and. j1.gt.0) .and. &
6163                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6164 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6165 ! The system gains extra energy.
6166               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6167               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6168                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6169               n_corr=n_corr+1
6170             else if (j1.eq.j) then
6171 ! Contacts I-J and I-(J+1) occur simultaneously.
6172 ! The system loses extra energy.
6173 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6174             endif
6175           enddo ! kk
6176           do kk=1,num_conti
6177             j1=jcont_hb(kk,i)
6178 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6179 !    &         ' jj=',jj,' kk=',kk
6180             if (j1.eq.j+1) then
6181 ! Contacts I-J and (I+1)-J occur simultaneously.
6182 ! The system loses extra energy.
6183 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6184             endif ! j1==j+1
6185           enddo ! kk
6186         enddo ! jj
6187       enddo ! i
6188       return
6189       end subroutine multibody_hb
6190 !-----------------------------------------------------------------------------
6191       subroutine add_hb_contact(ii,jj,itask)
6192 !      implicit real*8 (a-h,o-z)
6193 !      include "DIMENSIONS"
6194 !      include "COMMON.IOUNITS"
6195 !      include "COMMON.CONTACTS"
6196 !      integer,parameter :: maxconts=nres/4
6197       integer,parameter :: max_dim=26
6198       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6199 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6200 !      common /przechowalnia/ zapas
6201       integer :: i,j,ii,jj,iproc,nn,jjc
6202       integer,dimension(4) :: itask
6203 !      write (iout,*) "itask",itask
6204       do i=1,2
6205         iproc=itask(i)
6206         if (iproc.gt.0) then
6207           do j=1,num_cont_hb(ii)
6208             jjc=jcont_hb(j,ii)
6209 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6210             if (jjc.eq.jj) then
6211               ncont_sent(iproc)=ncont_sent(iproc)+1
6212               nn=ncont_sent(iproc)
6213               zapas(1,nn,iproc)=ii
6214               zapas(2,nn,iproc)=jjc
6215               zapas(3,nn,iproc)=facont_hb(j,ii)
6216               zapas(4,nn,iproc)=ees0p(j,ii)
6217               zapas(5,nn,iproc)=ees0m(j,ii)
6218               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6219               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6220               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6221               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6222               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6223               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6224               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6225               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6226               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6227               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6228               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6229               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6230               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6231               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6232               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6233               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6234               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6235               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6236               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6237               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6238               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6239               exit
6240             endif
6241           enddo
6242         endif
6243       enddo
6244       return
6245       end subroutine add_hb_contact
6246 !-----------------------------------------------------------------------------
6247       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6248 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6249 !      implicit real*8 (a-h,o-z)
6250 !      include 'DIMENSIONS'
6251 !      include 'COMMON.IOUNITS'
6252       integer,parameter :: max_dim=70
6253 #ifdef MPI
6254       include "mpif.h"
6255 !      integer :: maxconts !max_cont=maxconts=nres/4
6256       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6257       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6258 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6259 !      common /przechowalnia/ zapas
6260       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6261         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6262         ierr,iii,nnn
6263 #endif
6264 !      include 'COMMON.SETUP'
6265 !      include 'COMMON.FFIELD'
6266 !      include 'COMMON.DERIV'
6267 !      include 'COMMON.LOCAL'
6268 !      include 'COMMON.INTERACT'
6269 !      include 'COMMON.CONTACTS'
6270 !      include 'COMMON.CHAIN'
6271 !      include 'COMMON.CONTROL'
6272       real(kind=8),dimension(3) :: gx,gx1
6273       integer,dimension(nres) :: num_cont_hb_old
6274       logical :: lprn,ldone
6275 !EL      double precision eello4,eello5,eelo6,eello_turn6
6276 !EL      external eello4,eello5,eello6,eello_turn6
6277 !el local variables
6278       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6279               j1,jp1,i1,num_conti1
6280       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6281       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6282
6283 ! Set lprn=.true. for debugging
6284       lprn=.false.
6285       eturn6=0.0d0
6286 #ifdef MPI
6287 !      maxconts=nres/4
6288       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6289       do i=1,nres
6290         num_cont_hb_old(i)=num_cont_hb(i)
6291       enddo
6292       n_corr=0
6293       n_corr1=0
6294       if (nfgtasks.le.1) goto 30
6295       if (lprn) then
6296         write (iout,'(a)') 'Contact function values before RECEIVE:'
6297         do i=nnt,nct-2
6298           write (iout,'(2i3,50(1x,i2,f5.2))') &
6299           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6300           j=1,num_cont_hb(i))
6301         enddo
6302       endif
6303       call flush(iout)
6304       do i=1,ntask_cont_from
6305         ncont_recv(i)=0
6306       enddo
6307       do i=1,ntask_cont_to
6308         ncont_sent(i)=0
6309       enddo
6310 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6311 !     & ntask_cont_to
6312 ! Make the list of contacts to send to send to other procesors
6313       do i=iturn3_start,iturn3_end
6314 !        write (iout,*) "make contact list turn3",i," num_cont",
6315 !     &    num_cont_hb(i)
6316         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6317       enddo
6318       do i=iturn4_start,iturn4_end
6319 !        write (iout,*) "make contact list turn4",i," num_cont",
6320 !     &   num_cont_hb(i)
6321         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6322       enddo
6323       do ii=1,nat_sent
6324         i=iat_sent(ii)
6325 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6326 !     &    num_cont_hb(i)
6327         do j=1,num_cont_hb(i)
6328         do k=1,4
6329           jjc=jcont_hb(j,i)
6330           iproc=iint_sent_local(k,jjc,ii)
6331 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6332           if (iproc.ne.0) then
6333             ncont_sent(iproc)=ncont_sent(iproc)+1
6334             nn=ncont_sent(iproc)
6335             zapas(1,nn,iproc)=i
6336             zapas(2,nn,iproc)=jjc
6337             zapas(3,nn,iproc)=d_cont(j,i)
6338             ind=3
6339             do kk=1,3
6340               ind=ind+1
6341               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6342             enddo
6343             do kk=1,2
6344               do ll=1,2
6345                 ind=ind+1
6346                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6347               enddo
6348             enddo
6349             do jj=1,5
6350               do kk=1,3
6351                 do ll=1,2
6352                   do mm=1,2
6353                     ind=ind+1
6354                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6355                   enddo
6356                 enddo
6357               enddo
6358             enddo
6359           endif
6360         enddo
6361         enddo
6362       enddo
6363       if (lprn) then
6364       write (iout,*) &
6365         "Numbers of contacts to be sent to other processors",&
6366         (ncont_sent(i),i=1,ntask_cont_to)
6367       write (iout,*) "Contacts sent"
6368       do ii=1,ntask_cont_to
6369         nn=ncont_sent(ii)
6370         iproc=itask_cont_to(ii)
6371         write (iout,*) nn," contacts to processor",iproc,&
6372          " of CONT_TO_COMM group"
6373         do i=1,nn
6374           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6375         enddo
6376       enddo
6377       call flush(iout)
6378       endif
6379       CorrelType=477
6380       CorrelID=fg_rank+1
6381       CorrelType1=478
6382       CorrelID1=nfgtasks+fg_rank+1
6383       ireq=0
6384 ! Receive the numbers of needed contacts from other processors
6385       do ii=1,ntask_cont_from
6386         iproc=itask_cont_from(ii)
6387         ireq=ireq+1
6388         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6389           FG_COMM,req(ireq),IERR)
6390       enddo
6391 !      write (iout,*) "IRECV ended"
6392 !      call flush(iout)
6393 ! Send the number of contacts needed by other processors
6394       do ii=1,ntask_cont_to
6395         iproc=itask_cont_to(ii)
6396         ireq=ireq+1
6397         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6398           FG_COMM,req(ireq),IERR)
6399       enddo
6400 !      write (iout,*) "ISEND ended"
6401 !      write (iout,*) "number of requests (nn)",ireq
6402       call flush(iout)
6403       if (ireq.gt.0) &
6404         call MPI_Waitall(ireq,req,status_array,ierr)
6405 !      write (iout,*)
6406 !     &  "Numbers of contacts to be received from other processors",
6407 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6408 !      call flush(iout)
6409 ! Receive contacts
6410       ireq=0
6411       do ii=1,ntask_cont_from
6412         iproc=itask_cont_from(ii)
6413         nn=ncont_recv(ii)
6414 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6415 !     &   " of CONT_TO_COMM group"
6416         call flush(iout)
6417         if (nn.gt.0) then
6418           ireq=ireq+1
6419           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6420           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6421 !          write (iout,*) "ireq,req",ireq,req(ireq)
6422         endif
6423       enddo
6424 ! Send the contacts to processors that need them
6425       do ii=1,ntask_cont_to
6426         iproc=itask_cont_to(ii)
6427         nn=ncont_sent(ii)
6428 !        write (iout,*) nn," contacts to processor",iproc,
6429 !     &   " of CONT_TO_COMM group"
6430         if (nn.gt.0) then
6431           ireq=ireq+1
6432           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6433             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6434 !          write (iout,*) "ireq,req",ireq,req(ireq)
6435 !          do i=1,nn
6436 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6437 !          enddo
6438         endif
6439       enddo
6440 !      write (iout,*) "number of requests (contacts)",ireq
6441 !      write (iout,*) "req",(req(i),i=1,4)
6442 !      call flush(iout)
6443       if (ireq.gt.0) &
6444        call MPI_Waitall(ireq,req,status_array,ierr)
6445       do iii=1,ntask_cont_from
6446         iproc=itask_cont_from(iii)
6447         nn=ncont_recv(iii)
6448         if (lprn) then
6449         write (iout,*) "Received",nn," contacts from processor",iproc,&
6450          " of CONT_FROM_COMM group"
6451         call flush(iout)
6452         do i=1,nn
6453           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6454         enddo
6455         call flush(iout)
6456         endif
6457         do i=1,nn
6458           ii=zapas_recv(1,i,iii)
6459 ! Flag the received contacts to prevent double-counting
6460           jj=-zapas_recv(2,i,iii)
6461 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6462 !          call flush(iout)
6463           nnn=num_cont_hb(ii)+1
6464           num_cont_hb(ii)=nnn
6465           jcont_hb(nnn,ii)=jj
6466           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6467           ind=3
6468           do kk=1,3
6469             ind=ind+1
6470             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6471           enddo
6472           do kk=1,2
6473             do ll=1,2
6474               ind=ind+1
6475               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6476             enddo
6477           enddo
6478           do jj=1,5
6479             do kk=1,3
6480               do ll=1,2
6481                 do mm=1,2
6482                   ind=ind+1
6483                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6484                 enddo
6485               enddo
6486             enddo
6487           enddo
6488         enddo
6489       enddo
6490       call flush(iout)
6491       if (lprn) then
6492         write (iout,'(a)') 'Contact function values after receive:'
6493         do i=nnt,nct-2
6494           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6495           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6496           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6497         enddo
6498         call flush(iout)
6499       endif
6500    30 continue
6501 #endif
6502       if (lprn) then
6503         write (iout,'(a)') 'Contact function values:'
6504         do i=nnt,nct-2
6505           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6506           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6507           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6508         enddo
6509       endif
6510       ecorr=0.0D0
6511       ecorr5=0.0d0
6512       ecorr6=0.0d0
6513
6514 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6515 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6516 ! Remove the loop below after debugging !!!
6517       do i=nnt,nct
6518         do j=1,3
6519           gradcorr(j,i)=0.0D0
6520           gradxorr(j,i)=0.0D0
6521         enddo
6522       enddo
6523 ! Calculate the dipole-dipole interaction energies
6524       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6525       do i=iatel_s,iatel_e+1
6526         num_conti=num_cont_hb(i)
6527         do jj=1,num_conti
6528           j=jcont_hb(jj,i)
6529 #ifdef MOMENT
6530           call dipole(i,j,jj)
6531 #endif
6532         enddo
6533       enddo
6534       endif
6535 ! Calculate the local-electrostatic correlation terms
6536 !                write (iout,*) "gradcorr5 in eello5 before loop"
6537 !                do iii=1,nres
6538 !                  write (iout,'(i5,3f10.5)')
6539 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6540 !                enddo
6541       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6542 !        write (iout,*) "corr loop i",i
6543         i1=i+1
6544         num_conti=num_cont_hb(i)
6545         num_conti1=num_cont_hb(i+1)
6546         do jj=1,num_conti
6547           j=jcont_hb(jj,i)
6548           jp=iabs(j)
6549           do kk=1,num_conti1
6550             j1=jcont_hb(kk,i1)
6551             jp1=iabs(j1)
6552 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6553 !     &         ' jj=',jj,' kk=',kk
6554 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6555             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6556                 .or. j.lt.0 .and. j1.gt.0) .and. &
6557                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6558 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6559 ! The system gains extra energy.
6560               n_corr=n_corr+1
6561               sqd1=dsqrt(d_cont(jj,i))
6562               sqd2=dsqrt(d_cont(kk,i1))
6563               sred_geom = sqd1*sqd2
6564               IF (sred_geom.lt.cutoff_corr) THEN
6565                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6566                   ekont,fprimcont)
6567 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6568 !d     &         ' jj=',jj,' kk=',kk
6569                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6570                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6571                 do l=1,3
6572                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6573                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6574                 enddo
6575                 n_corr1=n_corr1+1
6576 !d               write (iout,*) 'sred_geom=',sred_geom,
6577 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6578 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6579 !d               write (iout,*) "g_contij",g_contij
6580 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6581 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6582                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6583                 if (wcorr4.gt.0.0d0) &
6584                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6585                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6586                        write (iout,'(a6,4i5,0pf7.3)') &
6587                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6588 !                write (iout,*) "gradcorr5 before eello5"
6589 !                do iii=1,nres
6590 !                  write (iout,'(i5,3f10.5)')
6591 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6592 !                enddo
6593                 if (wcorr5.gt.0.0d0) &
6594                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6595 !                write (iout,*) "gradcorr5 after eello5"
6596 !                do iii=1,nres
6597 !                  write (iout,'(i5,3f10.5)')
6598 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6599 !                enddo
6600                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6601                        write (iout,'(a6,4i5,0pf7.3)') &
6602                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6603 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6604 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6605                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6606                      .or. wturn6.eq.0.0d0))then
6607 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6608                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6609                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6610                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6611 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6612 !d     &            'ecorr6=',ecorr6
6613 !d                write (iout,'(4e15.5)') sred_geom,
6614 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6615 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6616 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6617                 else if (wturn6.gt.0.0d0 &
6618                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6619 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6620                   eturn6=eturn6+eello_turn6(i,jj,kk)
6621                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6622                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6623 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6624                 endif
6625               ENDIF
6626 1111          continue
6627             endif
6628           enddo ! kk
6629         enddo ! jj
6630       enddo ! i
6631       do i=1,nres
6632         num_cont_hb(i)=num_cont_hb_old(i)
6633       enddo
6634 !                write (iout,*) "gradcorr5 in eello5"
6635 !                do iii=1,nres
6636 !                  write (iout,'(i5,3f10.5)')
6637 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6638 !                enddo
6639       return
6640       end subroutine multibody_eello
6641 !-----------------------------------------------------------------------------
6642       subroutine add_hb_contact_eello(ii,jj,itask)
6643 !      implicit real*8 (a-h,o-z)
6644 !      include "DIMENSIONS"
6645 !      include "COMMON.IOUNITS"
6646 !      include "COMMON.CONTACTS"
6647 !      integer,parameter :: maxconts=nres/4
6648       integer,parameter :: max_dim=70
6649       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6650 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6651 !      common /przechowalnia/ zapas
6652
6653       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6654       integer,dimension(4) ::itask
6655 !      write (iout,*) "itask",itask
6656       do i=1,2
6657         iproc=itask(i)
6658         if (iproc.gt.0) then
6659           do j=1,num_cont_hb(ii)
6660             jjc=jcont_hb(j,ii)
6661 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6662             if (jjc.eq.jj) then
6663               ncont_sent(iproc)=ncont_sent(iproc)+1
6664               nn=ncont_sent(iproc)
6665               zapas(1,nn,iproc)=ii
6666               zapas(2,nn,iproc)=jjc
6667               zapas(3,nn,iproc)=d_cont(j,ii)
6668               ind=3
6669               do kk=1,3
6670                 ind=ind+1
6671                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6672               enddo
6673               do kk=1,2
6674                 do ll=1,2
6675                   ind=ind+1
6676                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6677                 enddo
6678               enddo
6679               do jj=1,5
6680                 do kk=1,3
6681                   do ll=1,2
6682                     do mm=1,2
6683                       ind=ind+1
6684                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6685                     enddo
6686                   enddo
6687                 enddo
6688               enddo
6689               exit
6690             endif
6691           enddo
6692         endif
6693       enddo
6694       return
6695       end subroutine add_hb_contact_eello
6696 !-----------------------------------------------------------------------------
6697       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6698 !      implicit real*8 (a-h,o-z)
6699 !      include 'DIMENSIONS'
6700 !      include 'COMMON.IOUNITS'
6701 !      include 'COMMON.DERIV'
6702 !      include 'COMMON.INTERACT'
6703 !      include 'COMMON.CONTACTS'
6704       real(kind=8),dimension(3) :: gx,gx1
6705       logical :: lprn
6706 !el local variables
6707       integer :: i,j,k,l,jj,kk,ll
6708       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6709                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6710                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6711
6712       lprn=.false.
6713       eij=facont_hb(jj,i)
6714       ekl=facont_hb(kk,k)
6715       ees0pij=ees0p(jj,i)
6716       ees0pkl=ees0p(kk,k)
6717       ees0mij=ees0m(jj,i)
6718       ees0mkl=ees0m(kk,k)
6719       ekont=eij*ekl
6720       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6721 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6722 ! Following 4 lines for diagnostics.
6723 !d    ees0pkl=0.0D0
6724 !d    ees0pij=1.0D0
6725 !d    ees0mkl=0.0D0
6726 !d    ees0mij=1.0D0
6727 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6728 !     & 'Contacts ',i,j,
6729 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6730 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6731 !     & 'gradcorr_long'
6732 ! Calculate the multi-body contribution to energy.
6733 !      ecorr=ecorr+ekont*ees
6734 ! Calculate multi-body contributions to the gradient.
6735       coeffpees0pij=coeffp*ees0pij
6736       coeffmees0mij=coeffm*ees0mij
6737       coeffpees0pkl=coeffp*ees0pkl
6738       coeffmees0mkl=coeffm*ees0mkl
6739       do ll=1,3
6740 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6741         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6742         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6743         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6744         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6745         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6746         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6747 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6748         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6749         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6750         coeffmees0mij*gacontm_hb1(ll,kk,k))
6751         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6752         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6753         coeffmees0mij*gacontm_hb2(ll,kk,k))
6754         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6755            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6756            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6757         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6758         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6759         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6760            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6761            coeffmees0mij*gacontm_hb3(ll,kk,k))
6762         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6763         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6764 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6765       enddo
6766 !      write (iout,*)
6767 !grad      do m=i+1,j-1
6768 !grad        do ll=1,3
6769 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6770 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6771 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6772 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6773 !grad        enddo
6774 !grad      enddo
6775 !grad      do m=k+1,l-1
6776 !grad        do ll=1,3
6777 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6778 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6779 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6780 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6781 !grad        enddo
6782 !grad      enddo
6783 !      write (iout,*) "ehbcorr",ekont*ees
6784       ehbcorr=ekont*ees
6785       return
6786       end function ehbcorr
6787 #ifdef MOMENT
6788 !-----------------------------------------------------------------------------
6789       subroutine dipole(i,j,jj)
6790 !      implicit real*8 (a-h,o-z)
6791 !      include 'DIMENSIONS'
6792 !      include 'COMMON.IOUNITS'
6793 !      include 'COMMON.CHAIN'
6794 !      include 'COMMON.FFIELD'
6795 !      include 'COMMON.DERIV'
6796 !      include 'COMMON.INTERACT'
6797 !      include 'COMMON.CONTACTS'
6798 !      include 'COMMON.TORSION'
6799 !      include 'COMMON.VAR'
6800 !      include 'COMMON.GEO'
6801       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6802       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6803       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6804
6805       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6806       allocate(dipderx(3,5,4,maxconts,nres))
6807 !
6808
6809       iti1 = itortyp(itype(i+1))
6810       if (j.lt.nres-1) then
6811         itj1 = itortyp(itype(j+1))
6812       else
6813         itj1=ntortyp+1
6814       endif
6815       do iii=1,2
6816         dipi(iii,1)=Ub2(iii,i)
6817         dipderi(iii)=Ub2der(iii,i)
6818         dipi(iii,2)=b1(iii,iti1)
6819         dipj(iii,1)=Ub2(iii,j)
6820         dipderj(iii)=Ub2der(iii,j)
6821         dipj(iii,2)=b1(iii,itj1)
6822       enddo
6823       kkk=0
6824       do iii=1,2
6825         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6826         do jjj=1,2
6827           kkk=kkk+1
6828           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6829         enddo
6830       enddo
6831       do kkk=1,5
6832         do lll=1,3
6833           mmm=0
6834           do iii=1,2
6835             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6836               auxvec(1))
6837             do jjj=1,2
6838               mmm=mmm+1
6839               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6840             enddo
6841           enddo
6842         enddo
6843       enddo
6844       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6845       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6846       do iii=1,2
6847         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6848       enddo
6849       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6850       do iii=1,2
6851         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6852       enddo
6853       return
6854       end subroutine dipole
6855 #endif
6856 !-----------------------------------------------------------------------------
6857       subroutine calc_eello(i,j,k,l,jj,kk)
6858 !
6859 ! This subroutine computes matrices and vectors needed to calculate
6860 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6861 !
6862       use comm_kut
6863 !      implicit real*8 (a-h,o-z)
6864 !      include 'DIMENSIONS'
6865 !      include 'COMMON.IOUNITS'
6866 !      include 'COMMON.CHAIN'
6867 !      include 'COMMON.DERIV'
6868 !      include 'COMMON.INTERACT'
6869 !      include 'COMMON.CONTACTS'
6870 !      include 'COMMON.TORSION'
6871 !      include 'COMMON.VAR'
6872 !      include 'COMMON.GEO'
6873 !      include 'COMMON.FFIELD'
6874       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6875       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6876       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6877               itj1
6878 !el      logical :: lprn
6879 !el      common /kutas/ lprn
6880 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6881 !d     & ' jj=',jj,' kk=',kk
6882 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6883 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6884 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6885       do iii=1,2
6886         do jjj=1,2
6887           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6888           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6889         enddo
6890       enddo
6891       call transpose2(aa1(1,1),aa1t(1,1))
6892       call transpose2(aa2(1,1),aa2t(1,1))
6893       do kkk=1,5
6894         do lll=1,3
6895           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6896             aa1tder(1,1,lll,kkk))
6897           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6898             aa2tder(1,1,lll,kkk))
6899         enddo
6900       enddo
6901       if (l.eq.j+1) then
6902 ! parallel orientation of the two CA-CA-CA frames.
6903         if (i.gt.1) then
6904           iti=itortyp(itype(i))
6905         else
6906           iti=ntortyp+1
6907         endif
6908         itk1=itortyp(itype(k+1))
6909         itj=itortyp(itype(j))
6910         if (l.lt.nres-1) then
6911           itl1=itortyp(itype(l+1))
6912         else
6913           itl1=ntortyp+1
6914         endif
6915 ! A1 kernel(j+1) A2T
6916 !d        do iii=1,2
6917 !d          write (iout,'(3f10.5,5x,3f10.5)')
6918 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6919 !d        enddo
6920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6921          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
6922          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6923 ! Following matrices are needed only for 6-th order cumulants
6924         IF (wcorr6.gt.0.0d0) THEN
6925         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6926          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
6927          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6929          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
6930          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
6931          ADtEAderx(1,1,1,1,1,1))
6932         lprn=.false.
6933         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6934          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
6935          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
6936          ADtEA1derx(1,1,1,1,1,1))
6937         ENDIF
6938 ! End 6-th order cumulants
6939 !d        lprn=.false.
6940 !d        if (lprn) then
6941 !d        write (2,*) 'In calc_eello6'
6942 !d        do iii=1,2
6943 !d          write (2,*) 'iii=',iii
6944 !d          do kkk=1,5
6945 !d            write (2,*) 'kkk=',kkk
6946 !d            do jjj=1,2
6947 !d              write (2,'(3(2f10.5),5x)')
6948 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6949 !d            enddo
6950 !d          enddo
6951 !d        enddo
6952 !d        endif
6953         call transpose2(EUgder(1,1,k),auxmat(1,1))
6954         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6955         call transpose2(EUg(1,1,k),auxmat(1,1))
6956         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6957         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6958         do iii=1,2
6959           do kkk=1,5
6960             do lll=1,3
6961               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
6962                 EAEAderx(1,1,lll,kkk,iii,1))
6963             enddo
6964           enddo
6965         enddo
6966 ! A1T kernel(i+1) A2
6967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6968          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
6969          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6970 ! Following matrices are needed only for 6-th order cumulants
6971         IF (wcorr6.gt.0.0d0) THEN
6972         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6973          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
6974          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6975         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6976          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
6977          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
6978          ADtEAderx(1,1,1,1,1,2))
6979         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6980          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
6981          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
6982          ADtEA1derx(1,1,1,1,1,2))
6983         ENDIF
6984 ! End 6-th order cumulants
6985         call transpose2(EUgder(1,1,l),auxmat(1,1))
6986         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6987         call transpose2(EUg(1,1,l),auxmat(1,1))
6988         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6989         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6990         do iii=1,2
6991           do kkk=1,5
6992             do lll=1,3
6993               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
6994                 EAEAderx(1,1,lll,kkk,iii,2))
6995             enddo
6996           enddo
6997         enddo
6998 ! AEAb1 and AEAb2
6999 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7000 ! They are needed only when the fifth- or the sixth-order cumulants are
7001 ! indluded.
7002         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7003         call transpose2(AEA(1,1,1),auxmat(1,1))
7004         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7005         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7006         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7007         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7008         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7009         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7010         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7011         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7012         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7013         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7014         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7015         call transpose2(AEA(1,1,2),auxmat(1,1))
7016         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7017         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7018         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7019         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7020         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7021         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7022         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7023         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7024         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7025         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7026         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7027 ! Calculate the Cartesian derivatives of the vectors.
7028         do iii=1,2
7029           do kkk=1,5
7030             do lll=1,3
7031               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7032               call matvec2(auxmat(1,1),b1(1,iti),&
7033                 AEAb1derx(1,lll,kkk,iii,1,1))
7034               call matvec2(auxmat(1,1),Ub2(1,i),&
7035                 AEAb2derx(1,lll,kkk,iii,1,1))
7036               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7037                 AEAb1derx(1,lll,kkk,iii,2,1))
7038               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7039                 AEAb2derx(1,lll,kkk,iii,2,1))
7040               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7041               call matvec2(auxmat(1,1),b1(1,itj),&
7042                 AEAb1derx(1,lll,kkk,iii,1,2))
7043               call matvec2(auxmat(1,1),Ub2(1,j),&
7044                 AEAb2derx(1,lll,kkk,iii,1,2))
7045               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7046                 AEAb1derx(1,lll,kkk,iii,2,2))
7047               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7048                 AEAb2derx(1,lll,kkk,iii,2,2))
7049             enddo
7050           enddo
7051         enddo
7052         ENDIF
7053 ! End vectors
7054       else
7055 ! Antiparallel orientation of the two CA-CA-CA frames.
7056         if (i.gt.1) then
7057           iti=itortyp(itype(i))
7058         else
7059           iti=ntortyp+1
7060         endif
7061         itk1=itortyp(itype(k+1))
7062         itl=itortyp(itype(l))
7063         itj=itortyp(itype(j))
7064         if (j.lt.nres-1) then
7065           itj1=itortyp(itype(j+1))
7066         else
7067           itj1=ntortyp+1
7068         endif
7069 ! A2 kernel(j-1)T A1T
7070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7071          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7072          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7073 ! Following matrices are needed only for 6-th order cumulants
7074         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7075            j.eq.i+4 .and. l.eq.i+3)) THEN
7076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7077          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7078          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7079         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7080          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7081          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7082          ADtEAderx(1,1,1,1,1,1))
7083         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7084          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7085          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7086          ADtEA1derx(1,1,1,1,1,1))
7087         ENDIF
7088 ! End 6-th order cumulants
7089         call transpose2(EUgder(1,1,k),auxmat(1,1))
7090         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7091         call transpose2(EUg(1,1,k),auxmat(1,1))
7092         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7093         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7094         do iii=1,2
7095           do kkk=1,5
7096             do lll=1,3
7097               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7098                 EAEAderx(1,1,lll,kkk,iii,1))
7099             enddo
7100           enddo
7101         enddo
7102 ! A2T kernel(i+1)T A1
7103         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7104          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7105          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7106 ! Following matrices are needed only for 6-th order cumulants
7107         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7108            j.eq.i+4 .and. l.eq.i+3)) THEN
7109         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7110          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7111          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7112         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7113          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7114          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7115          ADtEAderx(1,1,1,1,1,2))
7116         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7117          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7118          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7119          ADtEA1derx(1,1,1,1,1,2))
7120         ENDIF
7121 ! End 6-th order cumulants
7122         call transpose2(EUgder(1,1,j),auxmat(1,1))
7123         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7124         call transpose2(EUg(1,1,j),auxmat(1,1))
7125         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7126         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7127         do iii=1,2
7128           do kkk=1,5
7129             do lll=1,3
7130               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7131                 EAEAderx(1,1,lll,kkk,iii,2))
7132             enddo
7133           enddo
7134         enddo
7135 ! AEAb1 and AEAb2
7136 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7137 ! They are needed only when the fifth- or the sixth-order cumulants are
7138 ! indluded.
7139         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7140           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7141         call transpose2(AEA(1,1,1),auxmat(1,1))
7142         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7144         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7145         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7146         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7147         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7148         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7149         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7150         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7151         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7152         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7153         call transpose2(AEA(1,1,2),auxmat(1,1))
7154         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7155         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7156         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7157         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7158         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7159         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7160         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7161         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7162         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7163         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7164         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7165 ! Calculate the Cartesian derivatives of the vectors.
7166         do iii=1,2
7167           do kkk=1,5
7168             do lll=1,3
7169               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7170               call matvec2(auxmat(1,1),b1(1,iti),&
7171                 AEAb1derx(1,lll,kkk,iii,1,1))
7172               call matvec2(auxmat(1,1),Ub2(1,i),&
7173                 AEAb2derx(1,lll,kkk,iii,1,1))
7174               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7175                 AEAb1derx(1,lll,kkk,iii,2,1))
7176               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7177                 AEAb2derx(1,lll,kkk,iii,2,1))
7178               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7179               call matvec2(auxmat(1,1),b1(1,itl),&
7180                 AEAb1derx(1,lll,kkk,iii,1,2))
7181               call matvec2(auxmat(1,1),Ub2(1,l),&
7182                 AEAb2derx(1,lll,kkk,iii,1,2))
7183               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7184                 AEAb1derx(1,lll,kkk,iii,2,2))
7185               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7186                 AEAb2derx(1,lll,kkk,iii,2,2))
7187             enddo
7188           enddo
7189         enddo
7190         ENDIF
7191 ! End vectors
7192       endif
7193       return
7194       end subroutine calc_eello
7195 !-----------------------------------------------------------------------------
7196       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7197       use comm_kut
7198       implicit none
7199       integer :: nderg
7200       logical :: transp
7201       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7202       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7203       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7204       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7205       integer :: iii,kkk,lll
7206       integer :: jjj,mmm
7207 !el      logical :: lprn
7208 !el      common /kutas/ lprn
7209       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7210       do iii=1,nderg
7211         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7212           AKAderg(1,1,iii))
7213       enddo
7214 !d      if (lprn) write (2,*) 'In kernel'
7215       do kkk=1,5
7216 !d        if (lprn) write (2,*) 'kkk=',kkk
7217         do lll=1,3
7218           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7219             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7220 !d          if (lprn) then
7221 !d            write (2,*) 'lll=',lll
7222 !d            write (2,*) 'iii=1'
7223 !d            do jjj=1,2
7224 !d              write (2,'(3(2f10.5),5x)')
7225 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7226 !d            enddo
7227 !d          endif
7228           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7229             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7230 !d          if (lprn) then
7231 !d            write (2,*) 'lll=',lll
7232 !d            write (2,*) 'iii=2'
7233 !d            do jjj=1,2
7234 !d              write (2,'(3(2f10.5),5x)')
7235 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7236 !d            enddo
7237 !d          endif
7238         enddo
7239       enddo
7240       return
7241       end subroutine kernel
7242 !-----------------------------------------------------------------------------
7243       real(kind=8) function eello4(i,j,k,l,jj,kk)
7244 !      implicit real*8 (a-h,o-z)
7245 !      include 'DIMENSIONS'
7246 !      include 'COMMON.IOUNITS'
7247 !      include 'COMMON.CHAIN'
7248 !      include 'COMMON.DERIV'
7249 !      include 'COMMON.INTERACT'
7250 !      include 'COMMON.CONTACTS'
7251 !      include 'COMMON.TORSION'
7252 !      include 'COMMON.VAR'
7253 !      include 'COMMON.GEO'
7254       real(kind=8),dimension(2,2) :: pizda
7255       real(kind=8),dimension(3) :: ggg1,ggg2
7256       real(kind=8) ::  eel4,glongij,glongkl
7257       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7258 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7259 !d        eello4=0.0d0
7260 !d        return
7261 !d      endif
7262 !d      print *,'eello4:',i,j,k,l,jj,kk
7263 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7264 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7265 !old      eij=facont_hb(jj,i)
7266 !old      ekl=facont_hb(kk,k)
7267 !old      ekont=eij*ekl
7268       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7269 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7270       gcorr_loc(k-1)=gcorr_loc(k-1) &
7271          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7272       if (l.eq.j+1) then
7273         gcorr_loc(l-1)=gcorr_loc(l-1) &
7274            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7275       else
7276         gcorr_loc(j-1)=gcorr_loc(j-1) &
7277            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7278       endif
7279       do iii=1,2
7280         do kkk=1,5
7281           do lll=1,3
7282             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7283                               -EAEAderx(2,2,lll,kkk,iii,1)
7284 !d            derx(lll,kkk,iii)=0.0d0
7285           enddo
7286         enddo
7287       enddo
7288 !d      gcorr_loc(l-1)=0.0d0
7289 !d      gcorr_loc(j-1)=0.0d0
7290 !d      gcorr_loc(k-1)=0.0d0
7291 !d      eel4=1.0d0
7292 !d      write (iout,*)'Contacts have occurred for peptide groups',
7293 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7294 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7295       if (j.lt.nres-1) then
7296         j1=j+1
7297         j2=j-1
7298       else
7299         j1=j-1
7300         j2=j-2
7301       endif
7302       if (l.lt.nres-1) then
7303         l1=l+1
7304         l2=l-1
7305       else
7306         l1=l-1
7307         l2=l-2
7308       endif
7309       do ll=1,3
7310 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7311 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7312         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7313         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7314 !grad        ghalf=0.5d0*ggg1(ll)
7315         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7316         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7317         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7318         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7319         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7320         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7321 !grad        ghalf=0.5d0*ggg2(ll)
7322         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7323         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7324         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7325         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7326         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7327         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7328       enddo
7329 !grad      do m=i+1,j-1
7330 !grad        do ll=1,3
7331 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7332 !grad        enddo
7333 !grad      enddo
7334 !grad      do m=k+1,l-1
7335 !grad        do ll=1,3
7336 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7337 !grad        enddo
7338 !grad      enddo
7339 !grad      do m=i+2,j2
7340 !grad        do ll=1,3
7341 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7342 !grad        enddo
7343 !grad      enddo
7344 !grad      do m=k+2,l2
7345 !grad        do ll=1,3
7346 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7347 !grad        enddo
7348 !grad      enddo
7349 !d      do iii=1,nres-3
7350 !d        write (2,*) iii,gcorr_loc(iii)
7351 !d      enddo
7352       eello4=ekont*eel4
7353 !d      write (2,*) 'ekont',ekont
7354 !d      write (iout,*) 'eello4',ekont*eel4
7355       return
7356       end function eello4
7357 !-----------------------------------------------------------------------------
7358       real(kind=8) function eello5(i,j,k,l,jj,kk)
7359 !      implicit real*8 (a-h,o-z)
7360 !      include 'DIMENSIONS'
7361 !      include 'COMMON.IOUNITS'
7362 !      include 'COMMON.CHAIN'
7363 !      include 'COMMON.DERIV'
7364 !      include 'COMMON.INTERACT'
7365 !      include 'COMMON.CONTACTS'
7366 !      include 'COMMON.TORSION'
7367 !      include 'COMMON.VAR'
7368 !      include 'COMMON.GEO'
7369       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7370       real(kind=8),dimension(2) :: vv
7371       real(kind=8),dimension(3) :: ggg1,ggg2
7372       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7373       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7374       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7375 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7376 !                                                                              C
7377 !                            Parallel chains                                   C
7378 !                                                                              C
7379 !          o             o                   o             o                   C
7380 !         /l\           / \             \   / \           / \   /              C
7381 !        /   \         /   \             \ /   \         /   \ /               C
7382 !       j| o |l1       | o |              o| o |         | o |o                C
7383 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7384 !      \i/   \         /   \ /             /   \         /   \                 C
7385 !       o    k1             o                                                  C
7386 !         (I)          (II)                (III)          (IV)                 C
7387 !                                                                              C
7388 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7389 !                                                                              C
7390 !                            Antiparallel chains                               C
7391 !                                                                              C
7392 !          o             o                   o             o                   C
7393 !         /j\           / \             \   / \           / \   /              C
7394 !        /   \         /   \             \ /   \         /   \ /               C
7395 !      j1| o |l        | o |              o| o |         | o |o                C
7396 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7397 !      \i/   \         /   \ /             /   \         /   \                 C
7398 !       o     k1            o                                                  C
7399 !         (I)          (II)                (III)          (IV)                 C
7400 !                                                                              C
7401 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7402 !                                                                              C
7403 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7404 !                                                                              C
7405 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7406 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7407 !d        eello5=0.0d0
7408 !d        return
7409 !d      endif
7410 !d      write (iout,*)
7411 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7412 !d     &   ' and',k,l
7413       itk=itortyp(itype(k))
7414       itl=itortyp(itype(l))
7415       itj=itortyp(itype(j))
7416       eello5_1=0.0d0
7417       eello5_2=0.0d0
7418       eello5_3=0.0d0
7419       eello5_4=0.0d0
7420 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7421 !d     &   eel5_3_num,eel5_4_num)
7422       do iii=1,2
7423         do kkk=1,5
7424           do lll=1,3
7425             derx(lll,kkk,iii)=0.0d0
7426           enddo
7427         enddo
7428       enddo
7429 !d      eij=facont_hb(jj,i)
7430 !d      ekl=facont_hb(kk,k)
7431 !d      ekont=eij*ekl
7432 !d      write (iout,*)'Contacts have occurred for peptide groups',
7433 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7434 !d      goto 1111
7435 ! Contribution from the graph I.
7436 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7437 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7438       call transpose2(EUg(1,1,k),auxmat(1,1))
7439       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7440       vv(1)=pizda(1,1)-pizda(2,2)
7441       vv(2)=pizda(1,2)+pizda(2,1)
7442       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7443        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7444 ! Explicit gradient in virtual-dihedral angles.
7445       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7446        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7447        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7448       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7449       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7450       vv(1)=pizda(1,1)-pizda(2,2)
7451       vv(2)=pizda(1,2)+pizda(2,1)
7452       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7453        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7454        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7455       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7456       vv(1)=pizda(1,1)-pizda(2,2)
7457       vv(2)=pizda(1,2)+pizda(2,1)
7458       if (l.eq.j+1) then
7459         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7460          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7461          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7462       else
7463         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7464          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7465          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7466       endif
7467 ! Cartesian gradient
7468       do iii=1,2
7469         do kkk=1,5
7470           do lll=1,3
7471             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7472               pizda(1,1))
7473             vv(1)=pizda(1,1)-pizda(2,2)
7474             vv(2)=pizda(1,2)+pizda(2,1)
7475             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7476              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7477              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7478           enddo
7479         enddo
7480       enddo
7481 !      goto 1112
7482 !1111  continue
7483 ! Contribution from graph II
7484       call transpose2(EE(1,1,itk),auxmat(1,1))
7485       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7486       vv(1)=pizda(1,1)+pizda(2,2)
7487       vv(2)=pizda(2,1)-pizda(1,2)
7488       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7489        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7490 ! Explicit gradient in virtual-dihedral angles.
7491       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7492        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7493       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7494       vv(1)=pizda(1,1)+pizda(2,2)
7495       vv(2)=pizda(2,1)-pizda(1,2)
7496       if (l.eq.j+1) then
7497         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7498          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7499          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7500       else
7501         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7502          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7503          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7504       endif
7505 ! Cartesian gradient
7506       do iii=1,2
7507         do kkk=1,5
7508           do lll=1,3
7509             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7510               pizda(1,1))
7511             vv(1)=pizda(1,1)+pizda(2,2)
7512             vv(2)=pizda(2,1)-pizda(1,2)
7513             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7514              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7515              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7516           enddo
7517         enddo
7518       enddo
7519 !d      goto 1112
7520 !d1111  continue
7521       if (l.eq.j+1) then
7522 !d        goto 1110
7523 ! Parallel orientation
7524 ! Contribution from graph III
7525         call transpose2(EUg(1,1,l),auxmat(1,1))
7526         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7527         vv(1)=pizda(1,1)-pizda(2,2)
7528         vv(2)=pizda(1,2)+pizda(2,1)
7529         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7530          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7531 ! Explicit gradient in virtual-dihedral angles.
7532         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7533          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7534          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7535         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7536         vv(1)=pizda(1,1)-pizda(2,2)
7537         vv(2)=pizda(1,2)+pizda(2,1)
7538         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7539          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7540          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7541         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7542         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7543         vv(1)=pizda(1,1)-pizda(2,2)
7544         vv(2)=pizda(1,2)+pizda(2,1)
7545         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7546          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7547          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7548 ! Cartesian gradient
7549         do iii=1,2
7550           do kkk=1,5
7551             do lll=1,3
7552               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7553                 pizda(1,1))
7554               vv(1)=pizda(1,1)-pizda(2,2)
7555               vv(2)=pizda(1,2)+pizda(2,1)
7556               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7557                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7558                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7559             enddo
7560           enddo
7561         enddo
7562 !d        goto 1112
7563 ! Contribution from graph IV
7564 !d1110    continue
7565         call transpose2(EE(1,1,itl),auxmat(1,1))
7566         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7567         vv(1)=pizda(1,1)+pizda(2,2)
7568         vv(2)=pizda(2,1)-pizda(1,2)
7569         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7570          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7571 ! Explicit gradient in virtual-dihedral angles.
7572         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7573          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7574         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7575         vv(1)=pizda(1,1)+pizda(2,2)
7576         vv(2)=pizda(2,1)-pizda(1,2)
7577         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7578          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7579          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7580 ! Cartesian gradient
7581         do iii=1,2
7582           do kkk=1,5
7583             do lll=1,3
7584               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7585                 pizda(1,1))
7586               vv(1)=pizda(1,1)+pizda(2,2)
7587               vv(2)=pizda(2,1)-pizda(1,2)
7588               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7589                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7590                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7591             enddo
7592           enddo
7593         enddo
7594       else
7595 ! Antiparallel orientation
7596 ! Contribution from graph III
7597 !        goto 1110
7598         call transpose2(EUg(1,1,j),auxmat(1,1))
7599         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7600         vv(1)=pizda(1,1)-pizda(2,2)
7601         vv(2)=pizda(1,2)+pizda(2,1)
7602         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7603          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7604 ! Explicit gradient in virtual-dihedral angles.
7605         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7606          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7607          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7608         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7609         vv(1)=pizda(1,1)-pizda(2,2)
7610         vv(2)=pizda(1,2)+pizda(2,1)
7611         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7612          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7613          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7614         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7615         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7616         vv(1)=pizda(1,1)-pizda(2,2)
7617         vv(2)=pizda(1,2)+pizda(2,1)
7618         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7619          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7620          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7621 ! Cartesian gradient
7622         do iii=1,2
7623           do kkk=1,5
7624             do lll=1,3
7625               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7626                 pizda(1,1))
7627               vv(1)=pizda(1,1)-pizda(2,2)
7628               vv(2)=pizda(1,2)+pizda(2,1)
7629               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7630                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7631                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7632             enddo
7633           enddo
7634         enddo
7635 !d        goto 1112
7636 ! Contribution from graph IV
7637 1110    continue
7638         call transpose2(EE(1,1,itj),auxmat(1,1))
7639         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7640         vv(1)=pizda(1,1)+pizda(2,2)
7641         vv(2)=pizda(2,1)-pizda(1,2)
7642         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7643          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7644 ! Explicit gradient in virtual-dihedral angles.
7645         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7646          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7647         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7648         vv(1)=pizda(1,1)+pizda(2,2)
7649         vv(2)=pizda(2,1)-pizda(1,2)
7650         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7651          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7652          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7653 ! Cartesian gradient
7654         do iii=1,2
7655           do kkk=1,5
7656             do lll=1,3
7657               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7658                 pizda(1,1))
7659               vv(1)=pizda(1,1)+pizda(2,2)
7660               vv(2)=pizda(2,1)-pizda(1,2)
7661               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7662                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7663                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7664             enddo
7665           enddo
7666         enddo
7667       endif
7668 1112  continue
7669       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7670 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7671 !d        write (2,*) 'ijkl',i,j,k,l
7672 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7673 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7674 !d      endif
7675 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7676 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7677 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7678 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7679       if (j.lt.nres-1) then
7680         j1=j+1
7681         j2=j-1
7682       else
7683         j1=j-1
7684         j2=j-2
7685       endif
7686       if (l.lt.nres-1) then
7687         l1=l+1
7688         l2=l-1
7689       else
7690         l1=l-1
7691         l2=l-2
7692       endif
7693 !d      eij=1.0d0
7694 !d      ekl=1.0d0
7695 !d      ekont=1.0d0
7696 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7697 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7698 !        summed up outside the subrouine as for the other subroutines
7699 !        handling long-range interactions. The old code is commented out
7700 !        with "cgrad" to keep track of changes.
7701       do ll=1,3
7702 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7703 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7704         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7705         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7706 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7707 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7708 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7709 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7710 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7711 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7712 !     &   gradcorr5ij,
7713 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7714 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7715 !grad        ghalf=0.5d0*ggg1(ll)
7716 !d        ghalf=0.0d0
7717         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7718         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7719         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7720         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7721         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7722         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7723 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7724 !grad        ghalf=0.5d0*ggg2(ll)
7725         ghalf=0.0d0
7726         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7727         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7728         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7729         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7730         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7731         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7732       enddo
7733 !d      goto 1112
7734 !grad      do m=i+1,j-1
7735 !grad        do ll=1,3
7736 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7737 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7738 !grad        enddo
7739 !grad      enddo
7740 !grad      do m=k+1,l-1
7741 !grad        do ll=1,3
7742 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7743 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7744 !grad        enddo
7745 !grad      enddo
7746 !1112  continue
7747 !grad      do m=i+2,j2
7748 !grad        do ll=1,3
7749 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7750 !grad        enddo
7751 !grad      enddo
7752 !grad      do m=k+2,l2
7753 !grad        do ll=1,3
7754 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7755 !grad        enddo
7756 !grad      enddo
7757 !d      do iii=1,nres-3
7758 !d        write (2,*) iii,g_corr5_loc(iii)
7759 !d      enddo
7760       eello5=ekont*eel5
7761 !d      write (2,*) 'ekont',ekont
7762 !d      write (iout,*) 'eello5',ekont*eel5
7763       return
7764       end function eello5
7765 !-----------------------------------------------------------------------------
7766       real(kind=8) function eello6(i,j,k,l,jj,kk)
7767 !      implicit real*8 (a-h,o-z)
7768 !      include 'DIMENSIONS'
7769 !      include 'COMMON.IOUNITS'
7770 !      include 'COMMON.CHAIN'
7771 !      include 'COMMON.DERIV'
7772 !      include 'COMMON.INTERACT'
7773 !      include 'COMMON.CONTACTS'
7774 !      include 'COMMON.TORSION'
7775 !      include 'COMMON.VAR'
7776 !      include 'COMMON.GEO'
7777 !      include 'COMMON.FFIELD'
7778       real(kind=8),dimension(3) :: ggg1,ggg2
7779       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7780                    eello6_6,eel6
7781       real(kind=8) :: gradcorr6ij,gradcorr6kl
7782       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7783 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7784 !d        eello6=0.0d0
7785 !d        return
7786 !d      endif
7787 !d      write (iout,*)
7788 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7789 !d     &   ' and',k,l
7790       eello6_1=0.0d0
7791       eello6_2=0.0d0
7792       eello6_3=0.0d0
7793       eello6_4=0.0d0
7794       eello6_5=0.0d0
7795       eello6_6=0.0d0
7796 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7797 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7798       do iii=1,2
7799         do kkk=1,5
7800           do lll=1,3
7801             derx(lll,kkk,iii)=0.0d0
7802           enddo
7803         enddo
7804       enddo
7805 !d      eij=facont_hb(jj,i)
7806 !d      ekl=facont_hb(kk,k)
7807 !d      ekont=eij*ekl
7808 !d      eij=1.0d0
7809 !d      ekl=1.0d0
7810 !d      ekont=1.0d0
7811       if (l.eq.j+1) then
7812         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7813         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7814         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7815         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7816         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7817         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7818       else
7819         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7820         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7821         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7822         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7823         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7824           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7825         else
7826           eello6_5=0.0d0
7827         endif
7828         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7829       endif
7830 ! If turn contributions are considered, they will be handled separately.
7831       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7832 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7833 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7834 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7835 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7836 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7837 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7838 !d      goto 1112
7839       if (j.lt.nres-1) then
7840         j1=j+1
7841         j2=j-1
7842       else
7843         j1=j-1
7844         j2=j-2
7845       endif
7846       if (l.lt.nres-1) then
7847         l1=l+1
7848         l2=l-1
7849       else
7850         l1=l-1
7851         l2=l-2
7852       endif
7853       do ll=1,3
7854 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7855 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7856 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7857 !grad        ghalf=0.5d0*ggg1(ll)
7858 !d        ghalf=0.0d0
7859         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7860         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7861         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7862         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7863         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7864         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7865         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7866         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7867 !grad        ghalf=0.5d0*ggg2(ll)
7868 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7869 !d        ghalf=0.0d0
7870         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7871         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7872         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7873         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7874         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7875         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7876       enddo
7877 !d      goto 1112
7878 !grad      do m=i+1,j-1
7879 !grad        do ll=1,3
7880 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7881 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7882 !grad        enddo
7883 !grad      enddo
7884 !grad      do m=k+1,l-1
7885 !grad        do ll=1,3
7886 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7887 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7888 !grad        enddo
7889 !grad      enddo
7890 !grad1112  continue
7891 !grad      do m=i+2,j2
7892 !grad        do ll=1,3
7893 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7894 !grad        enddo
7895 !grad      enddo
7896 !grad      do m=k+2,l2
7897 !grad        do ll=1,3
7898 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7899 !grad        enddo
7900 !grad      enddo
7901 !d      do iii=1,nres-3
7902 !d        write (2,*) iii,g_corr6_loc(iii)
7903 !d      enddo
7904       eello6=ekont*eel6
7905 !d      write (2,*) 'ekont',ekont
7906 !d      write (iout,*) 'eello6',ekont*eel6
7907       return
7908       end function eello6
7909 !-----------------------------------------------------------------------------
7910       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7911       use comm_kut
7912 !      implicit real*8 (a-h,o-z)
7913 !      include 'DIMENSIONS'
7914 !      include 'COMMON.IOUNITS'
7915 !      include 'COMMON.CHAIN'
7916 !      include 'COMMON.DERIV'
7917 !      include 'COMMON.INTERACT'
7918 !      include 'COMMON.CONTACTS'
7919 !      include 'COMMON.TORSION'
7920 !      include 'COMMON.VAR'
7921 !      include 'COMMON.GEO'
7922       real(kind=8),dimension(2) :: vv,vv1
7923       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
7924       logical :: swap
7925 !el      logical :: lprn
7926 !el      common /kutas/ lprn
7927       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
7928       real(kind=8) :: s1,s2,s3,s4,s5
7929 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7930 !                                                                              C
7931 !      Parallel       Antiparallel                                             C
7932 !                                                                              C
7933 !          o             o                                                     C
7934 !         /l\           /j\                                                    C
7935 !        /   \         /   \                                                   C
7936 !       /| o |         | o |\                                                  C
7937 !     \ j|/k\|  /   \  |/k\|l /                                                C
7938 !      \ /   \ /     \ /   \ /                                                 C
7939 !       o     o       o     o                                                  C
7940 !       i             i                                                        C
7941 !                                                                              C
7942 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7943       itk=itortyp(itype(k))
7944       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7945       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7946       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7947       call transpose2(EUgC(1,1,k),auxmat(1,1))
7948       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7949       vv1(1)=pizda1(1,1)-pizda1(2,2)
7950       vv1(2)=pizda1(1,2)+pizda1(2,1)
7951       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7952       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7953       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7954       s5=scalar2(vv(1),Dtobr2(1,i))
7955 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7956       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7957       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
7958        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
7959        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
7960        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
7961        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
7962        +scalar2(vv(1),Dtobr2der(1,i)))
7963       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7964       vv1(1)=pizda1(1,1)-pizda1(2,2)
7965       vv1(2)=pizda1(1,2)+pizda1(2,1)
7966       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7967       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7968       if (l.eq.j+1) then
7969         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
7970        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7971        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7972        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7973        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7974       else
7975         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
7976        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7977        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7978        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7979        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7980       endif
7981       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7982       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7983       vv1(1)=pizda1(1,1)-pizda1(2,2)
7984       vv1(2)=pizda1(1,2)+pizda1(2,1)
7985       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
7986        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
7987        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
7988        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7989       do iii=1,2
7990         if (swap) then
7991           ind=3-iii
7992         else
7993           ind=iii
7994         endif
7995         do kkk=1,5
7996           do lll=1,3
7997             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7998             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7999             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8000             call transpose2(EUgC(1,1,k),auxmat(1,1))
8001             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8002               pizda1(1,1))
8003             vv1(1)=pizda1(1,1)-pizda1(2,2)
8004             vv1(2)=pizda1(1,2)+pizda1(2,1)
8005             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8006             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8007              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8008             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8009              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8010             s5=scalar2(vv(1),Dtobr2(1,i))
8011             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8012           enddo
8013         enddo
8014       enddo
8015       return
8016       end function eello6_graph1
8017 !-----------------------------------------------------------------------------
8018       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8019       use comm_kut
8020 !      implicit real*8 (a-h,o-z)
8021 !      include 'DIMENSIONS'
8022 !      include 'COMMON.IOUNITS'
8023 !      include 'COMMON.CHAIN'
8024 !      include 'COMMON.DERIV'
8025 !      include 'COMMON.INTERACT'
8026 !      include 'COMMON.CONTACTS'
8027 !      include 'COMMON.TORSION'
8028 !      include 'COMMON.VAR'
8029 !      include 'COMMON.GEO'
8030       logical :: swap
8031       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8032       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8033 !el      logical :: lprn
8034 !el      common /kutas/ lprn
8035       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8036       real(kind=8) :: s2,s3,s4
8037 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038 !                                                                              C
8039 !      Parallel       Antiparallel                                             C
8040 !                                                                              C
8041 !          o             o                                                     C
8042 !     \   /l\           /j\   /                                                C
8043 !      \ /   \         /   \ /                                                 C
8044 !       o| o |         | o |o                                                  C
8045 !     \ j|/k\|      \  |/k\|l                                                  C
8046 !      \ /   \       \ /   \                                                   C
8047 !       o             o                                                        C
8048 !       i             i                                                        C
8049 !                                                                              C
8050 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8051 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8052 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8053 !           but not in a cluster cumulant
8054 #ifdef MOMENT
8055       s1=dip(1,jj,i)*dip(1,kk,k)
8056 #endif
8057       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8058       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8059       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8060       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8061       call transpose2(EUg(1,1,k),auxmat(1,1))
8062       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8063       vv(1)=pizda(1,1)-pizda(2,2)
8064       vv(2)=pizda(1,2)+pizda(2,1)
8065       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8066 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8067 #ifdef MOMENT
8068       eello6_graph2=-(s1+s2+s3+s4)
8069 #else
8070       eello6_graph2=-(s2+s3+s4)
8071 #endif
8072 !      eello6_graph2=-s3
8073 ! Derivatives in gamma(i-1)
8074       if (i.gt.1) then
8075 #ifdef MOMENT
8076         s1=dipderg(1,jj,i)*dip(1,kk,k)
8077 #endif
8078         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8079         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8080         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8081         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8082 #ifdef MOMENT
8083         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8084 #else
8085         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8086 #endif
8087 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8088       endif
8089 ! Derivatives in gamma(k-1)
8090 #ifdef MOMENT
8091       s1=dip(1,jj,i)*dipderg(1,kk,k)
8092 #endif
8093       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8094       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8095       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8096       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8097       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8098       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)-pizda(2,2)
8100       vv(2)=pizda(1,2)+pizda(2,1)
8101       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8102 #ifdef MOMENT
8103       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8104 #else
8105       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8106 #endif
8107 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8108 ! Derivatives in gamma(j-1) or gamma(l-1)
8109       if (j.gt.1) then
8110 #ifdef MOMENT
8111         s1=dipderg(3,jj,i)*dip(1,kk,k)
8112 #endif
8113         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8114         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8115         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8116         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8117         vv(1)=pizda(1,1)-pizda(2,2)
8118         vv(2)=pizda(1,2)+pizda(2,1)
8119         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8120 #ifdef MOMENT
8121         if (swap) then
8122           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8123         else
8124           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8125         endif
8126 #endif
8127         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8128 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8129       endif
8130 ! Derivatives in gamma(l-1) or gamma(j-1)
8131       if (l.gt.1) then
8132 #ifdef MOMENT
8133         s1=dip(1,jj,i)*dipderg(3,kk,k)
8134 #endif
8135         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8136         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8137         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8138         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8139         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8140         vv(1)=pizda(1,1)-pizda(2,2)
8141         vv(2)=pizda(1,2)+pizda(2,1)
8142         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8143 #ifdef MOMENT
8144         if (swap) then
8145           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8146         else
8147           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8148         endif
8149 #endif
8150         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8151 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8152       endif
8153 ! Cartesian derivatives.
8154       if (lprn) then
8155         write (2,*) 'In eello6_graph2'
8156         do iii=1,2
8157           write (2,*) 'iii=',iii
8158           do kkk=1,5
8159             write (2,*) 'kkk=',kkk
8160             do jjj=1,2
8161               write (2,'(3(2f10.5),5x)') &
8162               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8163             enddo
8164           enddo
8165         enddo
8166       endif
8167       do iii=1,2
8168         do kkk=1,5
8169           do lll=1,3
8170 #ifdef MOMENT
8171             if (iii.eq.1) then
8172               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8173             else
8174               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8175             endif
8176 #endif
8177             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8178               auxvec(1))
8179             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8180             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8181               auxvec(1))
8182             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8183             call transpose2(EUg(1,1,k),auxmat(1,1))
8184             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8185               pizda(1,1))
8186             vv(1)=pizda(1,1)-pizda(2,2)
8187             vv(2)=pizda(1,2)+pizda(2,1)
8188             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8189 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8190 #ifdef MOMENT
8191             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8192 #else
8193             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8194 #endif
8195             if (swap) then
8196               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8197             else
8198               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8199             endif
8200           enddo
8201         enddo
8202       enddo
8203       return
8204       end function eello6_graph2
8205 !-----------------------------------------------------------------------------
8206       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8207 !      implicit real*8 (a-h,o-z)
8208 !      include 'DIMENSIONS'
8209 !      include 'COMMON.IOUNITS'
8210 !      include 'COMMON.CHAIN'
8211 !      include 'COMMON.DERIV'
8212 !      include 'COMMON.INTERACT'
8213 !      include 'COMMON.CONTACTS'
8214 !      include 'COMMON.TORSION'
8215 !      include 'COMMON.VAR'
8216 !      include 'COMMON.GEO'
8217       real(kind=8),dimension(2) :: vv,auxvec
8218       real(kind=8),dimension(2,2) :: pizda,auxmat
8219       logical :: swap
8220       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8221       real(kind=8) :: s1,s2,s3,s4
8222 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8223 !                                                                              C
8224 !      Parallel       Antiparallel                                             C
8225 !                                                                              C
8226 !          o             o                                                     C
8227 !         /l\   /   \   /j\                                                    C
8228 !        /   \ /     \ /   \                                                   C
8229 !       /| o |o       o| o |\                                                  C
8230 !       j|/k\|  /      |/k\|l /                                                C
8231 !        /   \ /       /   \ /                                                 C
8232 !       /     o       /     o                                                  C
8233 !       i             i                                                        C
8234 !                                                                              C
8235 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8236 !
8237 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8238 !           energy moment and not to the cluster cumulant.
8239       iti=itortyp(itype(i))
8240       if (j.lt.nres-1) then
8241         itj1=itortyp(itype(j+1))
8242       else
8243         itj1=ntortyp+1
8244       endif
8245       itk=itortyp(itype(k))
8246       itk1=itortyp(itype(k+1))
8247       if (l.lt.nres-1) then
8248         itl1=itortyp(itype(l+1))
8249       else
8250         itl1=ntortyp+1
8251       endif
8252 #ifdef MOMENT
8253       s1=dip(4,jj,i)*dip(4,kk,k)
8254 #endif
8255       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8256       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8257       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8258       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8259       call transpose2(EE(1,1,itk),auxmat(1,1))
8260       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8261       vv(1)=pizda(1,1)+pizda(2,2)
8262       vv(2)=pizda(2,1)-pizda(1,2)
8263       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8264 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8265 !d     & "sum",-(s2+s3+s4)
8266 #ifdef MOMENT
8267       eello6_graph3=-(s1+s2+s3+s4)
8268 #else
8269       eello6_graph3=-(s2+s3+s4)
8270 #endif
8271 !      eello6_graph3=-s4
8272 ! Derivatives in gamma(k-1)
8273       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8274       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8275       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8276       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8277 ! Derivatives in gamma(l-1)
8278       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8279       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8280       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8281       vv(1)=pizda(1,1)+pizda(2,2)
8282       vv(2)=pizda(2,1)-pizda(1,2)
8283       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8284       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8285 ! Cartesian derivatives.
8286       do iii=1,2
8287         do kkk=1,5
8288           do lll=1,3
8289 #ifdef MOMENT
8290             if (iii.eq.1) then
8291               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8292             else
8293               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8294             endif
8295 #endif
8296             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8297               auxvec(1))
8298             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8299             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8300               auxvec(1))
8301             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8302             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8303               pizda(1,1))
8304             vv(1)=pizda(1,1)+pizda(2,2)
8305             vv(2)=pizda(2,1)-pizda(1,2)
8306             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8307 #ifdef MOMENT
8308             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8309 #else
8310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8311 #endif
8312             if (swap) then
8313               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8314             else
8315               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8316             endif
8317 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8318           enddo
8319         enddo
8320       enddo
8321       return
8322       end function eello6_graph3
8323 !-----------------------------------------------------------------------------
8324       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8325 !      implicit real*8 (a-h,o-z)
8326 !      include 'DIMENSIONS'
8327 !      include 'COMMON.IOUNITS'
8328 !      include 'COMMON.CHAIN'
8329 !      include 'COMMON.DERIV'
8330 !      include 'COMMON.INTERACT'
8331 !      include 'COMMON.CONTACTS'
8332 !      include 'COMMON.TORSION'
8333 !      include 'COMMON.VAR'
8334 !      include 'COMMON.GEO'
8335 !      include 'COMMON.FFIELD'
8336       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8337       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8338       logical :: swap
8339       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8340               iii,kkk,lll
8341       real(kind=8) :: s1,s2,s3,s4
8342 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8343 !                                                                              C
8344 !      Parallel       Antiparallel                                             C
8345 !                                                                              C
8346 !          o             o                                                     C
8347 !         /l\   /   \   /j\                                                    C
8348 !        /   \ /     \ /   \                                                   C
8349 !       /| o |o       o| o |\                                                  C
8350 !     \ j|/k\|      \  |/k\|l                                                  C
8351 !      \ /   \       \ /   \                                                   C
8352 !       o     \       o     \                                                  C
8353 !       i             i                                                        C
8354 !                                                                              C
8355 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8356 !
8357 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8358 !           energy moment and not to the cluster cumulant.
8359 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8360       iti=itortyp(itype(i))
8361       itj=itortyp(itype(j))
8362       if (j.lt.nres-1) then
8363         itj1=itortyp(itype(j+1))
8364       else
8365         itj1=ntortyp+1
8366       endif
8367       itk=itortyp(itype(k))
8368       if (k.lt.nres-1) then
8369         itk1=itortyp(itype(k+1))
8370       else
8371         itk1=ntortyp+1
8372       endif
8373       itl=itortyp(itype(l))
8374       if (l.lt.nres-1) then
8375         itl1=itortyp(itype(l+1))
8376       else
8377         itl1=ntortyp+1
8378       endif
8379 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8380 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8381 !d     & ' itl',itl,' itl1',itl1
8382 #ifdef MOMENT
8383       if (imat.eq.1) then
8384         s1=dip(3,jj,i)*dip(3,kk,k)
8385       else
8386         s1=dip(2,jj,j)*dip(2,kk,l)
8387       endif
8388 #endif
8389       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8390       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8391       if (j.eq.l+1) then
8392         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8393         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8394       else
8395         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8396         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8397       endif
8398       call transpose2(EUg(1,1,k),auxmat(1,1))
8399       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8400       vv(1)=pizda(1,1)-pizda(2,2)
8401       vv(2)=pizda(2,1)+pizda(1,2)
8402       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8403 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8404 #ifdef MOMENT
8405       eello6_graph4=-(s1+s2+s3+s4)
8406 #else
8407       eello6_graph4=-(s2+s3+s4)
8408 #endif
8409 ! Derivatives in gamma(i-1)
8410       if (i.gt.1) then
8411 #ifdef MOMENT
8412         if (imat.eq.1) then
8413           s1=dipderg(2,jj,i)*dip(3,kk,k)
8414         else
8415           s1=dipderg(4,jj,j)*dip(2,kk,l)
8416         endif
8417 #endif
8418         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8419         if (j.eq.l+1) then
8420           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8421           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8422         else
8423           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8424           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8425         endif
8426         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8427         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8428 !d          write (2,*) 'turn6 derivatives'
8429 #ifdef MOMENT
8430           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8431 #else
8432           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8433 #endif
8434         else
8435 #ifdef MOMENT
8436           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8437 #else
8438           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8439 #endif
8440         endif
8441       endif
8442 ! Derivatives in gamma(k-1)
8443 #ifdef MOMENT
8444       if (imat.eq.1) then
8445         s1=dip(3,jj,i)*dipderg(2,kk,k)
8446       else
8447         s1=dip(2,jj,j)*dipderg(4,kk,l)
8448       endif
8449 #endif
8450       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8451       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8452       if (j.eq.l+1) then
8453         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8454         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8455       else
8456         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8457         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8458       endif
8459       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8460       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8461       vv(1)=pizda(1,1)-pizda(2,2)
8462       vv(2)=pizda(2,1)+pizda(1,2)
8463       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8464       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8465 #ifdef MOMENT
8466         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8467 #else
8468         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8469 #endif
8470       else
8471 #ifdef MOMENT
8472         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8473 #else
8474         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8475 #endif
8476       endif
8477 ! Derivatives in gamma(j-1) or gamma(l-1)
8478       if (l.eq.j+1 .and. l.gt.1) then
8479         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8480         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8481         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8482         vv(1)=pizda(1,1)-pizda(2,2)
8483         vv(2)=pizda(2,1)+pizda(1,2)
8484         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8485         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8486       else if (j.gt.1) then
8487         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8488         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8489         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8490         vv(1)=pizda(1,1)-pizda(2,2)
8491         vv(2)=pizda(2,1)+pizda(1,2)
8492         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8493         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8494           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8495         else
8496           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8497         endif
8498       endif
8499 ! Cartesian derivatives.
8500       do iii=1,2
8501         do kkk=1,5
8502           do lll=1,3
8503 #ifdef MOMENT
8504             if (iii.eq.1) then
8505               if (imat.eq.1) then
8506                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8507               else
8508                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8509               endif
8510             else
8511               if (imat.eq.1) then
8512                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8513               else
8514                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8515               endif
8516             endif
8517 #endif
8518             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8519               auxvec(1))
8520             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8521             if (j.eq.l+1) then
8522               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8523                 b1(1,itj1),auxvec(1))
8524               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8525             else
8526               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8527                 b1(1,itl1),auxvec(1))
8528               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8529             endif
8530             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8531               pizda(1,1))
8532             vv(1)=pizda(1,1)-pizda(2,2)
8533             vv(2)=pizda(2,1)+pizda(1,2)
8534             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8535             if (swap) then
8536               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8537 #ifdef MOMENT
8538                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8539                    -(s1+s2+s4)
8540 #else
8541                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8542                    -(s2+s4)
8543 #endif
8544                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8545               else
8546 #ifdef MOMENT
8547                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8548 #else
8549                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8550 #endif
8551                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8552               endif
8553             else
8554 #ifdef MOMENT
8555               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8556 #else
8557               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8558 #endif
8559               if (l.eq.j+1) then
8560                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8561               else
8562                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8563               endif
8564             endif
8565           enddo
8566         enddo
8567       enddo
8568       return
8569       end function eello6_graph4
8570 !-----------------------------------------------------------------------------
8571       real(kind=8) function eello_turn6(i,jj,kk)
8572 !      implicit real*8 (a-h,o-z)
8573 !      include 'DIMENSIONS'
8574 !      include 'COMMON.IOUNITS'
8575 !      include 'COMMON.CHAIN'
8576 !      include 'COMMON.DERIV'
8577 !      include 'COMMON.INTERACT'
8578 !      include 'COMMON.CONTACTS'
8579 !      include 'COMMON.TORSION'
8580 !      include 'COMMON.VAR'
8581 !      include 'COMMON.GEO'
8582       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8583       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8584       real(kind=8),dimension(3) :: ggg1,ggg2
8585       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8586       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8587 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8588 !           the respective energy moment and not to the cluster cumulant.
8589 !el local variables
8590       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8591       integer :: j1,j2,l1,l2,ll
8592       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8593       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8594       s1=0.0d0
8595       s8=0.0d0
8596       s13=0.0d0
8597 !
8598       eello_turn6=0.0d0
8599       j=i+4
8600       k=i+1
8601       l=i+3
8602       iti=itortyp(itype(i))
8603       itk=itortyp(itype(k))
8604       itk1=itortyp(itype(k+1))
8605       itl=itortyp(itype(l))
8606       itj=itortyp(itype(j))
8607 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8608 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8609 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8610 !d        eello6=0.0d0
8611 !d        return
8612 !d      endif
8613 !d      write (iout,*)
8614 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8615 !d     &   ' and',k,l
8616 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8617       do iii=1,2
8618         do kkk=1,5
8619           do lll=1,3
8620             derx_turn(lll,kkk,iii)=0.0d0
8621           enddo
8622         enddo
8623       enddo
8624 !d      eij=1.0d0
8625 !d      ekl=1.0d0
8626 !d      ekont=1.0d0
8627       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8628 !d      eello6_5=0.0d0
8629 !d      write (2,*) 'eello6_5',eello6_5
8630 #ifdef MOMENT
8631       call transpose2(AEA(1,1,1),auxmat(1,1))
8632       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8633       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8634       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8635 #endif
8636       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8637       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8638       s2 = scalar2(b1(1,itk),vtemp1(1))
8639 #ifdef MOMENT
8640       call transpose2(AEA(1,1,2),atemp(1,1))
8641       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8642       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8643       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8644 #endif
8645       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8646       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8647       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8648 #ifdef MOMENT
8649       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8650       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8651       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8652       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8653       ss13 = scalar2(b1(1,itk),vtemp4(1))
8654       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8655 #endif
8656 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8657 !      s1=0.0d0
8658 !      s2=0.0d0
8659 !      s8=0.0d0
8660 !      s12=0.0d0
8661 !      s13=0.0d0
8662       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8663 ! Derivatives in gamma(i+2)
8664       s1d =0.0d0
8665       s8d =0.0d0
8666 #ifdef MOMENT
8667       call transpose2(AEA(1,1,1),auxmatd(1,1))
8668       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8669       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8670       call transpose2(AEAderg(1,1,2),atempd(1,1))
8671       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8672       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8673 #endif
8674       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8675       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8676       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8677 !      s1d=0.0d0
8678 !      s2d=0.0d0
8679 !      s8d=0.0d0
8680 !      s12d=0.0d0
8681 !      s13d=0.0d0
8682       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8683 ! Derivatives in gamma(i+3)
8684 #ifdef MOMENT
8685       call transpose2(AEA(1,1,1),auxmatd(1,1))
8686       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8687       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8688       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8689 #endif
8690       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8691       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8692       s2d = scalar2(b1(1,itk),vtemp1d(1))
8693 #ifdef MOMENT
8694       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8695       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8696 #endif
8697       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8698 #ifdef MOMENT
8699       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8700       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8701       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8702 #endif
8703 !      s1d=0.0d0
8704 !      s2d=0.0d0
8705 !      s8d=0.0d0
8706 !      s12d=0.0d0
8707 !      s13d=0.0d0
8708 #ifdef MOMENT
8709       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8710                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8711 #else
8712       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8713                     -0.5d0*ekont*(s2d+s12d)
8714 #endif
8715 ! Derivatives in gamma(i+4)
8716       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8717       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8718       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8719 #ifdef MOMENT
8720       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8721       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8722       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8723 #endif
8724 !      s1d=0.0d0
8725 !      s2d=0.0d0
8726 !      s8d=0.0d0
8727 !      s12d=0.0d0
8728 !      s13d=0.0d0
8729 #ifdef MOMENT
8730       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8731 #else
8732       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8733 #endif
8734 ! Derivatives in gamma(i+5)
8735 #ifdef MOMENT
8736       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8737       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8738       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8739 #endif
8740       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8741       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8742       s2d = scalar2(b1(1,itk),vtemp1d(1))
8743 #ifdef MOMENT
8744       call transpose2(AEA(1,1,2),atempd(1,1))
8745       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8746       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8747 #endif
8748       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8749       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8750 #ifdef MOMENT
8751       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8752       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8753       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8754 #endif
8755 !      s1d=0.0d0
8756 !      s2d=0.0d0
8757 !      s8d=0.0d0
8758 !      s12d=0.0d0
8759 !      s13d=0.0d0
8760 #ifdef MOMENT
8761       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8762                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8763 #else
8764       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8765                     -0.5d0*ekont*(s2d+s12d)
8766 #endif
8767 ! Cartesian derivatives
8768       do iii=1,2
8769         do kkk=1,5
8770           do lll=1,3
8771 #ifdef MOMENT
8772             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8773             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8774             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8775 #endif
8776             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8777             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8778                 vtemp1d(1))
8779             s2d = scalar2(b1(1,itk),vtemp1d(1))
8780 #ifdef MOMENT
8781             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8782             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8783             s8d = -(atempd(1,1)+atempd(2,2))* &
8784                  scalar2(cc(1,1,itl),vtemp2(1))
8785 #endif
8786             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8787                  auxmatd(1,1))
8788             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8789             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8790 !      s1d=0.0d0
8791 !      s2d=0.0d0
8792 !      s8d=0.0d0
8793 !      s12d=0.0d0
8794 !      s13d=0.0d0
8795 #ifdef MOMENT
8796             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8797               - 0.5d0*(s1d+s2d)
8798 #else
8799             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8800               - 0.5d0*s2d
8801 #endif
8802 #ifdef MOMENT
8803             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8804               - 0.5d0*(s8d+s12d)
8805 #else
8806             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8807               - 0.5d0*s12d
8808 #endif
8809           enddo
8810         enddo
8811       enddo
8812 #ifdef MOMENT
8813       do kkk=1,5
8814         do lll=1,3
8815           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8816             achuj_tempd(1,1))
8817           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8818           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8819           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8820           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8821           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8822             vtemp4d(1))
8823           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8824           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8825           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8826         enddo
8827       enddo
8828 #endif
8829 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8830 !d     &  16*eel_turn6_num
8831 !d      goto 1112
8832       if (j.lt.nres-1) then
8833         j1=j+1
8834         j2=j-1
8835       else
8836         j1=j-1
8837         j2=j-2
8838       endif
8839       if (l.lt.nres-1) then
8840         l1=l+1
8841         l2=l-1
8842       else
8843         l1=l-1
8844         l2=l-2
8845       endif
8846       do ll=1,3
8847 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8848 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8849 !grad        ghalf=0.5d0*ggg1(ll)
8850 !d        ghalf=0.0d0
8851         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8852         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8853         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8854           +ekont*derx_turn(ll,2,1)
8855         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8856         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8857           +ekont*derx_turn(ll,4,1)
8858         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8859         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8860         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8861 !grad        ghalf=0.5d0*ggg2(ll)
8862 !d        ghalf=0.0d0
8863         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8864           +ekont*derx_turn(ll,2,2)
8865         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8866         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8867           +ekont*derx_turn(ll,4,2)
8868         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8869         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8870         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8871       enddo
8872 !d      goto 1112
8873 !grad      do m=i+1,j-1
8874 !grad        do ll=1,3
8875 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8876 !grad        enddo
8877 !grad      enddo
8878 !grad      do m=k+1,l-1
8879 !grad        do ll=1,3
8880 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8881 !grad        enddo
8882 !grad      enddo
8883 !grad1112  continue
8884 !grad      do m=i+2,j2
8885 !grad        do ll=1,3
8886 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8887 !grad        enddo
8888 !grad      enddo
8889 !grad      do m=k+2,l2
8890 !grad        do ll=1,3
8891 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8892 !grad        enddo
8893 !grad      enddo
8894 !d      do iii=1,nres-3
8895 !d        write (2,*) iii,g_corr6_loc(iii)
8896 !d      enddo
8897       eello_turn6=ekont*eel_turn6
8898 !d      write (2,*) 'ekont',ekont
8899 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8900       return
8901       end function eello_turn6
8902 !-----------------------------------------------------------------------------
8903       subroutine MATVEC2(A1,V1,V2)
8904 !DIR$ INLINEALWAYS MATVEC2
8905 #ifndef OSF
8906 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8907 #endif
8908 !      implicit real*8 (a-h,o-z)
8909 !      include 'DIMENSIONS'
8910       real(kind=8),dimension(2) :: V1,V2
8911       real(kind=8),dimension(2,2) :: A1
8912       real(kind=8) :: vaux1,vaux2
8913 !      DO 1 I=1,2
8914 !        VI=0.0
8915 !        DO 3 K=1,2
8916 !    3     VI=VI+A1(I,K)*V1(K)
8917 !        Vaux(I)=VI
8918 !    1 CONTINUE
8919
8920       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8921       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8922
8923       v2(1)=vaux1
8924       v2(2)=vaux2
8925       end subroutine MATVEC2
8926 !-----------------------------------------------------------------------------
8927       subroutine MATMAT2(A1,A2,A3)
8928 #ifndef OSF
8929 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8930 #endif
8931 !      implicit real*8 (a-h,o-z)
8932 !      include 'DIMENSIONS'
8933       real(kind=8),dimension(2,2) :: A1,A2,A3
8934       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
8935 !      DIMENSION AI3(2,2)
8936 !        DO  J=1,2
8937 !          A3IJ=0.0
8938 !          DO K=1,2
8939 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8940 !          enddo
8941 !          A3(I,J)=A3IJ
8942 !       enddo
8943 !      enddo
8944
8945       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8946       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8947       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8948       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8949
8950       A3(1,1)=AI3_11
8951       A3(2,1)=AI3_21
8952       A3(1,2)=AI3_12
8953       A3(2,2)=AI3_22
8954       end subroutine MATMAT2
8955 !-----------------------------------------------------------------------------
8956       real(kind=8) function scalar2(u,v)
8957 !DIR$ INLINEALWAYS scalar2
8958       implicit none
8959       real(kind=8),dimension(2) :: u,v
8960       real(kind=8) :: sc
8961       integer :: i
8962       scalar2=u(1)*v(1)+u(2)*v(2)
8963       return
8964       end function scalar2
8965 !-----------------------------------------------------------------------------
8966       subroutine transpose2(a,at)
8967 !DIR$ INLINEALWAYS transpose2
8968 #ifndef OSF
8969 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
8970 #endif
8971       implicit none
8972       real(kind=8),dimension(2,2) :: a,at
8973       at(1,1)=a(1,1)
8974       at(1,2)=a(2,1)
8975       at(2,1)=a(1,2)
8976       at(2,2)=a(2,2)
8977       return
8978       end subroutine transpose2
8979 !-----------------------------------------------------------------------------
8980       subroutine transpose(n,a,at)
8981       implicit none
8982       integer :: n,i,j
8983       real(kind=8),dimension(n,n) :: a,at
8984       do i=1,n
8985         do j=1,n
8986           at(j,i)=a(i,j)
8987         enddo
8988       enddo
8989       return
8990       end subroutine transpose
8991 !-----------------------------------------------------------------------------
8992       subroutine prodmat3(a1,a2,kk,transp,prod)
8993 !DIR$ INLINEALWAYS prodmat3
8994 #ifndef OSF
8995 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
8996 #endif
8997       implicit none
8998       integer :: i,j
8999       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9000       logical :: transp
9001 !rc      double precision auxmat(2,2),prod_(2,2)
9002
9003       if (transp) then
9004 !rc        call transpose2(kk(1,1),auxmat(1,1))
9005 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9006 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9007
9008            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9009        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9010            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9011        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9012            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9013        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9014            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9015        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9016
9017       else
9018 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9019 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9020
9021            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9022         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9023            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9024         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9025            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9026         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9027            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9028         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9029
9030       endif
9031 !      call transpose2(a2(1,1),a2t(1,1))
9032
9033 !rc      print *,transp
9034 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9035 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9036
9037       return
9038       end subroutine prodmat3
9039 !-----------------------------------------------------------------------------
9040 ! energy_p_new_barrier.F
9041 !-----------------------------------------------------------------------------
9042       subroutine sum_gradient
9043 !      implicit real*8 (a-h,o-z)
9044       use io_base, only: pdbout
9045 !      include 'DIMENSIONS'
9046 #ifndef ISNAN
9047       external proc_proc
9048 #ifdef WINPGI
9049 !MS$ATTRIBUTES C ::  proc_proc
9050 #endif
9051 #endif
9052 #ifdef MPI
9053       include 'mpif.h'
9054 #endif
9055       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9056                    gloc_scbuf !(3,maxres)
9057
9058       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9059 !#endif
9060 !el local variables
9061       integer :: i,j,k,ierror,ierr
9062       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9063                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9064                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9065                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9066                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9067                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9068                    gsccorr_max,gsccorrx_max,time00
9069
9070 !      include 'COMMON.SETUP'
9071 !      include 'COMMON.IOUNITS'
9072 !      include 'COMMON.FFIELD'
9073 !      include 'COMMON.DERIV'
9074 !      include 'COMMON.INTERACT'
9075 !      include 'COMMON.SBRIDGE'
9076 !      include 'COMMON.CHAIN'
9077 !      include 'COMMON.VAR'
9078 !      include 'COMMON.CONTROL'
9079 !      include 'COMMON.TIME1'
9080 !      include 'COMMON.MAXGRAD'
9081 !      include 'COMMON.SCCOR'
9082 #ifdef TIMING
9083       time01=MPI_Wtime()
9084 #endif
9085 #ifdef DEBUG
9086       write (iout,*) "sum_gradient gvdwc, gvdwx"
9087       do i=1,nres
9088         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9089          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9090       enddo
9091       call flush(iout)
9092 #endif
9093 #ifdef MPI
9094         gradbufc=0.0d0
9095         gradbufx=0.0d0
9096         gradbufc_sum=0.0d0
9097         gloc_scbuf=0.0d0
9098         glocbuf=0.0d0
9099 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9100         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9101           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9102 #endif
9103 !
9104 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9105 !            in virtual-bond-vector coordinates
9106 !
9107 #ifdef DEBUG
9108 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9109 !      do i=1,nres-1
9110 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9111 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9112 !      enddo
9113 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9114 !      do i=1,nres-1
9115 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9116 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9117 !      enddo
9118       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9119       do i=1,nres
9120         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9121          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9122          (gvdwc_scpp(j,i),j=1,3)
9123       enddo
9124       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9125       do i=1,nres
9126         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9127          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9128          (gelc_loc_long(j,i),j=1,3)
9129       enddo
9130       call flush(iout)
9131 #endif
9132 #ifdef SPLITELE
9133       do i=1,nct
9134         do j=1,3
9135           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9136                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9137                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9138                       wel_loc*gel_loc_long(j,i)+ &
9139                       wcorr*gradcorr_long(j,i)+ &
9140                       wcorr5*gradcorr5_long(j,i)+ &
9141                       wcorr6*gradcorr6_long(j,i)+ &
9142                       wturn6*gcorr6_turn_long(j,i)+ &
9143                       wstrain*ghpbc(j,i)
9144         enddo
9145       enddo
9146 #else
9147       do i=1,nct
9148         do j=1,3
9149           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9150                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9151                       welec*gelc_long(j,i)+ &
9152                       wbond*gradb(j,i)+ &
9153                       wel_loc*gel_loc_long(j,i)+ &
9154                       wcorr*gradcorr_long(j,i)+ &
9155                       wcorr5*gradcorr5_long(j,i)+ &
9156                       wcorr6*gradcorr6_long(j,i)+ &
9157                       wturn6*gcorr6_turn_long(j,i)+ &
9158                       wstrain*ghpbc(j,i)
9159         enddo
9160       enddo
9161 #endif
9162 #ifdef MPI
9163       if (nfgtasks.gt.1) then
9164       time00=MPI_Wtime()
9165 #ifdef DEBUG
9166       write (iout,*) "gradbufc before allreduce"
9167       do i=1,nres
9168         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9169       enddo
9170       call flush(iout)
9171 #endif
9172       do i=1,nres
9173         do j=1,3
9174           gradbufc_sum(j,i)=gradbufc(j,i)
9175         enddo
9176       enddo
9177 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9178 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9179 !      time_reduce=time_reduce+MPI_Wtime()-time00
9180 #ifdef DEBUG
9181 !      write (iout,*) "gradbufc_sum after allreduce"
9182 !      do i=1,nres
9183 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9184 !      enddo
9185 !      call flush(iout)
9186 #endif
9187 #ifdef TIMING
9188 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9189 #endif
9190       do i=nnt,nres
9191         do k=1,3
9192           gradbufc(k,i)=0.0d0
9193         enddo
9194       enddo
9195 #ifdef DEBUG
9196       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9197       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9198                         " jgrad_end  ",jgrad_end(i),&
9199                         i=igrad_start,igrad_end)
9200 #endif
9201 !
9202 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9203 ! do not parallelize this part.
9204 !
9205 !      do i=igrad_start,igrad_end
9206 !        do j=jgrad_start(i),jgrad_end(i)
9207 !          do k=1,3
9208 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9209 !          enddo
9210 !        enddo
9211 !      enddo
9212       do j=1,3
9213         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9214       enddo
9215       do i=nres-2,nnt,-1
9216         do j=1,3
9217           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9218         enddo
9219       enddo
9220 #ifdef DEBUG
9221       write (iout,*) "gradbufc after summing"
9222       do i=1,nres
9223         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9224       enddo
9225       call flush(iout)
9226 #endif
9227       else
9228 #endif
9229 !el#define DEBUG
9230 #ifdef DEBUG
9231       write (iout,*) "gradbufc"
9232       do i=1,nres
9233         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9234       enddo
9235       call flush(iout)
9236 #endif
9237 !el#undef DEBUG
9238       do i=1,nres
9239         do j=1,3
9240           gradbufc_sum(j,i)=gradbufc(j,i)
9241           gradbufc(j,i)=0.0d0
9242         enddo
9243       enddo
9244       do j=1,3
9245         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9246       enddo
9247       do i=nres-2,nnt,-1
9248         do j=1,3
9249           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9250         enddo
9251       enddo
9252 !      do i=nnt,nres-1
9253 !        do k=1,3
9254 !          gradbufc(k,i)=0.0d0
9255 !        enddo
9256 !        do j=i+1,nres
9257 !          do k=1,3
9258 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9259 !          enddo
9260 !        enddo
9261 !      enddo
9262 !el#define DEBUG
9263 #ifdef DEBUG
9264       write (iout,*) "gradbufc after summing"
9265       do i=1,nres
9266         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9267       enddo
9268       call flush(iout)
9269 #endif
9270 !el#undef DEBUG
9271 #ifdef MPI
9272       endif
9273 #endif
9274       do k=1,3
9275         gradbufc(k,nres)=0.0d0
9276       enddo
9277 !el----------------
9278 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9279 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9280 !el-----------------
9281       do i=1,nct
9282         do j=1,3
9283 #ifdef SPLITELE
9284           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9285                       wel_loc*gel_loc(j,i)+ &
9286                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9287                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9288                       wel_loc*gel_loc_long(j,i)+ &
9289                       wcorr*gradcorr_long(j,i)+ &
9290                       wcorr5*gradcorr5_long(j,i)+ &
9291                       wcorr6*gradcorr6_long(j,i)+ &
9292                       wturn6*gcorr6_turn_long(j,i))+ &
9293                       wbond*gradb(j,i)+ &
9294                       wcorr*gradcorr(j,i)+ &
9295                       wturn3*gcorr3_turn(j,i)+ &
9296                       wturn4*gcorr4_turn(j,i)+ &
9297                       wcorr5*gradcorr5(j,i)+ &
9298                       wcorr6*gradcorr6(j,i)+ &
9299                       wturn6*gcorr6_turn(j,i)+ &
9300                       wsccor*gsccorc(j,i) &
9301                      +wscloc*gscloc(j,i)
9302 #else
9303           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9304                       wel_loc*gel_loc(j,i)+ &
9305                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9306                       welec*gelc_long(j,i)+ &
9307                       wel_loc*gel_loc_long(j,i)+ &
9308 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9309                       wcorr5*gradcorr5_long(j,i)+ &
9310                       wcorr6*gradcorr6_long(j,i)+ &
9311                       wturn6*gcorr6_turn_long(j,i))+ &
9312                       wbond*gradb(j,i)+ &
9313                       wcorr*gradcorr(j,i)+ &
9314                       wturn3*gcorr3_turn(j,i)+ &
9315                       wturn4*gcorr4_turn(j,i)+ &
9316                       wcorr5*gradcorr5(j,i)+ &
9317                       wcorr6*gradcorr6(j,i)+ &
9318                       wturn6*gcorr6_turn(j,i)+ &
9319                       wsccor*gsccorc(j,i) &
9320                      +wscloc*gscloc(j,i)
9321 #endif
9322           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9323                         wbond*gradbx(j,i)+ &
9324                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9325                         wsccor*gsccorx(j,i) &
9326                        +wscloc*gsclocx(j,i)
9327         enddo
9328       enddo
9329 #ifdef DEBUG
9330       write (iout,*) "gloc before adding corr"
9331       do i=1,4*nres
9332         write (iout,*) i,gloc(i,icg)
9333       enddo
9334 #endif
9335       do i=1,nres-3
9336         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9337          +wcorr5*g_corr5_loc(i) &
9338          +wcorr6*g_corr6_loc(i) &
9339          +wturn4*gel_loc_turn4(i) &
9340          +wturn3*gel_loc_turn3(i) &
9341          +wturn6*gel_loc_turn6(i) &
9342          +wel_loc*gel_loc_loc(i)
9343       enddo
9344 #ifdef DEBUG
9345       write (iout,*) "gloc after adding corr"
9346       do i=1,4*nres
9347         write (iout,*) i,gloc(i,icg)
9348       enddo
9349 #endif
9350 #ifdef MPI
9351       if (nfgtasks.gt.1) then
9352         do j=1,3
9353           do i=1,nres
9354             gradbufc(j,i)=gradc(j,i,icg)
9355             gradbufx(j,i)=gradx(j,i,icg)
9356           enddo
9357         enddo
9358         do i=1,4*nres
9359           glocbuf(i)=gloc(i,icg)
9360         enddo
9361 !#define DEBUG
9362 #ifdef DEBUG
9363       write (iout,*) "gloc_sc before reduce"
9364       do i=1,nres
9365        do j=1,1
9366         write (iout,*) i,j,gloc_sc(j,i,icg)
9367        enddo
9368       enddo
9369 #endif
9370 !#undef DEBUG
9371         do i=1,nres
9372          do j=1,3
9373           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9374          enddo
9375         enddo
9376         time00=MPI_Wtime()
9377         call MPI_Barrier(FG_COMM,IERR)
9378         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9379         time00=MPI_Wtime()
9380         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9381           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9382         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9383           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9384         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9385           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9386         time_reduce=time_reduce+MPI_Wtime()-time00
9387         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9388           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9389         time_reduce=time_reduce+MPI_Wtime()-time00
9390 !#define DEBUG
9391 #ifdef DEBUG
9392       write (iout,*) "gloc_sc after reduce"
9393       do i=1,nres
9394        do j=1,1
9395         write (iout,*) i,j,gloc_sc(j,i,icg)
9396        enddo
9397       enddo
9398 #endif
9399 !#undef DEBUG
9400 #ifdef DEBUG
9401       write (iout,*) "gloc after reduce"
9402       do i=1,4*nres
9403         write (iout,*) i,gloc(i,icg)
9404       enddo
9405 #endif
9406       endif
9407 #endif
9408       if (gnorm_check) then
9409 !
9410 ! Compute the maximum elements of the gradient
9411 !
9412       gvdwc_max=0.0d0
9413       gvdwc_scp_max=0.0d0
9414       gelc_max=0.0d0
9415       gvdwpp_max=0.0d0
9416       gradb_max=0.0d0
9417       ghpbc_max=0.0d0
9418       gradcorr_max=0.0d0
9419       gel_loc_max=0.0d0
9420       gcorr3_turn_max=0.0d0
9421       gcorr4_turn_max=0.0d0
9422       gradcorr5_max=0.0d0
9423       gradcorr6_max=0.0d0
9424       gcorr6_turn_max=0.0d0
9425       gsccorc_max=0.0d0
9426       gscloc_max=0.0d0
9427       gvdwx_max=0.0d0
9428       gradx_scp_max=0.0d0
9429       ghpbx_max=0.0d0
9430       gradxorr_max=0.0d0
9431       gsccorx_max=0.0d0
9432       gsclocx_max=0.0d0
9433       do i=1,nct
9434         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9435         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9436         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9437         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9438          gvdwc_scp_max=gvdwc_scp_norm
9439         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9440         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9441         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9442         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9443         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9444         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9445         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9446         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9447         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9448         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9449         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9450         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9451         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9452           gcorr3_turn(1,i)))
9453         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9454           gcorr3_turn_max=gcorr3_turn_norm
9455         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9456           gcorr4_turn(1,i)))
9457         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9458           gcorr4_turn_max=gcorr4_turn_norm
9459         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9460         if (gradcorr5_norm.gt.gradcorr5_max) &
9461           gradcorr5_max=gradcorr5_norm
9462         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9463         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9464         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9465           gcorr6_turn(1,i)))
9466         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9467           gcorr6_turn_max=gcorr6_turn_norm
9468         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9469         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9470         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9471         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9472         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9473         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9474         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9475         if (gradx_scp_norm.gt.gradx_scp_max) &
9476           gradx_scp_max=gradx_scp_norm
9477         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9478         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9479         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9480         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9481         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9482         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9483         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9484         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9485       enddo
9486       if (gradout) then
9487 #ifdef AIX
9488         open(istat,file=statname,position="append")
9489 #else
9490         open(istat,file=statname,access="append")
9491 #endif
9492         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9493            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9494            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9495            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9496            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9497            gsccorx_max,gsclocx_max
9498         close(istat)
9499         if (gvdwc_max.gt.1.0d4) then
9500           write (iout,*) "gvdwc gvdwx gradb gradbx"
9501           do i=nnt,nct
9502             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9503               gradb(j,i),gradbx(j,i),j=1,3)
9504           enddo
9505           call pdbout(0.0d0,'cipiszcze',iout)
9506           call flush(iout)
9507         endif
9508       endif
9509       endif
9510 !el#define DEBUG
9511 #ifdef DEBUG
9512       write (iout,*) "gradc gradx gloc"
9513       do i=1,nres
9514         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9515          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9516       enddo
9517 #endif
9518 !el#undef DEBUG
9519 #ifdef TIMING
9520       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9521 #endif
9522       return
9523       end subroutine sum_gradient
9524 !-----------------------------------------------------------------------------
9525       subroutine sc_grad
9526 !      implicit real*8 (a-h,o-z)
9527       use calc_data
9528 !      include 'DIMENSIONS'
9529 !      include 'COMMON.CHAIN'
9530 !      include 'COMMON.DERIV'
9531 !      include 'COMMON.CALC'
9532 !      include 'COMMON.IOUNITS'
9533       real(kind=8), dimension(3) :: dcosom1,dcosom2
9534
9535       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9536       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9537       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9538            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9539 ! diagnostics only
9540 !      eom1=0.0d0
9541 !      eom2=0.0d0
9542 !      eom12=evdwij*eps1_om12
9543 ! end diagnostics
9544 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9545 !       " sigder",sigder
9546 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9547 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9548       do k=1,3
9549         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9550         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9551       enddo
9552       do k=1,3
9553         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
9554       enddo
9555 !      write (iout,*) "gg",(gg(k),k=1,3)
9556       do k=1,3
9557         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9558                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9559                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9560         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9561                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9562                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9563 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9564 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9565 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9566 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9567       enddo
9568 !
9569 ! Calculate the components of the gradient in DC and X
9570 !
9571 !grad      do k=i,j-1
9572 !grad        do l=1,3
9573 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9574 !grad        enddo
9575 !grad      enddo
9576       do l=1,3
9577         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9578         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9579       enddo
9580       return
9581       end subroutine sc_grad
9582 #ifdef CRYST_THETA
9583 !-----------------------------------------------------------------------------
9584       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9585
9586       use comm_calcthet
9587 !      implicit real*8 (a-h,o-z)
9588 !      include 'DIMENSIONS'
9589 !      include 'COMMON.LOCAL'
9590 !      include 'COMMON.IOUNITS'
9591 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9592 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9593 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9594       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9595       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9596 !el      integer :: it
9597 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9598 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9599 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9600 !el local variables
9601
9602       delthec=thetai-thet_pred_mean
9603       delthe0=thetai-theta0i
9604 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9605       t3 = thetai-thet_pred_mean
9606       t6 = t3**2
9607       t9 = term1
9608       t12 = t3*sigcsq
9609       t14 = t12+t6*sigsqtc
9610       t16 = 1.0d0
9611       t21 = thetai-theta0i
9612       t23 = t21**2
9613       t26 = term2
9614       t27 = t21*t26
9615       t32 = termexp
9616       t40 = t32**2
9617       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9618        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9619        *(-t12*t9-ak*sig0inv*t27)
9620       return
9621       end subroutine mixder
9622 #endif
9623 !-----------------------------------------------------------------------------
9624 ! cartder.F
9625 !-----------------------------------------------------------------------------
9626       subroutine cartder
9627 !-----------------------------------------------------------------------------
9628 ! This subroutine calculates the derivatives of the consecutive virtual
9629 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9630 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9631 ! in the angles alpha and omega, describing the location of a side chain
9632 ! in its local coordinate system.
9633 !
9634 ! The derivatives are stored in the following arrays:
9635 !
9636 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9637 ! The structure is as follows:
9638 !
9639 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9640 ! 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)
9641 !         . . . . . . . . . . . .  . . . . . .
9642 ! 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)
9643 !                          .
9644 !                          .
9645 !                          .
9646 ! 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)
9647 !
9648 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9649 ! The structure is same as above.
9650 !
9651 ! DCDS - the derivatives of the side chain vectors in the local spherical
9652 ! andgles alph and omega:
9653 !
9654 ! 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)
9655 ! 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)
9656 !                          .
9657 !                          .
9658 !                          .
9659 ! 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)
9660 !
9661 ! Version of March '95, based on an early version of November '91.
9662 !
9663 !**********************************************************************
9664 !      implicit real*8 (a-h,o-z)
9665 !      include 'DIMENSIONS'
9666 !      include 'COMMON.VAR'
9667 !      include 'COMMON.CHAIN'
9668 !      include 'COMMON.DERIV'
9669 !      include 'COMMON.GEO'
9670 !      include 'COMMON.LOCAL'
9671 !      include 'COMMON.INTERACT'
9672       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9673       real(kind=8),dimension(3,3) :: dp,temp
9674 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9675       real(kind=8),dimension(3) :: xx,xx1
9676 !el local variables
9677       integer :: i,k,l,j,m,ind,ind1,jjj
9678       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9679                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9680                  sint2,xp,yp,xxp,yyp,zzp,dj
9681
9682 !      common /przechowalnia/ fromto
9683       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9684 ! get the position of the jth ijth fragment of the chain coordinate system
9685 ! in the fromto array.
9686 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9687 !
9688 !      maxdim=(nres-1)*(nres-2)/2
9689 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9690 ! calculate the derivatives of transformation matrix elements in theta
9691 !
9692
9693 !el      call flush(iout) !el
9694       do i=1,nres-2
9695         rdt(1,1,i)=-rt(1,2,i)
9696         rdt(1,2,i)= rt(1,1,i)
9697         rdt(1,3,i)= 0.0d0
9698         rdt(2,1,i)=-rt(2,2,i)
9699         rdt(2,2,i)= rt(2,1,i)
9700         rdt(2,3,i)= 0.0d0
9701         rdt(3,1,i)=-rt(3,2,i)
9702         rdt(3,2,i)= rt(3,1,i)
9703         rdt(3,3,i)= 0.0d0
9704       enddo
9705 !
9706 ! derivatives in phi
9707 !
9708       do i=2,nres-2
9709         drt(1,1,i)= 0.0d0
9710         drt(1,2,i)= 0.0d0
9711         drt(1,3,i)= 0.0d0
9712         drt(2,1,i)= rt(3,1,i)
9713         drt(2,2,i)= rt(3,2,i)
9714         drt(2,3,i)= rt(3,3,i)
9715         drt(3,1,i)=-rt(2,1,i)
9716         drt(3,2,i)=-rt(2,2,i)
9717         drt(3,3,i)=-rt(2,3,i)
9718       enddo
9719 !
9720 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9721 !
9722       do i=2,nres-2
9723         ind=indmat(i,i+1)
9724         do k=1,3
9725           do l=1,3
9726             temp(k,l)=rt(k,l,i)
9727           enddo
9728         enddo
9729         do k=1,3
9730           do l=1,3
9731             fromto(k,l,ind)=temp(k,l)
9732           enddo
9733         enddo
9734         do j=i+1,nres-2
9735           ind=indmat(i,j+1)
9736           do k=1,3
9737             do l=1,3
9738               dpkl=0.0d0
9739               do m=1,3
9740                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9741               enddo
9742               dp(k,l)=dpkl
9743               fromto(k,l,ind)=dpkl
9744             enddo
9745           enddo
9746           do k=1,3
9747             do l=1,3
9748               temp(k,l)=dp(k,l)
9749             enddo
9750           enddo
9751         enddo
9752       enddo
9753 !
9754 ! Calculate derivatives.
9755 !
9756       ind1=0
9757       do i=1,nres-2
9758         ind1=ind1+1
9759 !
9760 ! Derivatives of DC(i+1) in theta(i+2)
9761 !
9762         do j=1,3
9763           do k=1,2
9764             dpjk=0.0D0
9765             do l=1,3
9766               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9767             enddo
9768             dp(j,k)=dpjk
9769             prordt(j,k,i)=dp(j,k)
9770           enddo
9771           dp(j,3)=0.0D0
9772           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9773         enddo
9774 !
9775 ! Derivatives of SC(i+1) in theta(i+2)
9776 !
9777         xx1(1)=-0.5D0*xloc(2,i+1)
9778         xx1(2)= 0.5D0*xloc(1,i+1)
9779         do j=1,3
9780           xj=0.0D0
9781           do k=1,2
9782             xj=xj+r(j,k,i)*xx1(k)
9783           enddo
9784           xx(j)=xj
9785         enddo
9786         do j=1,3
9787           rj=0.0D0
9788           do k=1,3
9789             rj=rj+prod(j,k,i)*xx(k)
9790           enddo
9791           dxdv(j,ind1)=rj
9792         enddo
9793 !
9794 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9795 ! than the other off-diagonal derivatives.
9796 !
9797         do j=1,3
9798           dxoiij=0.0D0
9799           do k=1,3
9800             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9801           enddo
9802           dxdv(j,ind1+1)=dxoiij
9803         enddo
9804 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9805 !
9806 ! Derivatives of DC(i+1) in phi(i+2)
9807 !
9808         do j=1,3
9809           do k=1,3
9810             dpjk=0.0
9811             do l=2,3
9812               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9813             enddo
9814             dp(j,k)=dpjk
9815             prodrt(j,k,i)=dp(j,k)
9816           enddo
9817           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9818         enddo
9819 !
9820 ! Derivatives of SC(i+1) in phi(i+2)
9821 !
9822         xx(1)= 0.0D0
9823         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9824         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9825         do j=1,3
9826           rj=0.0D0
9827           do k=2,3
9828             rj=rj+prod(j,k,i)*xx(k)
9829           enddo
9830           dxdv(j+3,ind1)=-rj
9831         enddo
9832 !
9833 ! Derivatives of SC(i+1) in phi(i+3).
9834 !
9835         do j=1,3
9836           dxoiij=0.0D0
9837           do k=1,3
9838             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9839           enddo
9840           dxdv(j+3,ind1+1)=dxoiij
9841         enddo
9842 !
9843 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9844 ! theta(nres) and phi(i+3) thru phi(nres).
9845 !
9846         do j=i+1,nres-2
9847           ind1=ind1+1
9848           ind=indmat(i+1,j+1)
9849 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9850           do k=1,3
9851             do l=1,3
9852               tempkl=0.0D0
9853               do m=1,2
9854                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9855               enddo
9856               temp(k,l)=tempkl
9857             enddo
9858           enddo
9859 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9860 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9861 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9862 ! Derivatives of virtual-bond vectors in theta
9863           do k=1,3
9864             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9865           enddo
9866 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9867 ! Derivatives of SC vectors in theta
9868           do k=1,3
9869             dxoijk=0.0D0
9870             do l=1,3
9871               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9872             enddo
9873             dxdv(k,ind1+1)=dxoijk
9874           enddo
9875 !
9876 !--- Calculate the derivatives in phi
9877 !
9878           do k=1,3
9879             do l=1,3
9880               tempkl=0.0D0
9881               do m=1,3
9882                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9883               enddo
9884               temp(k,l)=tempkl
9885             enddo
9886           enddo
9887           do k=1,3
9888             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9889           enddo
9890           do k=1,3
9891             dxoijk=0.0D0
9892             do l=1,3
9893               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9894             enddo
9895             dxdv(k+3,ind1+1)=dxoijk
9896           enddo
9897         enddo
9898       enddo
9899 !
9900 ! Derivatives in alpha and omega:
9901 !
9902       do i=2,nres-1
9903 !       dsci=dsc(itype(i))
9904         dsci=vbld(i+nres)
9905 #ifdef OSF
9906         alphi=alph(i)
9907         omegi=omeg(i)
9908         if(alphi.ne.alphi) alphi=100.0
9909         if(omegi.ne.omegi) omegi=-100.0
9910 #else
9911         alphi=alph(i)
9912         omegi=omeg(i)
9913 #endif
9914 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
9915         cosalphi=dcos(alphi)
9916         sinalphi=dsin(alphi)
9917         cosomegi=dcos(omegi)
9918         sinomegi=dsin(omegi)
9919         temp(1,1)=-dsci*sinalphi
9920         temp(2,1)= dsci*cosalphi*cosomegi
9921         temp(3,1)=-dsci*cosalphi*sinomegi
9922         temp(1,2)=0.0D0
9923         temp(2,2)=-dsci*sinalphi*sinomegi
9924         temp(3,2)=-dsci*sinalphi*cosomegi
9925         theta2=pi-0.5D0*theta(i+1)
9926         cost2=dcos(theta2)
9927         sint2=dsin(theta2)
9928         jjj=0
9929 !d      print *,((temp(l,k),l=1,3),k=1,2)
9930         do j=1,2
9931           xp=temp(1,j)
9932           yp=temp(2,j)
9933           xxp= xp*cost2+yp*sint2
9934           yyp=-xp*sint2+yp*cost2
9935           zzp=temp(3,j)
9936           xx(1)=xxp
9937           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
9938           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
9939           do k=1,3
9940             dj=0.0D0
9941             do l=1,3
9942               dj=dj+prod(k,l,i-1)*xx(l)
9943             enddo
9944             dxds(jjj+k,i)=dj
9945           enddo
9946           jjj=jjj+3
9947         enddo
9948       enddo
9949       return
9950       end subroutine cartder
9951 !-----------------------------------------------------------------------------
9952 ! checkder_p.F
9953 !-----------------------------------------------------------------------------
9954       subroutine check_cartgrad
9955 ! Check the gradient of Cartesian coordinates in internal coordinates.
9956 !      implicit real*8 (a-h,o-z)
9957 !      include 'DIMENSIONS'
9958 !      include 'COMMON.IOUNITS'
9959 !      include 'COMMON.VAR'
9960 !      include 'COMMON.CHAIN'
9961 !      include 'COMMON.GEO'
9962 !      include 'COMMON.LOCAL'
9963 !      include 'COMMON.DERIV'
9964       real(kind=8),dimension(6,nres) :: temp
9965       real(kind=8),dimension(3) :: xx,gg
9966       integer :: i,k,j,ii
9967       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
9968 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9969 !
9970 ! Check the gradient of the virtual-bond and SC vectors in the internal
9971 ! coordinates.
9972 !
9973       aincr=1.0d-7
9974       aincr2=5.0d-8
9975       call cartder
9976       write (iout,'(a)') '**************** dx/dalpha'
9977       write (iout,'(a)')
9978       do i=2,nres-1
9979         alphi=alph(i)
9980         alph(i)=alph(i)+aincr
9981         do k=1,3
9982           temp(k,i)=dc(k,nres+i)
9983         enddo
9984         call chainbuild
9985         do k=1,3
9986           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
9987           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
9988         enddo
9989         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
9990         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
9991         write (iout,'(a)')
9992         alph(i)=alphi
9993         call chainbuild
9994       enddo
9995       write (iout,'(a)')
9996       write (iout,'(a)') '**************** dx/domega'
9997       write (iout,'(a)')
9998       do i=2,nres-1
9999         omegi=omeg(i)
10000         omeg(i)=omeg(i)+aincr
10001         do k=1,3
10002           temp(k,i)=dc(k,nres+i)
10003         enddo
10004         call chainbuild
10005         do k=1,3
10006           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10007           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10008                 (aincr*dabs(dxds(k+3,i))+aincr))
10009         enddo
10010         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10011             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10012         write (iout,'(a)')
10013         omeg(i)=omegi
10014         call chainbuild
10015       enddo
10016       write (iout,'(a)')
10017       write (iout,'(a)') '**************** dx/dtheta'
10018       write (iout,'(a)')
10019       do i=3,nres
10020         theti=theta(i)
10021         theta(i)=theta(i)+aincr
10022         do j=i-1,nres-1
10023           do k=1,3
10024             temp(k,j)=dc(k,nres+j)
10025           enddo
10026         enddo
10027         call chainbuild
10028         do j=i-1,nres-1
10029           ii = indmat(i-2,j)
10030 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10031           do k=1,3
10032             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10033             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10034                   (aincr*dabs(dxdv(k,ii))+aincr))
10035           enddo
10036           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10037               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10038           write(iout,'(a)')
10039         enddo
10040         write (iout,'(a)')
10041         theta(i)=theti
10042         call chainbuild
10043       enddo
10044       write (iout,'(a)') '***************** dx/dphi'
10045       write (iout,'(a)')
10046       do i=4,nres
10047         phi(i)=phi(i)+aincr
10048         do j=i-1,nres-1
10049           do k=1,3
10050             temp(k,j)=dc(k,nres+j)
10051           enddo
10052         enddo
10053         call chainbuild
10054         do j=i-1,nres-1
10055           ii = indmat(i-2,j)
10056 !         print *,'ii=',ii
10057           do k=1,3
10058             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10059             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10060                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10061           enddo
10062           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10063               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10064           write(iout,'(a)')
10065         enddo
10066         phi(i)=phi(i)-aincr
10067         call chainbuild
10068       enddo
10069       write (iout,'(a)') '****************** ddc/dtheta'
10070       do i=1,nres-2
10071         thet=theta(i+2)
10072         theta(i+2)=thet+aincr
10073         do j=i,nres
10074           do k=1,3
10075             temp(k,j)=dc(k,j)
10076           enddo
10077         enddo
10078         call chainbuild
10079         do j=i+1,nres-1
10080           ii = indmat(i,j)
10081 !         print *,'ii=',ii
10082           do k=1,3
10083             gg(k)=(dc(k,j)-temp(k,j))/aincr
10084             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10085                  (aincr*dabs(dcdv(k,ii))+aincr))
10086           enddo
10087           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10088                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10089           write (iout,'(a)')
10090         enddo
10091         do j=1,nres
10092           do k=1,3
10093             dc(k,j)=temp(k,j)
10094           enddo
10095         enddo
10096         theta(i+2)=thet
10097       enddo
10098       write (iout,'(a)') '******************* ddc/dphi'
10099       do i=1,nres-3
10100         phii=phi(i+3)
10101         phi(i+3)=phii+aincr
10102         do j=1,nres
10103           do k=1,3
10104             temp(k,j)=dc(k,j)
10105           enddo
10106         enddo
10107         call chainbuild
10108         do j=i+2,nres-1
10109           ii = indmat(i+1,j)
10110 !         print *,'ii=',ii
10111           do k=1,3
10112             gg(k)=(dc(k,j)-temp(k,j))/aincr
10113             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10114                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10115           enddo
10116           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10117                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10118           write (iout,'(a)')
10119         enddo
10120         do j=1,nres
10121           do k=1,3
10122             dc(k,j)=temp(k,j)
10123           enddo
10124         enddo
10125         phi(i+3)=phii
10126       enddo
10127       return
10128       end subroutine check_cartgrad
10129 !-----------------------------------------------------------------------------
10130       subroutine check_ecart
10131 ! Check the gradient of the energy in Cartesian coordinates.
10132 !     implicit real*8 (a-h,o-z)
10133 !     include 'DIMENSIONS'
10134 !     include 'COMMON.CHAIN'
10135 !     include 'COMMON.DERIV'
10136 !     include 'COMMON.IOUNITS'
10137 !     include 'COMMON.VAR'
10138 !     include 'COMMON.CONTACTS'
10139       use comm_srutu
10140 !el      integer :: icall
10141 !el      common /srutu/ icall
10142       real(kind=8),dimension(6) :: ggg
10143       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10144       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10145       real(kind=8),dimension(6,nres) :: grad_s
10146       real(kind=8),dimension(0:n_ene) :: energia,energia1
10147       integer :: uiparm(1)
10148       real(kind=8) :: urparm(1)
10149 !EL      external fdum
10150       integer :: nf,i,j,k
10151       real(kind=8) :: aincr,etot,etot1
10152       icg=1
10153       nf=0
10154       nfl=0
10155       call zerograd
10156       aincr=1.0D-7
10157       print '(a)','CG processor',me,' calling CHECK_CART.'
10158       nf=0
10159       icall=0
10160       call geom_to_var(nvar,x)
10161       call etotal(energia)
10162       etot=energia(0)
10163 !el      call enerprint(energia)
10164       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10165       icall =1
10166       do i=1,nres
10167         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10168       enddo
10169       do i=1,nres
10170         do j=1,3
10171           grad_s(j,i)=gradc(j,i,icg)
10172           grad_s(j+3,i)=gradx(j,i,icg)
10173         enddo
10174       enddo
10175       call flush(iout)
10176       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10177       do i=1,nres
10178         do j=1,3
10179           xx(j)=c(j,i+nres)
10180           ddc(j)=dc(j,i)
10181           ddx(j)=dc(j,i+nres)
10182         enddo
10183         do j=1,3
10184           dc(j,i)=dc(j,i)+aincr
10185           do k=i+1,nres
10186             c(j,k)=c(j,k)+aincr
10187             c(j,k+nres)=c(j,k+nres)+aincr
10188           enddo
10189           call etotal(energia1)
10190           etot1=energia1(0)
10191           ggg(j)=(etot1-etot)/aincr
10192           dc(j,i)=ddc(j)
10193           do k=i+1,nres
10194             c(j,k)=c(j,k)-aincr
10195             c(j,k+nres)=c(j,k+nres)-aincr
10196           enddo
10197         enddo
10198         do j=1,3
10199           c(j,i+nres)=c(j,i+nres)+aincr
10200           dc(j,i+nres)=dc(j,i+nres)+aincr
10201           call etotal(energia1)
10202           etot1=energia1(0)
10203           ggg(j+3)=(etot1-etot)/aincr
10204           c(j,i+nres)=xx(j)
10205           dc(j,i+nres)=ddx(j)
10206         enddo
10207         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10208          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10209       enddo
10210       return
10211       end subroutine check_ecart
10212 !-----------------------------------------------------------------------------
10213       subroutine check_ecartint
10214 ! Check the gradient of the energy in Cartesian coordinates.
10215       use io_base, only: intout
10216 !      implicit real*8 (a-h,o-z)
10217 !      include 'DIMENSIONS'
10218 !      include 'COMMON.CONTROL'
10219 !      include 'COMMON.CHAIN'
10220 !      include 'COMMON.DERIV'
10221 !      include 'COMMON.IOUNITS'
10222 !      include 'COMMON.VAR'
10223 !      include 'COMMON.CONTACTS'
10224 !      include 'COMMON.MD'
10225 !      include 'COMMON.LOCAL'
10226 !      include 'COMMON.SPLITELE'
10227       use comm_srutu
10228 !el      integer :: icall
10229 !el      common /srutu/ icall
10230       real(kind=8),dimension(6) :: ggg,ggg1
10231       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10232       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10233       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10234       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10235       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10236       real(kind=8),dimension(0:n_ene) :: energia,energia1
10237       integer :: uiparm(1)
10238       real(kind=8) :: urparm(1)
10239 !EL      external fdum
10240       integer :: i,j,k,nf
10241       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10242                    etot21,etot22
10243       r_cut=2.0d0
10244       rlambd=0.3d0
10245       icg=1
10246       nf=0
10247       nfl=0
10248       call intout
10249 !      call intcartderiv
10250 !      call checkintcartgrad
10251       call zerograd
10252       aincr=1.0D-5
10253       write(iout,*) 'Calling CHECK_ECARTINT.'
10254       nf=0
10255       icall=0
10256       call geom_to_var(nvar,x)
10257       if (.not.split_ene) then
10258         call etotal(energia)
10259         etot=energia(0)
10260 !el        call enerprint(energia)
10261         call flush(iout)
10262         write (iout,*) "enter cartgrad"
10263         call flush(iout)
10264         call cartgrad
10265         write (iout,*) "exit cartgrad"
10266         call flush(iout)
10267         icall =1
10268         do i=1,nres
10269           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10270         enddo
10271         do j=1,3
10272           grad_s(j,0)=gcart(j,0)
10273         enddo
10274         do i=1,nres
10275           do j=1,3
10276             grad_s(j,i)=gcart(j,i)
10277             grad_s(j+3,i)=gxcart(j,i)
10278           enddo
10279         enddo
10280       else
10281 !- split gradient check
10282         call zerograd
10283         call etotal_long(energia)
10284 !el        call enerprint(energia)
10285         call flush(iout)
10286         write (iout,*) "enter cartgrad"
10287         call flush(iout)
10288         call cartgrad
10289         write (iout,*) "exit cartgrad"
10290         call flush(iout)
10291         icall =1
10292         write (iout,*) "longrange grad"
10293         do i=1,nres
10294           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10295           (gxcart(j,i),j=1,3)
10296         enddo
10297         do j=1,3
10298           grad_s(j,0)=gcart(j,0)
10299         enddo
10300         do i=1,nres
10301           do j=1,3
10302             grad_s(j,i)=gcart(j,i)
10303             grad_s(j+3,i)=gxcart(j,i)
10304           enddo
10305         enddo
10306         call zerograd
10307         call etotal_short(energia)
10308 !el        call enerprint(energia)
10309         call flush(iout)
10310         write (iout,*) "enter cartgrad"
10311         call flush(iout)
10312         call cartgrad
10313         write (iout,*) "exit cartgrad"
10314         call flush(iout)
10315         icall =1
10316         write (iout,*) "shortrange grad"
10317         do i=1,nres
10318           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10319           (gxcart(j,i),j=1,3)
10320         enddo
10321         do j=1,3
10322           grad_s1(j,0)=gcart(j,0)
10323         enddo
10324         do i=1,nres
10325           do j=1,3
10326             grad_s1(j,i)=gcart(j,i)
10327             grad_s1(j+3,i)=gxcart(j,i)
10328           enddo
10329         enddo
10330       endif
10331       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10332       do i=0,nres
10333         do j=1,3
10334           xx(j)=c(j,i+nres)
10335           ddc(j)=dc(j,i)
10336           ddx(j)=dc(j,i+nres)
10337           do k=1,3
10338             dcnorm_safe(k)=dc_norm(k,i)
10339             dxnorm_safe(k)=dc_norm(k,i+nres)
10340           enddo
10341         enddo
10342         do j=1,3
10343           dc(j,i)=ddc(j)+aincr
10344           call chainbuild_cart
10345 #ifdef MPI
10346 ! Broadcast the order to compute internal coordinates to the slaves.
10347 !          if (nfgtasks.gt.1)
10348 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10349 #endif
10350 !          call int_from_cart1(.false.)
10351           if (.not.split_ene) then
10352             call etotal(energia1)
10353             etot1=energia1(0)
10354           else
10355 !- split gradient
10356             call etotal_long(energia1)
10357             etot11=energia1(0)
10358             call etotal_short(energia1)
10359             etot12=energia1(0)
10360 !            write (iout,*) "etot11",etot11," etot12",etot12
10361           endif
10362 !- end split gradient
10363 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10364           dc(j,i)=ddc(j)-aincr
10365           call chainbuild_cart
10366 !          call int_from_cart1(.false.)
10367           if (.not.split_ene) then
10368             call etotal(energia1)
10369             etot2=energia1(0)
10370             ggg(j)=(etot1-etot2)/(2*aincr)
10371           else
10372 !- split gradient
10373             call etotal_long(energia1)
10374             etot21=energia1(0)
10375             ggg(j)=(etot11-etot21)/(2*aincr)
10376             call etotal_short(energia1)
10377             etot22=energia1(0)
10378             ggg1(j)=(etot12-etot22)/(2*aincr)
10379 !- end split gradient
10380 !            write (iout,*) "etot21",etot21," etot22",etot22
10381           endif
10382 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10383           dc(j,i)=ddc(j)
10384           call chainbuild_cart
10385         enddo
10386         do j=1,3
10387           dc(j,i+nres)=ddx(j)+aincr
10388           call chainbuild_cart
10389 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10390 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10391 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10392 !          write (iout,*) "dxnormnorm",dsqrt(
10393 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10394 !          write (iout,*) "dxnormnormsafe",dsqrt(
10395 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10396 !          write (iout,*)
10397           if (.not.split_ene) then
10398             call etotal(energia1)
10399             etot1=energia1(0)
10400           else
10401 !- split gradient
10402             call etotal_long(energia1)
10403             etot11=energia1(0)
10404             call etotal_short(energia1)
10405             etot12=energia1(0)
10406           endif
10407 !- end split gradient
10408 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10409           dc(j,i+nres)=ddx(j)-aincr
10410           call chainbuild_cart
10411 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10412 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10413 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10414 !          write (iout,*)
10415 !          write (iout,*) "dxnormnorm",dsqrt(
10416 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10417 !          write (iout,*) "dxnormnormsafe",dsqrt(
10418 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10419           if (.not.split_ene) then
10420             call etotal(energia1)
10421             etot2=energia1(0)
10422             ggg(j+3)=(etot1-etot2)/(2*aincr)
10423           else
10424 !- split gradient
10425             call etotal_long(energia1)
10426             etot21=energia1(0)
10427             ggg(j+3)=(etot11-etot21)/(2*aincr)
10428             call etotal_short(energia1)
10429             etot22=energia1(0)
10430             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10431 !- end split gradient
10432           endif
10433 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10434           dc(j,i+nres)=ddx(j)
10435           call chainbuild_cart
10436         enddo
10437         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10438          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10439         if (split_ene) then
10440           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10441          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10442          k=1,6)
10443          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10444          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10445          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10446         endif
10447       enddo
10448       return
10449       end subroutine check_ecartint
10450 !-----------------------------------------------------------------------------
10451       subroutine check_eint
10452 ! Check the gradient of energy in internal coordinates.
10453 !      implicit real*8 (a-h,o-z)
10454 !      include 'DIMENSIONS'
10455 !      include 'COMMON.CHAIN'
10456 !      include 'COMMON.DERIV'
10457 !      include 'COMMON.IOUNITS'
10458 !      include 'COMMON.VAR'
10459 !      include 'COMMON.GEO'
10460       use comm_srutu
10461 !el      integer :: icall
10462 !el      common /srutu/ icall
10463       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10464       integer :: uiparm(1)
10465       real(kind=8) :: urparm(1)
10466       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10467       character(len=6) :: key
10468 !EL      external fdum
10469       integer :: i,ii,nf
10470       real(kind=8) :: xi,aincr,etot,etot1,etot2
10471       call zerograd
10472       aincr=1.0D-7
10473       print '(a)','Calling CHECK_INT.'
10474       nf=0
10475       nfl=0
10476       icg=1
10477       call geom_to_var(nvar,x)
10478       call var_to_geom(nvar,x)
10479       call chainbuild
10480       icall=1
10481       print *,'ICG=',ICG
10482       call etotal(energia)
10483       etot = energia(0)
10484 !el      call enerprint(energia)
10485       print *,'ICG=',ICG
10486 #ifdef MPL
10487       if (MyID.ne.BossID) then
10488         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10489         nf=x(nvar+1)
10490         nfl=x(nvar+2)
10491         icg=x(nvar+3)
10492       endif
10493 #endif
10494       nf=1
10495       nfl=3
10496 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10497       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10498 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10499       icall=1
10500       do i=1,nvar
10501         xi=x(i)
10502         x(i)=xi-0.5D0*aincr
10503         call var_to_geom(nvar,x)
10504         call chainbuild
10505         call etotal(energia1)
10506         etot1=energia1(0)
10507         x(i)=xi+0.5D0*aincr
10508         call var_to_geom(nvar,x)
10509         call chainbuild
10510         call etotal(energia2)
10511         etot2=energia2(0)
10512         gg(i)=(etot2-etot1)/aincr
10513         write (iout,*) i,etot1,etot2
10514         x(i)=xi
10515       enddo
10516       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10517           '     RelDiff*100% '
10518       do i=1,nvar
10519         if (i.le.nphi) then
10520           ii=i
10521           key = ' phi'
10522         else if (i.le.nphi+ntheta) then
10523           ii=i-nphi
10524           key=' theta'
10525         else if (i.le.nphi+ntheta+nside) then
10526            ii=i-(nphi+ntheta)
10527            key=' alpha'
10528         else
10529            ii=i-(nphi+ntheta+nside)
10530            key=' omega'
10531         endif
10532         write (iout,'(i3,a,i3,3(1pd16.6))') &
10533        i,key,ii,gg(i),gana(i),&
10534        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10535       enddo
10536       return
10537       end subroutine check_eint
10538 !-----------------------------------------------------------------------------
10539 ! econstr_local.F
10540 !-----------------------------------------------------------------------------
10541       subroutine Econstr_back
10542 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10543 !      implicit real*8 (a-h,o-z)
10544 !      include 'DIMENSIONS'
10545 !      include 'COMMON.CONTROL'
10546 !      include 'COMMON.VAR'
10547 !      include 'COMMON.MD'
10548       use MD_data
10549 !#ifndef LANG0
10550 !      include 'COMMON.LANGEVIN'
10551 !#else
10552 !      include 'COMMON.LANGEVIN.lang0'
10553 !#endif
10554 !      include 'COMMON.CHAIN'
10555 !      include 'COMMON.DERIV'
10556 !      include 'COMMON.GEO'
10557 !      include 'COMMON.LOCAL'
10558 !      include 'COMMON.INTERACT'
10559 !      include 'COMMON.IOUNITS'
10560 !      include 'COMMON.NAMES'
10561 !      include 'COMMON.TIME1'
10562       integer :: i,j,ii,k
10563       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10564
10565       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10566       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10567       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10568
10569       Uconst_back=0.0d0
10570       do i=1,nres
10571         dutheta(i)=0.0d0
10572         dugamma(i)=0.0d0
10573         do j=1,3
10574           duscdiff(j,i)=0.0d0
10575           duscdiffx(j,i)=0.0d0
10576         enddo
10577       enddo
10578       do i=1,nfrag_back
10579         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10580 !
10581 ! Deviations from theta angles
10582 !
10583         utheta_i=0.0d0
10584         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10585           dtheta_i=theta(j)-thetaref(j)
10586           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10587           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10588         enddo
10589         utheta(i)=utheta_i/(ii-1)
10590 !
10591 ! Deviations from gamma angles
10592 !
10593         ugamma_i=0.0d0
10594         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10595           dgamma_i=pinorm(phi(j)-phiref(j))
10596 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10597           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10598           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10599 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10600         enddo
10601         ugamma(i)=ugamma_i/(ii-2)
10602 !
10603 ! Deviations from local SC geometry
10604 !
10605         uscdiff(i)=0.0d0
10606         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10607           dxx=xxtab(j)-xxref(j)
10608           dyy=yytab(j)-yyref(j)
10609           dzz=zztab(j)-zzref(j)
10610           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10611           do k=1,3
10612             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10613              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10614              (ii-1)
10615             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10616              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10617              (ii-1)
10618             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10619            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10620             /(ii-1)
10621           enddo
10622 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10623 !     &      xxref(j),yyref(j),zzref(j)
10624         enddo
10625         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10626 !        write (iout,*) i," uscdiff",uscdiff(i)
10627 !
10628 ! Put together deviations from local geometry
10629 !
10630         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10631           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10632 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10633 !     &   " uconst_back",uconst_back
10634         utheta(i)=dsqrt(utheta(i))
10635         ugamma(i)=dsqrt(ugamma(i))
10636         uscdiff(i)=dsqrt(uscdiff(i))
10637       enddo
10638       return
10639       end subroutine Econstr_back
10640 !-----------------------------------------------------------------------------
10641 ! energy_p_new-sep_barrier.F
10642 !-----------------------------------------------------------------------------
10643       real(kind=8) function sscale(r)
10644 !      include "COMMON.SPLITELE"
10645       real(kind=8) :: r,gamm
10646       if(r.lt.r_cut-rlamb) then
10647         sscale=1.0d0
10648       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10649         gamm=(r-(r_cut-rlamb))/rlamb
10650         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10651       else
10652         sscale=0d0
10653       endif
10654       return
10655       end function sscale
10656 !-----------------------------------------------------------------------------
10657       subroutine elj_long(evdw)
10658 !
10659 ! This subroutine calculates the interaction energy of nonbonded side chains
10660 ! assuming the LJ potential of interaction.
10661 !
10662 !      implicit real*8 (a-h,o-z)
10663 !      include 'DIMENSIONS'
10664 !      include 'COMMON.GEO'
10665 !      include 'COMMON.VAR'
10666 !      include 'COMMON.LOCAL'
10667 !      include 'COMMON.CHAIN'
10668 !      include 'COMMON.DERIV'
10669 !      include 'COMMON.INTERACT'
10670 !      include 'COMMON.TORSION'
10671 !      include 'COMMON.SBRIDGE'
10672 !      include 'COMMON.NAMES'
10673 !      include 'COMMON.IOUNITS'
10674 !      include 'COMMON.CONTACTS'
10675       real(kind=8),parameter :: accur=1.0d-10
10676       real(kind=8),dimension(3) :: gg
10677 !el local variables
10678       integer :: i,iint,j,k,itypi,itypi1,itypj
10679       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10680       real(kind=8) :: e1,e2,evdwij,evdw
10681 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10682       evdw=0.0D0
10683       do i=iatsc_s,iatsc_e
10684         itypi=itype(i)
10685         if (itypi.eq.ntyp1) cycle
10686         itypi1=itype(i+1)
10687         xi=c(1,nres+i)
10688         yi=c(2,nres+i)
10689         zi=c(3,nres+i)
10690 !
10691 ! Calculate SC interaction energy.
10692 !
10693         do iint=1,nint_gr(i)
10694 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10695 !d   &                  'iend=',iend(i,iint)
10696           do j=istart(i,iint),iend(i,iint)
10697             itypj=itype(j)
10698             if (itypj.eq.ntyp1) cycle
10699             xj=c(1,nres+j)-xi
10700             yj=c(2,nres+j)-yi
10701             zj=c(3,nres+j)-zi
10702             rij=xj*xj+yj*yj+zj*zj
10703             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10704             if (sss.lt.1.0d0) then
10705               rrij=1.0D0/rij
10706               eps0ij=eps(itypi,itypj)
10707               fac=rrij**expon2
10708               e1=fac*fac*aa(itypi,itypj)
10709               e2=fac*bb(itypi,itypj)
10710               evdwij=e1+e2
10711               evdw=evdw+(1.0d0-sss)*evdwij
10712 !
10713 ! Calculate the components of the gradient in DC and X
10714 !
10715               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
10716               gg(1)=xj*fac
10717               gg(2)=yj*fac
10718               gg(3)=zj*fac
10719               do k=1,3
10720                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10721                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10722                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10723                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10724               enddo
10725             endif
10726           enddo      ! j
10727         enddo        ! iint
10728       enddo          ! i
10729       do i=1,nct
10730         do j=1,3
10731           gvdwc(j,i)=expon*gvdwc(j,i)
10732           gvdwx(j,i)=expon*gvdwx(j,i)
10733         enddo
10734       enddo
10735 !******************************************************************************
10736 !
10737 !                              N O T E !!!
10738 !
10739 ! To save time, the factor of EXPON has been extracted from ALL components
10740 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10741 ! use!
10742 !
10743 !******************************************************************************
10744       return
10745       end subroutine elj_long
10746 !-----------------------------------------------------------------------------
10747       subroutine elj_short(evdw)
10748 !
10749 ! This subroutine calculates the interaction energy of nonbonded side chains
10750 ! assuming the LJ potential of interaction.
10751 !
10752 !      implicit real*8 (a-h,o-z)
10753 !      include 'DIMENSIONS'
10754 !      include 'COMMON.GEO'
10755 !      include 'COMMON.VAR'
10756 !      include 'COMMON.LOCAL'
10757 !      include 'COMMON.CHAIN'
10758 !      include 'COMMON.DERIV'
10759 !      include 'COMMON.INTERACT'
10760 !      include 'COMMON.TORSION'
10761 !      include 'COMMON.SBRIDGE'
10762 !      include 'COMMON.NAMES'
10763 !      include 'COMMON.IOUNITS'
10764 !      include 'COMMON.CONTACTS'
10765       real(kind=8),parameter :: accur=1.0d-10
10766       real(kind=8),dimension(3) :: gg
10767 !el local variables
10768       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
10769       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10770       real(kind=8) :: e1,e2,evdwij,evdw
10771 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10772       evdw=0.0D0
10773       do i=iatsc_s,iatsc_e
10774         itypi=itype(i)
10775         if (itypi.eq.ntyp1) cycle
10776         itypi1=itype(i+1)
10777         xi=c(1,nres+i)
10778         yi=c(2,nres+i)
10779         zi=c(3,nres+i)
10780 ! Change 12/1/95
10781         num_conti=0
10782 !
10783 ! Calculate SC interaction energy.
10784 !
10785         do iint=1,nint_gr(i)
10786 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10787 !d   &                  'iend=',iend(i,iint)
10788           do j=istart(i,iint),iend(i,iint)
10789             itypj=itype(j)
10790             if (itypj.eq.ntyp1) cycle
10791             xj=c(1,nres+j)-xi
10792             yj=c(2,nres+j)-yi
10793             zj=c(3,nres+j)-zi
10794 ! Change 12/1/95 to calculate four-body interactions
10795             rij=xj*xj+yj*yj+zj*zj
10796             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10797             if (sss.gt.0.0d0) then
10798               rrij=1.0D0/rij
10799               eps0ij=eps(itypi,itypj)
10800               fac=rrij**expon2
10801               e1=fac*fac*aa(itypi,itypj)
10802               e2=fac*bb(itypi,itypj)
10803               evdwij=e1+e2
10804               evdw=evdw+sss*evdwij
10805 !
10806 ! Calculate the components of the gradient in DC and X
10807 !
10808               fac=-rrij*(e1+evdwij)*sss
10809               gg(1)=xj*fac
10810               gg(2)=yj*fac
10811               gg(3)=zj*fac
10812               do k=1,3
10813                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10814                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10815                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10816                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10817               enddo
10818             endif
10819           enddo      ! j
10820         enddo        ! iint
10821       enddo          ! i
10822       do i=1,nct
10823         do j=1,3
10824           gvdwc(j,i)=expon*gvdwc(j,i)
10825           gvdwx(j,i)=expon*gvdwx(j,i)
10826         enddo
10827       enddo
10828 !******************************************************************************
10829 !
10830 !                              N O T E !!!
10831 !
10832 ! To save time, the factor of EXPON has been extracted from ALL components
10833 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10834 ! use!
10835 !
10836 !******************************************************************************
10837       return
10838       end subroutine elj_short
10839 !-----------------------------------------------------------------------------
10840       subroutine eljk_long(evdw)
10841 !
10842 ! This subroutine calculates the interaction energy of nonbonded side chains
10843 ! assuming the LJK potential of interaction.
10844 !
10845 !      implicit real*8 (a-h,o-z)
10846 !      include 'DIMENSIONS'
10847 !      include 'COMMON.GEO'
10848 !      include 'COMMON.VAR'
10849 !      include 'COMMON.LOCAL'
10850 !      include 'COMMON.CHAIN'
10851 !      include 'COMMON.DERIV'
10852 !      include 'COMMON.INTERACT'
10853 !      include 'COMMON.IOUNITS'
10854 !      include 'COMMON.NAMES'
10855       real(kind=8),dimension(3) :: gg
10856       logical :: scheck
10857 !el local variables
10858       integer :: i,iint,j,k,itypi,itypi1,itypj
10859       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10860                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10861 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10862       evdw=0.0D0
10863       do i=iatsc_s,iatsc_e
10864         itypi=itype(i)
10865         if (itypi.eq.ntyp1) cycle
10866         itypi1=itype(i+1)
10867         xi=c(1,nres+i)
10868         yi=c(2,nres+i)
10869         zi=c(3,nres+i)
10870 !
10871 ! Calculate SC interaction energy.
10872 !
10873         do iint=1,nint_gr(i)
10874           do j=istart(i,iint),iend(i,iint)
10875             itypj=itype(j)
10876             if (itypj.eq.ntyp1) cycle
10877             xj=c(1,nres+j)-xi
10878             yj=c(2,nres+j)-yi
10879             zj=c(3,nres+j)-zi
10880             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10881             fac_augm=rrij**expon
10882             e_augm=augm(itypi,itypj)*fac_augm
10883             r_inv_ij=dsqrt(rrij)
10884             rij=1.0D0/r_inv_ij
10885             sss=sscale(rij/sigma(itypi,itypj))
10886             if (sss.lt.1.0d0) then
10887               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10888               fac=r_shift_inv**expon
10889               e1=fac*fac*aa(itypi,itypj)
10890               e2=fac*bb(itypi,itypj)
10891               evdwij=e_augm+e1+e2
10892 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10893 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10894 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10895 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10896 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10897 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10898 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10899               evdw=evdw+(1.0d0-sss)*evdwij
10900 !
10901 ! Calculate the components of the gradient in DC and X
10902 !
10903               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10904               fac=fac*(1.0d0-sss)
10905               gg(1)=xj*fac
10906               gg(2)=yj*fac
10907               gg(3)=zj*fac
10908               do k=1,3
10909                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10910                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10911                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10912                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10913               enddo
10914             endif
10915           enddo      ! j
10916         enddo        ! iint
10917       enddo          ! i
10918       do i=1,nct
10919         do j=1,3
10920           gvdwc(j,i)=expon*gvdwc(j,i)
10921           gvdwx(j,i)=expon*gvdwx(j,i)
10922         enddo
10923       enddo
10924       return
10925       end subroutine eljk_long
10926 !-----------------------------------------------------------------------------
10927       subroutine eljk_short(evdw)
10928 !
10929 ! This subroutine calculates the interaction energy of nonbonded side chains
10930 ! assuming the LJK potential of interaction.
10931 !
10932 !      implicit real*8 (a-h,o-z)
10933 !      include 'DIMENSIONS'
10934 !      include 'COMMON.GEO'
10935 !      include 'COMMON.VAR'
10936 !      include 'COMMON.LOCAL'
10937 !      include 'COMMON.CHAIN'
10938 !      include 'COMMON.DERIV'
10939 !      include 'COMMON.INTERACT'
10940 !      include 'COMMON.IOUNITS'
10941 !      include 'COMMON.NAMES'
10942       real(kind=8),dimension(3) :: gg
10943       logical :: scheck
10944 !el local variables
10945       integer :: i,iint,j,k,itypi,itypi1,itypj
10946       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10947                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10948 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10949       evdw=0.0D0
10950       do i=iatsc_s,iatsc_e
10951         itypi=itype(i)
10952         if (itypi.eq.ntyp1) cycle
10953         itypi1=itype(i+1)
10954         xi=c(1,nres+i)
10955         yi=c(2,nres+i)
10956         zi=c(3,nres+i)
10957 !
10958 ! Calculate SC interaction energy.
10959 !
10960         do iint=1,nint_gr(i)
10961           do j=istart(i,iint),iend(i,iint)
10962             itypj=itype(j)
10963             if (itypj.eq.ntyp1) cycle
10964             xj=c(1,nres+j)-xi
10965             yj=c(2,nres+j)-yi
10966             zj=c(3,nres+j)-zi
10967             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10968             fac_augm=rrij**expon
10969             e_augm=augm(itypi,itypj)*fac_augm
10970             r_inv_ij=dsqrt(rrij)
10971             rij=1.0D0/r_inv_ij
10972             sss=sscale(rij/sigma(itypi,itypj))
10973             if (sss.gt.0.0d0) then
10974               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10975               fac=r_shift_inv**expon
10976               e1=fac*fac*aa(itypi,itypj)
10977               e2=fac*bb(itypi,itypj)
10978               evdwij=e_augm+e1+e2
10979 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10980 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10981 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10982 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10983 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10984 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10985 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10986               evdw=evdw+sss*evdwij
10987 !
10988 ! Calculate the components of the gradient in DC and X
10989 !
10990               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10991               fac=fac*sss
10992               gg(1)=xj*fac
10993               gg(2)=yj*fac
10994               gg(3)=zj*fac
10995               do k=1,3
10996                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10997                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10998                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10999                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11000               enddo
11001             endif
11002           enddo      ! j
11003         enddo        ! iint
11004       enddo          ! i
11005       do i=1,nct
11006         do j=1,3
11007           gvdwc(j,i)=expon*gvdwc(j,i)
11008           gvdwx(j,i)=expon*gvdwx(j,i)
11009         enddo
11010       enddo
11011       return
11012       end subroutine eljk_short
11013 !-----------------------------------------------------------------------------
11014       subroutine ebp_long(evdw)
11015 !
11016 ! This subroutine calculates the interaction energy of nonbonded side chains
11017 ! assuming the Berne-Pechukas potential of interaction.
11018 !
11019       use calc_data
11020 !      implicit real*8 (a-h,o-z)
11021 !      include 'DIMENSIONS'
11022 !      include 'COMMON.GEO'
11023 !      include 'COMMON.VAR'
11024 !      include 'COMMON.LOCAL'
11025 !      include 'COMMON.CHAIN'
11026 !      include 'COMMON.DERIV'
11027 !      include 'COMMON.NAMES'
11028 !      include 'COMMON.INTERACT'
11029 !      include 'COMMON.IOUNITS'
11030 !      include 'COMMON.CALC'
11031       use comm_srutu
11032 !el      integer :: icall
11033 !el      common /srutu/ icall
11034 !     double precision rrsave(maxdim)
11035       logical :: lprn
11036 !el local variables
11037       integer :: iint,itypi,itypi1,itypj
11038       real(kind=8) :: rrij,xi,yi,zi,fac
11039       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11040       evdw=0.0D0
11041 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11042       evdw=0.0D0
11043 !     if (icall.eq.0) then
11044 !       lprn=.true.
11045 !     else
11046         lprn=.false.
11047 !     endif
11048 !el      ind=0
11049       do i=iatsc_s,iatsc_e
11050         itypi=itype(i)
11051         if (itypi.eq.ntyp1) cycle
11052         itypi1=itype(i+1)
11053         xi=c(1,nres+i)
11054         yi=c(2,nres+i)
11055         zi=c(3,nres+i)
11056         dxi=dc_norm(1,nres+i)
11057         dyi=dc_norm(2,nres+i)
11058         dzi=dc_norm(3,nres+i)
11059 !        dsci_inv=dsc_inv(itypi)
11060         dsci_inv=vbld_inv(i+nres)
11061 !
11062 ! Calculate SC interaction energy.
11063 !
11064         do iint=1,nint_gr(i)
11065           do j=istart(i,iint),iend(i,iint)
11066 !el            ind=ind+1
11067             itypj=itype(j)
11068             if (itypj.eq.ntyp1) cycle
11069 !            dscj_inv=dsc_inv(itypj)
11070             dscj_inv=vbld_inv(j+nres)
11071             chi1=chi(itypi,itypj)
11072             chi2=chi(itypj,itypi)
11073             chi12=chi1*chi2
11074             chip1=chip(itypi)
11075             chip2=chip(itypj)
11076             chip12=chip1*chip2
11077             alf1=alp(itypi)
11078             alf2=alp(itypj)
11079             alf12=0.5D0*(alf1+alf2)
11080             xj=c(1,nres+j)-xi
11081             yj=c(2,nres+j)-yi
11082             zj=c(3,nres+j)-zi
11083             dxj=dc_norm(1,nres+j)
11084             dyj=dc_norm(2,nres+j)
11085             dzj=dc_norm(3,nres+j)
11086             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11087             rij=dsqrt(rrij)
11088             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11089
11090             if (sss.lt.1.0d0) then
11091
11092 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11093               call sc_angular
11094 ! Calculate whole angle-dependent part of epsilon and contributions
11095 ! to its derivatives
11096               fac=(rrij*sigsq)**expon2
11097               e1=fac*fac*aa(itypi,itypj)
11098               e2=fac*bb(itypi,itypj)
11099               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11100               eps2der=evdwij*eps3rt
11101               eps3der=evdwij*eps2rt
11102               evdwij=evdwij*eps2rt*eps3rt
11103               evdw=evdw+evdwij*(1.0d0-sss)
11104               if (lprn) then
11105               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11106               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11107 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11108 !d     &          restyp(itypi),i,restyp(itypj),j,
11109 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11110 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11111 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11112 !d     &          evdwij
11113               endif
11114 ! Calculate gradient components.
11115               e1=e1*eps1*eps2rt**2*eps3rt**2
11116               fac=-expon*(e1+evdwij)
11117               sigder=fac/sigsq
11118               fac=rrij*fac
11119 ! Calculate radial part of the gradient
11120               gg(1)=xj*fac
11121               gg(2)=yj*fac
11122               gg(3)=zj*fac
11123 ! Calculate the angular part of the gradient and sum add the contributions
11124 ! to the appropriate components of the Cartesian gradient.
11125               call sc_grad_scale(1.0d0-sss)
11126             endif
11127           enddo      ! j
11128         enddo        ! iint
11129       enddo          ! i
11130 !     stop
11131       return
11132       end subroutine ebp_long
11133 !-----------------------------------------------------------------------------
11134       subroutine ebp_short(evdw)
11135 !
11136 ! This subroutine calculates the interaction energy of nonbonded side chains
11137 ! assuming the Berne-Pechukas potential of interaction.
11138 !
11139       use calc_data
11140 !      implicit real*8 (a-h,o-z)
11141 !      include 'DIMENSIONS'
11142 !      include 'COMMON.GEO'
11143 !      include 'COMMON.VAR'
11144 !      include 'COMMON.LOCAL'
11145 !      include 'COMMON.CHAIN'
11146 !      include 'COMMON.DERIV'
11147 !      include 'COMMON.NAMES'
11148 !      include 'COMMON.INTERACT'
11149 !      include 'COMMON.IOUNITS'
11150 !      include 'COMMON.CALC'
11151       use comm_srutu
11152 !el      integer :: icall
11153 !el      common /srutu/ icall
11154 !     double precision rrsave(maxdim)
11155       logical :: lprn
11156 !el local variables
11157       integer :: iint,itypi,itypi1,itypj
11158       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11159       real(kind=8) :: sss,e1,e2,evdw
11160       evdw=0.0D0
11161 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11162       evdw=0.0D0
11163 !     if (icall.eq.0) then
11164 !       lprn=.true.
11165 !     else
11166         lprn=.false.
11167 !     endif
11168 !el      ind=0
11169       do i=iatsc_s,iatsc_e
11170         itypi=itype(i)
11171         if (itypi.eq.ntyp1) cycle
11172         itypi1=itype(i+1)
11173         xi=c(1,nres+i)
11174         yi=c(2,nres+i)
11175         zi=c(3,nres+i)
11176         dxi=dc_norm(1,nres+i)
11177         dyi=dc_norm(2,nres+i)
11178         dzi=dc_norm(3,nres+i)
11179 !        dsci_inv=dsc_inv(itypi)
11180         dsci_inv=vbld_inv(i+nres)
11181 !
11182 ! Calculate SC interaction energy.
11183 !
11184         do iint=1,nint_gr(i)
11185           do j=istart(i,iint),iend(i,iint)
11186 !el            ind=ind+1
11187             itypj=itype(j)
11188             if (itypj.eq.ntyp1) cycle
11189 !            dscj_inv=dsc_inv(itypj)
11190             dscj_inv=vbld_inv(j+nres)
11191             chi1=chi(itypi,itypj)
11192             chi2=chi(itypj,itypi)
11193             chi12=chi1*chi2
11194             chip1=chip(itypi)
11195             chip2=chip(itypj)
11196             chip12=chip1*chip2
11197             alf1=alp(itypi)
11198             alf2=alp(itypj)
11199             alf12=0.5D0*(alf1+alf2)
11200             xj=c(1,nres+j)-xi
11201             yj=c(2,nres+j)-yi
11202             zj=c(3,nres+j)-zi
11203             dxj=dc_norm(1,nres+j)
11204             dyj=dc_norm(2,nres+j)
11205             dzj=dc_norm(3,nres+j)
11206             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11207             rij=dsqrt(rrij)
11208             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11209
11210             if (sss.gt.0.0d0) then
11211
11212 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11213               call sc_angular
11214 ! Calculate whole angle-dependent part of epsilon and contributions
11215 ! to its derivatives
11216               fac=(rrij*sigsq)**expon2
11217               e1=fac*fac*aa(itypi,itypj)
11218               e2=fac*bb(itypi,itypj)
11219               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11220               eps2der=evdwij*eps3rt
11221               eps3der=evdwij*eps2rt
11222               evdwij=evdwij*eps2rt*eps3rt
11223               evdw=evdw+evdwij*sss
11224               if (lprn) then
11225               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11226               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11227 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11228 !d     &          restyp(itypi),i,restyp(itypj),j,
11229 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11230 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11231 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11232 !d     &          evdwij
11233               endif
11234 ! Calculate gradient components.
11235               e1=e1*eps1*eps2rt**2*eps3rt**2
11236               fac=-expon*(e1+evdwij)
11237               sigder=fac/sigsq
11238               fac=rrij*fac
11239 ! Calculate radial part of the gradient
11240               gg(1)=xj*fac
11241               gg(2)=yj*fac
11242               gg(3)=zj*fac
11243 ! Calculate the angular part of the gradient and sum add the contributions
11244 ! to the appropriate components of the Cartesian gradient.
11245               call sc_grad_scale(sss)
11246             endif
11247           enddo      ! j
11248         enddo        ! iint
11249       enddo          ! i
11250 !     stop
11251       return
11252       end subroutine ebp_short
11253 !-----------------------------------------------------------------------------
11254       subroutine egb_long(evdw)
11255 !
11256 ! This subroutine calculates the interaction energy of nonbonded side chains
11257 ! assuming the Gay-Berne potential of interaction.
11258 !
11259       use calc_data
11260 !      implicit real*8 (a-h,o-z)
11261 !      include 'DIMENSIONS'
11262 !      include 'COMMON.GEO'
11263 !      include 'COMMON.VAR'
11264 !      include 'COMMON.LOCAL'
11265 !      include 'COMMON.CHAIN'
11266 !      include 'COMMON.DERIV'
11267 !      include 'COMMON.NAMES'
11268 !      include 'COMMON.INTERACT'
11269 !      include 'COMMON.IOUNITS'
11270 !      include 'COMMON.CALC'
11271 !      include 'COMMON.CONTROL'
11272       logical :: lprn
11273 !el local variables
11274       integer :: iint,itypi,itypi1,itypj
11275       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11276       real(kind=8) :: sss,e1,e2,evdw
11277       evdw=0.0D0
11278 !cccc      energy_dec=.false.
11279 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11280       evdw=0.0D0
11281       lprn=.false.
11282 !     if (icall.eq.0) lprn=.false.
11283 !el      ind=0
11284       do i=iatsc_s,iatsc_e
11285         itypi=itype(i)
11286         if (itypi.eq.ntyp1) cycle
11287         itypi1=itype(i+1)
11288         xi=c(1,nres+i)
11289         yi=c(2,nres+i)
11290         zi=c(3,nres+i)
11291         dxi=dc_norm(1,nres+i)
11292         dyi=dc_norm(2,nres+i)
11293         dzi=dc_norm(3,nres+i)
11294 !        dsci_inv=dsc_inv(itypi)
11295         dsci_inv=vbld_inv(i+nres)
11296 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11297 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11298 !
11299 ! Calculate SC interaction energy.
11300 !
11301         do iint=1,nint_gr(i)
11302           do j=istart(i,iint),iend(i,iint)
11303 !el            ind=ind+1
11304             itypj=itype(j)
11305             if (itypj.eq.ntyp1) cycle
11306 !            dscj_inv=dsc_inv(itypj)
11307             dscj_inv=vbld_inv(j+nres)
11308 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11309 !     &       1.0d0/vbld(j+nres)
11310 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11311             sig0ij=sigma(itypi,itypj)
11312             chi1=chi(itypi,itypj)
11313             chi2=chi(itypj,itypi)
11314             chi12=chi1*chi2
11315             chip1=chip(itypi)
11316             chip2=chip(itypj)
11317             chip12=chip1*chip2
11318             alf1=alp(itypi)
11319             alf2=alp(itypj)
11320             alf12=0.5D0*(alf1+alf2)
11321             xj=c(1,nres+j)-xi
11322             yj=c(2,nres+j)-yi
11323             zj=c(3,nres+j)-zi
11324             dxj=dc_norm(1,nres+j)
11325             dyj=dc_norm(2,nres+j)
11326             dzj=dc_norm(3,nres+j)
11327             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11328             rij=dsqrt(rrij)
11329             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11330
11331             if (sss.lt.1.0d0) then
11332
11333 ! Calculate angle-dependent terms of energy and contributions to their
11334 ! derivatives.
11335               call sc_angular
11336               sigsq=1.0D0/sigsq
11337               sig=sig0ij*dsqrt(sigsq)
11338               rij_shift=1.0D0/rij-sig+sig0ij
11339 ! for diagnostics; uncomment
11340 !              rij_shift=1.2*sig0ij
11341 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11342               if (rij_shift.le.0.0D0) then
11343                 evdw=1.0D20
11344 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11345 !d     &          restyp(itypi),i,restyp(itypj),j,
11346 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11347                 return
11348               endif
11349               sigder=-sig*sigsq
11350 !---------------------------------------------------------------
11351               rij_shift=1.0D0/rij_shift
11352               fac=rij_shift**expon
11353               e1=fac*fac*aa(itypi,itypj)
11354               e2=fac*bb(itypi,itypj)
11355               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11356               eps2der=evdwij*eps3rt
11357               eps3der=evdwij*eps2rt
11358 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11359 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11360               evdwij=evdwij*eps2rt*eps3rt
11361               evdw=evdw+evdwij*(1.0d0-sss)
11362               if (lprn) then
11363               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11364               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11365               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11366                 restyp(itypi),i,restyp(itypj),j,&
11367                 epsi,sigm,chi1,chi2,chip1,chip2,&
11368                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11369                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11370                 evdwij
11371               endif
11372
11373               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11374                               'evdw',i,j,evdwij
11375 !              if (energy_dec) write (iout,*) &
11376 !                              'evdw',i,j,evdwij,"egb_long"
11377
11378 ! Calculate gradient components.
11379               e1=e1*eps1*eps2rt**2*eps3rt**2
11380               fac=-expon*(e1+evdwij)*rij_shift
11381               sigder=fac*sigder
11382               fac=rij*fac
11383 !              fac=0.0d0
11384 ! Calculate the radial part of the gradient
11385               gg(1)=xj*fac
11386               gg(2)=yj*fac
11387               gg(3)=zj*fac
11388 ! Calculate angular part of the gradient.
11389               call sc_grad_scale(1.0d0-sss)
11390             endif
11391           enddo      ! j
11392         enddo        ! iint
11393       enddo          ! i
11394 !      write (iout,*) "Number of loop steps in EGB:",ind
11395 !ccc      energy_dec=.false.
11396       return
11397       end subroutine egb_long
11398 !-----------------------------------------------------------------------------
11399       subroutine egb_short(evdw)
11400 !
11401 ! This subroutine calculates the interaction energy of nonbonded side chains
11402 ! assuming the Gay-Berne potential of interaction.
11403 !
11404       use calc_data
11405 !      implicit real*8 (a-h,o-z)
11406 !      include 'DIMENSIONS'
11407 !      include 'COMMON.GEO'
11408 !      include 'COMMON.VAR'
11409 !      include 'COMMON.LOCAL'
11410 !      include 'COMMON.CHAIN'
11411 !      include 'COMMON.DERIV'
11412 !      include 'COMMON.NAMES'
11413 !      include 'COMMON.INTERACT'
11414 !      include 'COMMON.IOUNITS'
11415 !      include 'COMMON.CALC'
11416 !      include 'COMMON.CONTROL'
11417       logical :: lprn
11418 !el local variables
11419       integer :: iint,itypi,itypi1,itypj
11420       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11421       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11422       evdw=0.0D0
11423 !cccc      energy_dec=.false.
11424 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11425       evdw=0.0D0
11426       lprn=.false.
11427 !     if (icall.eq.0) lprn=.false.
11428 !el      ind=0
11429       do i=iatsc_s,iatsc_e
11430         itypi=itype(i)
11431         if (itypi.eq.ntyp1) cycle
11432         itypi1=itype(i+1)
11433         xi=c(1,nres+i)
11434         yi=c(2,nres+i)
11435         zi=c(3,nres+i)
11436         dxi=dc_norm(1,nres+i)
11437         dyi=dc_norm(2,nres+i)
11438         dzi=dc_norm(3,nres+i)
11439 !        dsci_inv=dsc_inv(itypi)
11440         dsci_inv=vbld_inv(i+nres)
11441 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11442 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11443 !
11444 ! Calculate SC interaction energy.
11445 !
11446         do iint=1,nint_gr(i)
11447           do j=istart(i,iint),iend(i,iint)
11448 !el            ind=ind+1
11449             itypj=itype(j)
11450             if (itypj.eq.ntyp1) cycle
11451 !            dscj_inv=dsc_inv(itypj)
11452             dscj_inv=vbld_inv(j+nres)
11453 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11454 !     &       1.0d0/vbld(j+nres)
11455 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11456             sig0ij=sigma(itypi,itypj)
11457             chi1=chi(itypi,itypj)
11458             chi2=chi(itypj,itypi)
11459             chi12=chi1*chi2
11460             chip1=chip(itypi)
11461             chip2=chip(itypj)
11462             chip12=chip1*chip2
11463             alf1=alp(itypi)
11464             alf2=alp(itypj)
11465             alf12=0.5D0*(alf1+alf2)
11466             xj=c(1,nres+j)-xi
11467             yj=c(2,nres+j)-yi
11468             zj=c(3,nres+j)-zi
11469             dxj=dc_norm(1,nres+j)
11470             dyj=dc_norm(2,nres+j)
11471             dzj=dc_norm(3,nres+j)
11472             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11473             rij=dsqrt(rrij)
11474             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11475
11476             if (sss.gt.0.0d0) then
11477
11478 ! Calculate angle-dependent terms of energy and contributions to their
11479 ! derivatives.
11480               call sc_angular
11481               sigsq=1.0D0/sigsq
11482               sig=sig0ij*dsqrt(sigsq)
11483               rij_shift=1.0D0/rij-sig+sig0ij
11484 ! for diagnostics; uncomment
11485 !              rij_shift=1.2*sig0ij
11486 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11487               if (rij_shift.le.0.0D0) then
11488                 evdw=1.0D20
11489 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11490 !d     &          restyp(itypi),i,restyp(itypj),j,
11491 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11492                 return
11493               endif
11494               sigder=-sig*sigsq
11495 !---------------------------------------------------------------
11496               rij_shift=1.0D0/rij_shift
11497               fac=rij_shift**expon
11498               e1=fac*fac*aa(itypi,itypj)
11499               e2=fac*bb(itypi,itypj)
11500               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11501               eps2der=evdwij*eps3rt
11502               eps3der=evdwij*eps2rt
11503 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11504 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11505               evdwij=evdwij*eps2rt*eps3rt
11506               evdw=evdw+evdwij*sss
11507               if (lprn) then
11508               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11509               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11510               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11511                 restyp(itypi),i,restyp(itypj),j,&
11512                 epsi,sigm,chi1,chi2,chip1,chip2,&
11513                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11514                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11515                 evdwij
11516               endif
11517
11518               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11519                               'evdw',i,j,evdwij
11520 !              if (energy_dec) write (iout,*) &
11521 !                              'evdw',i,j,evdwij,"egb_short"
11522
11523 ! Calculate gradient components.
11524               e1=e1*eps1*eps2rt**2*eps3rt**2
11525               fac=-expon*(e1+evdwij)*rij_shift
11526               sigder=fac*sigder
11527               fac=rij*fac
11528 !              fac=0.0d0
11529 ! Calculate the radial part of the gradient
11530               gg(1)=xj*fac
11531               gg(2)=yj*fac
11532               gg(3)=zj*fac
11533 ! Calculate angular part of the gradient.
11534               call sc_grad_scale(sss)
11535             endif
11536           enddo      ! j
11537         enddo        ! iint
11538       enddo          ! i
11539 !      write (iout,*) "Number of loop steps in EGB:",ind
11540 !ccc      energy_dec=.false.
11541       return
11542       end subroutine egb_short
11543 !-----------------------------------------------------------------------------
11544       subroutine egbv_long(evdw)
11545 !
11546 ! This subroutine calculates the interaction energy of nonbonded side chains
11547 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11548 !
11549       use calc_data
11550 !      implicit real*8 (a-h,o-z)
11551 !      include 'DIMENSIONS'
11552 !      include 'COMMON.GEO'
11553 !      include 'COMMON.VAR'
11554 !      include 'COMMON.LOCAL'
11555 !      include 'COMMON.CHAIN'
11556 !      include 'COMMON.DERIV'
11557 !      include 'COMMON.NAMES'
11558 !      include 'COMMON.INTERACT'
11559 !      include 'COMMON.IOUNITS'
11560 !      include 'COMMON.CALC'
11561       use comm_srutu
11562 !el      integer :: icall
11563 !el      common /srutu/ icall
11564       logical :: lprn
11565 !el local variables
11566       integer :: iint,itypi,itypi1,itypj
11567       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
11568       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
11569       evdw=0.0D0
11570 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11571       evdw=0.0D0
11572       lprn=.false.
11573 !     if (icall.eq.0) lprn=.true.
11574 !el      ind=0
11575       do i=iatsc_s,iatsc_e
11576         itypi=itype(i)
11577         if (itypi.eq.ntyp1) cycle
11578         itypi1=itype(i+1)
11579         xi=c(1,nres+i)
11580         yi=c(2,nres+i)
11581         zi=c(3,nres+i)
11582         dxi=dc_norm(1,nres+i)
11583         dyi=dc_norm(2,nres+i)
11584         dzi=dc_norm(3,nres+i)
11585 !        dsci_inv=dsc_inv(itypi)
11586         dsci_inv=vbld_inv(i+nres)
11587 !
11588 ! Calculate SC interaction energy.
11589 !
11590         do iint=1,nint_gr(i)
11591           do j=istart(i,iint),iend(i,iint)
11592 !el            ind=ind+1
11593             itypj=itype(j)
11594             if (itypj.eq.ntyp1) cycle
11595 !            dscj_inv=dsc_inv(itypj)
11596             dscj_inv=vbld_inv(j+nres)
11597             sig0ij=sigma(itypi,itypj)
11598             r0ij=r0(itypi,itypj)
11599             chi1=chi(itypi,itypj)
11600             chi2=chi(itypj,itypi)
11601             chi12=chi1*chi2
11602             chip1=chip(itypi)
11603             chip2=chip(itypj)
11604             chip12=chip1*chip2
11605             alf1=alp(itypi)
11606             alf2=alp(itypj)
11607             alf12=0.5D0*(alf1+alf2)
11608             xj=c(1,nres+j)-xi
11609             yj=c(2,nres+j)-yi
11610             zj=c(3,nres+j)-zi
11611             dxj=dc_norm(1,nres+j)
11612             dyj=dc_norm(2,nres+j)
11613             dzj=dc_norm(3,nres+j)
11614             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11615             rij=dsqrt(rrij)
11616
11617             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11618
11619             if (sss.lt.1.0d0) then
11620
11621 ! Calculate angle-dependent terms of energy and contributions to their
11622 ! derivatives.
11623               call sc_angular
11624               sigsq=1.0D0/sigsq
11625               sig=sig0ij*dsqrt(sigsq)
11626               rij_shift=1.0D0/rij-sig+r0ij
11627 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11628               if (rij_shift.le.0.0D0) then
11629                 evdw=1.0D20
11630                 return
11631               endif
11632               sigder=-sig*sigsq
11633 !---------------------------------------------------------------
11634               rij_shift=1.0D0/rij_shift
11635               fac=rij_shift**expon
11636               e1=fac*fac*aa(itypi,itypj)
11637               e2=fac*bb(itypi,itypj)
11638               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11639               eps2der=evdwij*eps3rt
11640               eps3der=evdwij*eps2rt
11641               fac_augm=rrij**expon
11642               e_augm=augm(itypi,itypj)*fac_augm
11643               evdwij=evdwij*eps2rt*eps3rt
11644               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
11645               if (lprn) then
11646               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11647               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11648               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11649                 restyp(itypi),i,restyp(itypj),j,&
11650                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11651                 chi1,chi2,chip1,chip2,&
11652                 eps1,eps2rt**2,eps3rt**2,&
11653                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11654                 evdwij+e_augm
11655               endif
11656 ! Calculate gradient components.
11657               e1=e1*eps1*eps2rt**2*eps3rt**2
11658               fac=-expon*(e1+evdwij)*rij_shift
11659               sigder=fac*sigder
11660               fac=rij*fac-2*expon*rrij*e_augm
11661 ! Calculate the radial part of the gradient
11662               gg(1)=xj*fac
11663               gg(2)=yj*fac
11664               gg(3)=zj*fac
11665 ! Calculate angular part of the gradient.
11666               call sc_grad_scale(1.0d0-sss)
11667             endif
11668           enddo      ! j
11669         enddo        ! iint
11670       enddo          ! i
11671       end subroutine egbv_long
11672 !-----------------------------------------------------------------------------
11673       subroutine egbv_short(evdw)
11674 !
11675 ! This subroutine calculates the interaction energy of nonbonded side chains
11676 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11677 !
11678       use calc_data
11679 !      implicit real*8 (a-h,o-z)
11680 !      include 'DIMENSIONS'
11681 !      include 'COMMON.GEO'
11682 !      include 'COMMON.VAR'
11683 !      include 'COMMON.LOCAL'
11684 !      include 'COMMON.CHAIN'
11685 !      include 'COMMON.DERIV'
11686 !      include 'COMMON.NAMES'
11687 !      include 'COMMON.INTERACT'
11688 !      include 'COMMON.IOUNITS'
11689 !      include 'COMMON.CALC'
11690       use comm_srutu
11691 !el      integer :: icall
11692 !el      common /srutu/ icall
11693       logical :: lprn
11694 !el local variables
11695       integer :: iint,itypi,itypi1,itypj
11696       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
11697       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
11698       evdw=0.0D0
11699 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11700       evdw=0.0D0
11701       lprn=.false.
11702 !     if (icall.eq.0) lprn=.true.
11703 !el      ind=0
11704       do i=iatsc_s,iatsc_e
11705         itypi=itype(i)
11706         if (itypi.eq.ntyp1) cycle
11707         itypi1=itype(i+1)
11708         xi=c(1,nres+i)
11709         yi=c(2,nres+i)
11710         zi=c(3,nres+i)
11711         dxi=dc_norm(1,nres+i)
11712         dyi=dc_norm(2,nres+i)
11713         dzi=dc_norm(3,nres+i)
11714 !        dsci_inv=dsc_inv(itypi)
11715         dsci_inv=vbld_inv(i+nres)
11716 !
11717 ! Calculate SC interaction energy.
11718 !
11719         do iint=1,nint_gr(i)
11720           do j=istart(i,iint),iend(i,iint)
11721 !el            ind=ind+1
11722             itypj=itype(j)
11723             if (itypj.eq.ntyp1) cycle
11724 !            dscj_inv=dsc_inv(itypj)
11725             dscj_inv=vbld_inv(j+nres)
11726             sig0ij=sigma(itypi,itypj)
11727             r0ij=r0(itypi,itypj)
11728             chi1=chi(itypi,itypj)
11729             chi2=chi(itypj,itypi)
11730             chi12=chi1*chi2
11731             chip1=chip(itypi)
11732             chip2=chip(itypj)
11733             chip12=chip1*chip2
11734             alf1=alp(itypi)
11735             alf2=alp(itypj)
11736             alf12=0.5D0*(alf1+alf2)
11737             xj=c(1,nres+j)-xi
11738             yj=c(2,nres+j)-yi
11739             zj=c(3,nres+j)-zi
11740             dxj=dc_norm(1,nres+j)
11741             dyj=dc_norm(2,nres+j)
11742             dzj=dc_norm(3,nres+j)
11743             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11744             rij=dsqrt(rrij)
11745
11746             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11747
11748             if (sss.gt.0.0d0) then
11749
11750 ! Calculate angle-dependent terms of energy and contributions to their
11751 ! derivatives.
11752               call sc_angular
11753               sigsq=1.0D0/sigsq
11754               sig=sig0ij*dsqrt(sigsq)
11755               rij_shift=1.0D0/rij-sig+r0ij
11756 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11757               if (rij_shift.le.0.0D0) then
11758                 evdw=1.0D20
11759                 return
11760               endif
11761               sigder=-sig*sigsq
11762 !---------------------------------------------------------------
11763               rij_shift=1.0D0/rij_shift
11764               fac=rij_shift**expon
11765               e1=fac*fac*aa(itypi,itypj)
11766               e2=fac*bb(itypi,itypj)
11767               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11768               eps2der=evdwij*eps3rt
11769               eps3der=evdwij*eps2rt
11770               fac_augm=rrij**expon
11771               e_augm=augm(itypi,itypj)*fac_augm
11772               evdwij=evdwij*eps2rt*eps3rt
11773               evdw=evdw+(evdwij+e_augm)*sss
11774               if (lprn) then
11775               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11776               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11777               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11778                 restyp(itypi),i,restyp(itypj),j,&
11779                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11780                 chi1,chi2,chip1,chip2,&
11781                 eps1,eps2rt**2,eps3rt**2,&
11782                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11783                 evdwij+e_augm
11784               endif
11785 ! Calculate gradient components.
11786               e1=e1*eps1*eps2rt**2*eps3rt**2
11787               fac=-expon*(e1+evdwij)*rij_shift
11788               sigder=fac*sigder
11789               fac=rij*fac-2*expon*rrij*e_augm
11790 ! Calculate the radial part of the gradient
11791               gg(1)=xj*fac
11792               gg(2)=yj*fac
11793               gg(3)=zj*fac
11794 ! Calculate angular part of the gradient.
11795               call sc_grad_scale(sss)
11796             endif
11797           enddo      ! j
11798         enddo        ! iint
11799       enddo          ! i
11800       end subroutine egbv_short
11801 !-----------------------------------------------------------------------------
11802       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
11803 !
11804 ! This subroutine calculates the average interaction energy and its gradient
11805 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
11806 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
11807 ! The potential depends both on the distance of peptide-group centers and on
11808 ! the orientation of the CA-CA virtual bonds.
11809 !
11810 !      implicit real*8 (a-h,o-z)
11811
11812       use comm_locel
11813 #ifdef MPI
11814       include 'mpif.h'
11815 #endif
11816 !      include 'DIMENSIONS'
11817 !      include 'COMMON.CONTROL'
11818 !      include 'COMMON.SETUP'
11819 !      include 'COMMON.IOUNITS'
11820 !      include 'COMMON.GEO'
11821 !      include 'COMMON.VAR'
11822 !      include 'COMMON.LOCAL'
11823 !      include 'COMMON.CHAIN'
11824 !      include 'COMMON.DERIV'
11825 !      include 'COMMON.INTERACT'
11826 !      include 'COMMON.CONTACTS'
11827 !      include 'COMMON.TORSION'
11828 !      include 'COMMON.VECTORS'
11829 !      include 'COMMON.FFIELD'
11830 !      include 'COMMON.TIME1'
11831       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
11832       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
11833       real(kind=8),dimension(2,2) :: acipa !el,a_temp
11834 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
11835       real(kind=8),dimension(4) :: muij
11836 !el      integer :: num_conti,j1,j2
11837 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
11838 !el                   dz_normi,xmedi,ymedi,zmedi
11839 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
11840 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
11841 !el          num_conti,j1,j2
11842 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
11843 #ifdef MOMENT
11844       real(kind=8) :: scal_el=1.0d0
11845 #else
11846       real(kind=8) :: scal_el=0.5d0
11847 #endif
11848 ! 12/13/98
11849 ! 13-go grudnia roku pamietnego...
11850       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
11851                                              0.0d0,1.0d0,0.0d0,&
11852                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
11853 !el local variables
11854       integer :: i,j,k
11855       real(kind=8) :: fac
11856       real(kind=8) :: dxj,dyj,dzj
11857       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
11858
11859 !      allocate(num_cont_hb(nres)) !(maxres)
11860 !d      write(iout,*) 'In EELEC'
11861 !d      do i=1,nloctyp
11862 !d        write(iout,*) 'Type',i
11863 !d        write(iout,*) 'B1',B1(:,i)
11864 !d        write(iout,*) 'B2',B2(:,i)
11865 !d        write(iout,*) 'CC',CC(:,:,i)
11866 !d        write(iout,*) 'DD',DD(:,:,i)
11867 !d        write(iout,*) 'EE',EE(:,:,i)
11868 !d      enddo
11869 !d      call check_vecgrad
11870 !d      stop
11871       if (icheckgrad.eq.1) then
11872         do i=1,nres-1
11873           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
11874           do k=1,3
11875             dc_norm(k,i)=dc(k,i)*fac
11876           enddo
11877 !          write (iout,*) 'i',i,' fac',fac
11878         enddo
11879       endif
11880       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
11881           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
11882           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
11883 !        call vec_and_deriv
11884 #ifdef TIMING
11885         time01=MPI_Wtime()
11886 #endif
11887         call set_matrices
11888 #ifdef TIMING
11889         time_mat=time_mat+MPI_Wtime()-time01
11890 #endif
11891       endif
11892 !d      do i=1,nres-1
11893 !d        write (iout,*) 'i=',i
11894 !d        do k=1,3
11895 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
11896 !d        enddo
11897 !d        do k=1,3
11898 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
11899 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
11900 !d        enddo
11901 !d      enddo
11902       t_eelecij=0.0d0
11903       ees=0.0D0
11904       evdw1=0.0D0
11905       eel_loc=0.0d0
11906       eello_turn3=0.0d0
11907       eello_turn4=0.0d0
11908 !el      ind=0
11909       do i=1,nres
11910         num_cont_hb(i)=0
11911       enddo
11912 !d      print '(a)','Enter EELEC'
11913 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
11914 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
11915 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
11916       do i=1,nres
11917         gel_loc_loc(i)=0.0d0
11918         gcorr_loc(i)=0.0d0
11919       enddo
11920 !
11921 !
11922 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
11923 !
11924 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
11925 !
11926       do i=iturn3_start,iturn3_end
11927         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
11928         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
11929         dxi=dc(1,i)
11930         dyi=dc(2,i)
11931         dzi=dc(3,i)
11932         dx_normi=dc_norm(1,i)
11933         dy_normi=dc_norm(2,i)
11934         dz_normi=dc_norm(3,i)
11935         xmedi=c(1,i)+0.5d0*dxi
11936         ymedi=c(2,i)+0.5d0*dyi
11937         zmedi=c(3,i)+0.5d0*dzi
11938         num_conti=0
11939         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
11940         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
11941         num_cont_hb(i)=num_conti
11942       enddo
11943       do i=iturn4_start,iturn4_end
11944         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
11945           .or. itype(i+3).eq.ntyp1 &
11946           .or. itype(i+4).eq.ntyp1) cycle
11947         dxi=dc(1,i)
11948         dyi=dc(2,i)
11949         dzi=dc(3,i)
11950         dx_normi=dc_norm(1,i)
11951         dy_normi=dc_norm(2,i)
11952         dz_normi=dc_norm(3,i)
11953         xmedi=c(1,i)+0.5d0*dxi
11954         ymedi=c(2,i)+0.5d0*dyi
11955         zmedi=c(3,i)+0.5d0*dzi
11956         num_conti=num_cont_hb(i)
11957         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
11958         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
11959           call eturn4(i,eello_turn4)
11960         num_cont_hb(i)=num_conti
11961       enddo   ! i
11962 !
11963 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
11964 !
11965       do i=iatel_s,iatel_e
11966         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
11967         dxi=dc(1,i)
11968         dyi=dc(2,i)
11969         dzi=dc(3,i)
11970         dx_normi=dc_norm(1,i)
11971         dy_normi=dc_norm(2,i)
11972         dz_normi=dc_norm(3,i)
11973         xmedi=c(1,i)+0.5d0*dxi
11974         ymedi=c(2,i)+0.5d0*dyi
11975         zmedi=c(3,i)+0.5d0*dzi
11976 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
11977         num_conti=num_cont_hb(i)
11978         do j=ielstart(i),ielend(i)
11979           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
11980           call eelecij_scale(i,j,ees,evdw1,eel_loc)
11981         enddo ! j
11982         num_cont_hb(i)=num_conti
11983       enddo   ! i
11984 !      write (iout,*) "Number of loop steps in EELEC:",ind
11985 !d      do i=1,nres
11986 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
11987 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
11988 !d      enddo
11989 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
11990 !cc      eel_loc=eel_loc+eello_turn3
11991 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
11992       return
11993       end subroutine eelec_scale
11994 !-----------------------------------------------------------------------------
11995       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
11996 !      implicit real*8 (a-h,o-z)
11997
11998       use comm_locel
11999 !      include 'DIMENSIONS'
12000 #ifdef MPI
12001       include "mpif.h"
12002 #endif
12003 !      include 'COMMON.CONTROL'
12004 !      include 'COMMON.IOUNITS'
12005 !      include 'COMMON.GEO'
12006 !      include 'COMMON.VAR'
12007 !      include 'COMMON.LOCAL'
12008 !      include 'COMMON.CHAIN'
12009 !      include 'COMMON.DERIV'
12010 !      include 'COMMON.INTERACT'
12011 !      include 'COMMON.CONTACTS'
12012 !      include 'COMMON.TORSION'
12013 !      include 'COMMON.VECTORS'
12014 !      include 'COMMON.FFIELD'
12015 !      include 'COMMON.TIME1'
12016       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12017       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12018       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12019 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12020       real(kind=8),dimension(4) :: muij
12021 !el      integer :: num_conti,j1,j2
12022 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12023 !el                   dz_normi,xmedi,ymedi,zmedi
12024 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12025 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12026 !el          num_conti,j1,j2
12027 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12028 #ifdef MOMENT
12029       real(kind=8) :: scal_el=1.0d0
12030 #else
12031       real(kind=8) :: scal_el=0.5d0
12032 #endif
12033 ! 12/13/98
12034 ! 13-go grudnia roku pamietnego...
12035       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12036                                              0.0d0,1.0d0,0.0d0,&
12037                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12038 !el local variables
12039       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12040       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12041       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12042       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12043       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12044       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12045       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12046                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12047                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12048                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12049                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12050                   ecosam,ecosbm,ecosgm,ghalf,time00
12051 !      integer :: maxconts
12052 !      maxconts = nres/4
12053 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12054 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12055 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12056 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12057 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12058 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12059 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12060 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12061 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12062 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12063 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12064 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12065 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12066
12067 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12068 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12069
12070 #ifdef MPI
12071           time00=MPI_Wtime()
12072 #endif
12073 !d      write (iout,*) "eelecij",i,j
12074 !el          ind=ind+1
12075           iteli=itel(i)
12076           itelj=itel(j)
12077           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12078           aaa=app(iteli,itelj)
12079           bbb=bpp(iteli,itelj)
12080           ael6i=ael6(iteli,itelj)
12081           ael3i=ael3(iteli,itelj)
12082           dxj=dc(1,j)
12083           dyj=dc(2,j)
12084           dzj=dc(3,j)
12085           dx_normj=dc_norm(1,j)
12086           dy_normj=dc_norm(2,j)
12087           dz_normj=dc_norm(3,j)
12088           xj=c(1,j)+0.5D0*dxj-xmedi
12089           yj=c(2,j)+0.5D0*dyj-ymedi
12090           zj=c(3,j)+0.5D0*dzj-zmedi
12091           rij=xj*xj+yj*yj+zj*zj
12092           rrmij=1.0D0/rij
12093           rij=dsqrt(rij)
12094           rmij=1.0D0/rij
12095 ! For extracting the short-range part of Evdwpp
12096           sss=sscale(rij/rpp(iteli,itelj))
12097
12098           r3ij=rrmij*rmij
12099           r6ij=r3ij*r3ij
12100           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12101           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12102           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12103           fac=cosa-3.0D0*cosb*cosg
12104           ev1=aaa*r6ij*r6ij
12105 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12106           if (j.eq.i+2) ev1=scal_el*ev1
12107           ev2=bbb*r6ij
12108           fac3=ael6i*r6ij
12109           fac4=ael3i*r3ij
12110           evdwij=ev1+ev2
12111           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12112           el2=fac4*fac
12113           eesij=el1+el2
12114 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12115           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12116           ees=ees+eesij
12117           evdw1=evdw1+evdwij*(1.0d0-sss)
12118 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12119 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12120 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12121 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12122
12123           if (energy_dec) then
12124               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12125               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12126           endif
12127
12128 !
12129 ! Calculate contributions to the Cartesian gradient.
12130 !
12131 #ifdef SPLITELE
12132           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12133           facel=-3*rrmij*(el1+eesij)
12134           fac1=fac
12135           erij(1)=xj*rmij
12136           erij(2)=yj*rmij
12137           erij(3)=zj*rmij
12138 !
12139 ! Radial derivatives. First process both termini of the fragment (i,j)
12140 !
12141           ggg(1)=facel*xj
12142           ggg(2)=facel*yj
12143           ggg(3)=facel*zj
12144 !          do k=1,3
12145 !            ghalf=0.5D0*ggg(k)
12146 !            gelc(k,i)=gelc(k,i)+ghalf
12147 !            gelc(k,j)=gelc(k,j)+ghalf
12148 !          enddo
12149 ! 9/28/08 AL Gradient compotents will be summed only at the end
12150           do k=1,3
12151             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12152             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12153           enddo
12154 !
12155 ! Loop over residues i+1 thru j-1.
12156 !
12157 !grad          do k=i+1,j-1
12158 !grad            do l=1,3
12159 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12160 !grad            enddo
12161 !grad          enddo
12162           ggg(1)=facvdw*xj
12163           ggg(2)=facvdw*yj
12164           ggg(3)=facvdw*zj
12165 !          do k=1,3
12166 !            ghalf=0.5D0*ggg(k)
12167 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12168 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12169 !          enddo
12170 ! 9/28/08 AL Gradient compotents will be summed only at the end
12171           do k=1,3
12172             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12173             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12174           enddo
12175 !
12176 ! Loop over residues i+1 thru j-1.
12177 !
12178 !grad          do k=i+1,j-1
12179 !grad            do l=1,3
12180 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12181 !grad            enddo
12182 !grad          enddo
12183 #else
12184           facvdw=ev1+evdwij*(1.0d0-sss)
12185           facel=el1+eesij
12186           fac1=fac
12187           fac=-3*rrmij*(facvdw+facvdw+facel)
12188           erij(1)=xj*rmij
12189           erij(2)=yj*rmij
12190           erij(3)=zj*rmij
12191 !
12192 ! Radial derivatives. First process both termini of the fragment (i,j)
12193 !
12194           ggg(1)=fac*xj
12195           ggg(2)=fac*yj
12196           ggg(3)=fac*zj
12197 !          do k=1,3
12198 !            ghalf=0.5D0*ggg(k)
12199 !            gelc(k,i)=gelc(k,i)+ghalf
12200 !            gelc(k,j)=gelc(k,j)+ghalf
12201 !          enddo
12202 ! 9/28/08 AL Gradient compotents will be summed only at the end
12203           do k=1,3
12204             gelc_long(k,j)=gelc(k,j)+ggg(k)
12205             gelc_long(k,i)=gelc(k,i)-ggg(k)
12206           enddo
12207 !
12208 ! Loop over residues i+1 thru j-1.
12209 !
12210 !grad          do k=i+1,j-1
12211 !grad            do l=1,3
12212 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12213 !grad            enddo
12214 !grad          enddo
12215 ! 9/28/08 AL Gradient compotents will be summed only at the end
12216           ggg(1)=facvdw*xj
12217           ggg(2)=facvdw*yj
12218           ggg(3)=facvdw*zj
12219           do k=1,3
12220             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12221             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12222           enddo
12223 #endif
12224 !
12225 ! Angular part
12226 !
12227           ecosa=2.0D0*fac3*fac1+fac4
12228           fac4=-3.0D0*fac4
12229           fac3=-6.0D0*fac3
12230           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12231           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12232           do k=1,3
12233             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12234             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12235           enddo
12236 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12237 !d   &          (dcosg(k),k=1,3)
12238           do k=1,3
12239             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12240           enddo
12241 !          do k=1,3
12242 !            ghalf=0.5D0*ggg(k)
12243 !            gelc(k,i)=gelc(k,i)+ghalf
12244 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12245 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12246 !            gelc(k,j)=gelc(k,j)+ghalf
12247 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12248 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12249 !          enddo
12250 !grad          do k=i+1,j-1
12251 !grad            do l=1,3
12252 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12253 !grad            enddo
12254 !grad          enddo
12255           do k=1,3
12256             gelc(k,i)=gelc(k,i) &
12257                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12258                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12259             gelc(k,j)=gelc(k,j) &
12260                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12261                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12262             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12263             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12264           enddo
12265           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12266               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12267               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12268 !
12269 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12270 !   energy of a peptide unit is assumed in the form of a second-order
12271 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12272 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12273 !   are computed for EVERY pair of non-contiguous peptide groups.
12274 !
12275           if (j.lt.nres-1) then
12276             j1=j+1
12277             j2=j-1
12278           else
12279             j1=j-1
12280             j2=j-2
12281           endif
12282           kkk=0
12283           do k=1,2
12284             do l=1,2
12285               kkk=kkk+1
12286               muij(kkk)=mu(k,i)*mu(l,j)
12287             enddo
12288           enddo
12289 !d         write (iout,*) 'EELEC: i',i,' j',j
12290 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12291 !d          write(iout,*) 'muij',muij
12292           ury=scalar(uy(1,i),erij)
12293           urz=scalar(uz(1,i),erij)
12294           vry=scalar(uy(1,j),erij)
12295           vrz=scalar(uz(1,j),erij)
12296           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12297           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12298           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12299           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12300           fac=dsqrt(-ael6i)*r3ij
12301           a22=a22*fac
12302           a23=a23*fac
12303           a32=a32*fac
12304           a33=a33*fac
12305 !d          write (iout,'(4i5,4f10.5)')
12306 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12307 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12308 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12309 !d     &      uy(:,j),uz(:,j)
12310 !d          write (iout,'(4f10.5)')
12311 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12312 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12313 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12314 !d           write (iout,'(9f10.5/)')
12315 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12316 ! Derivatives of the elements of A in virtual-bond vectors
12317           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12318           do k=1,3
12319             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12320             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12321             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12322             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12323             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12324             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12325             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12326             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12327             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12328             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12329             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12330             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12331           enddo
12332 ! Compute radial contributions to the gradient
12333           facr=-3.0d0*rrmij
12334           a22der=a22*facr
12335           a23der=a23*facr
12336           a32der=a32*facr
12337           a33der=a33*facr
12338           agg(1,1)=a22der*xj
12339           agg(2,1)=a22der*yj
12340           agg(3,1)=a22der*zj
12341           agg(1,2)=a23der*xj
12342           agg(2,2)=a23der*yj
12343           agg(3,2)=a23der*zj
12344           agg(1,3)=a32der*xj
12345           agg(2,3)=a32der*yj
12346           agg(3,3)=a32der*zj
12347           agg(1,4)=a33der*xj
12348           agg(2,4)=a33der*yj
12349           agg(3,4)=a33der*zj
12350 ! Add the contributions coming from er
12351           fac3=-3.0d0*fac
12352           do k=1,3
12353             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12354             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12355             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12356             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12357           enddo
12358           do k=1,3
12359 ! Derivatives in DC(i)
12360 !grad            ghalf1=0.5d0*agg(k,1)
12361 !grad            ghalf2=0.5d0*agg(k,2)
12362 !grad            ghalf3=0.5d0*agg(k,3)
12363 !grad            ghalf4=0.5d0*agg(k,4)
12364             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12365             -3.0d0*uryg(k,2)*vry)!+ghalf1
12366             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12367             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12368             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12369             -3.0d0*urzg(k,2)*vry)!+ghalf3
12370             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12371             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12372 ! Derivatives in DC(i+1)
12373             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12374             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12375             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12376             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12377             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12378             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12379             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12380             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12381 ! Derivatives in DC(j)
12382             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12383             -3.0d0*vryg(k,2)*ury)!+ghalf1
12384             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12385             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12386             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12387             -3.0d0*vryg(k,2)*urz)!+ghalf3
12388             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12389             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12390 ! Derivatives in DC(j+1) or DC(nres-1)
12391             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12392             -3.0d0*vryg(k,3)*ury)
12393             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12394             -3.0d0*vrzg(k,3)*ury)
12395             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12396             -3.0d0*vryg(k,3)*urz)
12397             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12398             -3.0d0*vrzg(k,3)*urz)
12399 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12400 !grad              do l=1,4
12401 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12402 !grad              enddo
12403 !grad            endif
12404           enddo
12405           acipa(1,1)=a22
12406           acipa(1,2)=a23
12407           acipa(2,1)=a32
12408           acipa(2,2)=a33
12409           a22=-a22
12410           a23=-a23
12411           do l=1,2
12412             do k=1,3
12413               agg(k,l)=-agg(k,l)
12414               aggi(k,l)=-aggi(k,l)
12415               aggi1(k,l)=-aggi1(k,l)
12416               aggj(k,l)=-aggj(k,l)
12417               aggj1(k,l)=-aggj1(k,l)
12418             enddo
12419           enddo
12420           if (j.lt.nres-1) then
12421             a22=-a22
12422             a32=-a32
12423             do l=1,3,2
12424               do k=1,3
12425                 agg(k,l)=-agg(k,l)
12426                 aggi(k,l)=-aggi(k,l)
12427                 aggi1(k,l)=-aggi1(k,l)
12428                 aggj(k,l)=-aggj(k,l)
12429                 aggj1(k,l)=-aggj1(k,l)
12430               enddo
12431             enddo
12432           else
12433             a22=-a22
12434             a23=-a23
12435             a32=-a32
12436             a33=-a33
12437             do l=1,4
12438               do k=1,3
12439                 agg(k,l)=-agg(k,l)
12440                 aggi(k,l)=-aggi(k,l)
12441                 aggi1(k,l)=-aggi1(k,l)
12442                 aggj(k,l)=-aggj(k,l)
12443                 aggj1(k,l)=-aggj1(k,l)
12444               enddo
12445             enddo
12446           endif
12447           ENDIF ! WCORR
12448           IF (wel_loc.gt.0.0d0) THEN
12449 ! Contribution to the local-electrostatic energy coming from the i-j pair
12450           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12451            +a33*muij(4)
12452 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12453
12454           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12455                   'eelloc',i,j,eel_loc_ij
12456 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12457
12458           eel_loc=eel_loc+eel_loc_ij
12459 ! Partial derivatives in virtual-bond dihedral angles gamma
12460           if (i.gt.1) &
12461           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12462                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12463                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12464           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12465                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12466                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12467 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12468           do l=1,3
12469             ggg(l)=agg(l,1)*muij(1)+ &
12470                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12471             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12472             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12473 !grad            ghalf=0.5d0*ggg(l)
12474 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12475 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12476           enddo
12477 !grad          do k=i+1,j2
12478 !grad            do l=1,3
12479 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12480 !grad            enddo
12481 !grad          enddo
12482 ! Remaining derivatives of eello
12483           do l=1,3
12484             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12485                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12486             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12487                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12488             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12489                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12490             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12491                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12492           enddo
12493           ENDIF
12494 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12495 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12496           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12497              .and. num_conti.le.maxconts) then
12498 !            write (iout,*) i,j," entered corr"
12499 !
12500 ! Calculate the contact function. The ith column of the array JCONT will
12501 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12502 ! greater than I). The arrays FACONT and GACONT will contain the values of
12503 ! the contact function and its derivative.
12504 !           r0ij=1.02D0*rpp(iteli,itelj)
12505 !           r0ij=1.11D0*rpp(iteli,itelj)
12506             r0ij=2.20D0*rpp(iteli,itelj)
12507 !           r0ij=1.55D0*rpp(iteli,itelj)
12508             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12509 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12510             if (fcont.gt.0.0D0) then
12511               num_conti=num_conti+1
12512               if (num_conti.gt.maxconts) then
12513 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12514                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
12515                                ' will skip next contacts for this conf.',num_conti
12516               else
12517                 jcont_hb(num_conti,i)=j
12518 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
12519 !d     &           " jcont_hb",jcont_hb(num_conti,i)
12520                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
12521                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12522 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
12523 !  terms.
12524                 d_cont(num_conti,i)=rij
12525 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
12526 !     --- Electrostatic-interaction matrix ---
12527                 a_chuj(1,1,num_conti,i)=a22
12528                 a_chuj(1,2,num_conti,i)=a23
12529                 a_chuj(2,1,num_conti,i)=a32
12530                 a_chuj(2,2,num_conti,i)=a33
12531 !     --- Gradient of rij
12532                 do kkk=1,3
12533                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
12534                 enddo
12535                 kkll=0
12536                 do k=1,2
12537                   do l=1,2
12538                     kkll=kkll+1
12539                     do m=1,3
12540                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
12541                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
12542                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
12543                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
12544                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
12545                     enddo
12546                   enddo
12547                 enddo
12548                 ENDIF
12549                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
12550 ! Calculate contact energies
12551                 cosa4=4.0D0*cosa
12552                 wij=cosa-3.0D0*cosb*cosg
12553                 cosbg1=cosb+cosg
12554                 cosbg2=cosb-cosg
12555 !               fac3=dsqrt(-ael6i)/r0ij**3
12556                 fac3=dsqrt(-ael6i)*r3ij
12557 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
12558                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
12559                 if (ees0tmp.gt.0) then
12560                   ees0pij=dsqrt(ees0tmp)
12561                 else
12562                   ees0pij=0
12563                 endif
12564 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
12565                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
12566                 if (ees0tmp.gt.0) then
12567                   ees0mij=dsqrt(ees0tmp)
12568                 else
12569                   ees0mij=0
12570                 endif
12571 !               ees0mij=0.0D0
12572                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
12573                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
12574 ! Diagnostics. Comment out or remove after debugging!
12575 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
12576 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
12577 !               ees0m(num_conti,i)=0.0D0
12578 ! End diagnostics.
12579 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
12580 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
12581 ! Angular derivatives of the contact function
12582                 ees0pij1=fac3/ees0pij
12583                 ees0mij1=fac3/ees0mij
12584                 fac3p=-3.0D0*fac3*rrmij
12585                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
12586                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
12587 !               ees0mij1=0.0D0
12588                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
12589                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
12590                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
12591                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
12592                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
12593                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
12594                 ecosap=ecosa1+ecosa2
12595                 ecosbp=ecosb1+ecosb2
12596                 ecosgp=ecosg1+ecosg2
12597                 ecosam=ecosa1-ecosa2
12598                 ecosbm=ecosb1-ecosb2
12599                 ecosgm=ecosg1-ecosg2
12600 ! Diagnostics
12601 !               ecosap=ecosa1
12602 !               ecosbp=ecosb1
12603 !               ecosgp=ecosg1
12604 !               ecosam=0.0D0
12605 !               ecosbm=0.0D0
12606 !               ecosgm=0.0D0
12607 ! End diagnostics
12608                 facont_hb(num_conti,i)=fcont
12609                 fprimcont=fprimcont/rij
12610 !d              facont_hb(num_conti,i)=1.0D0
12611 ! Following line is for diagnostics.
12612 !d              fprimcont=0.0D0
12613                 do k=1,3
12614                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12615                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12616                 enddo
12617                 do k=1,3
12618                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
12619                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
12620                 enddo
12621                 gggp(1)=gggp(1)+ees0pijp*xj
12622                 gggp(2)=gggp(2)+ees0pijp*yj
12623                 gggp(3)=gggp(3)+ees0pijp*zj
12624                 gggm(1)=gggm(1)+ees0mijp*xj
12625                 gggm(2)=gggm(2)+ees0mijp*yj
12626                 gggm(3)=gggm(3)+ees0mijp*zj
12627 ! Derivatives due to the contact function
12628                 gacont_hbr(1,num_conti,i)=fprimcont*xj
12629                 gacont_hbr(2,num_conti,i)=fprimcont*yj
12630                 gacont_hbr(3,num_conti,i)=fprimcont*zj
12631                 do k=1,3
12632 !
12633 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
12634 !          following the change of gradient-summation algorithm.
12635 !
12636 !grad                  ghalfp=0.5D0*gggp(k)
12637 !grad                  ghalfm=0.5D0*gggm(k)
12638                   gacontp_hb1(k,num_conti,i)= & !ghalfp
12639                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12640                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12641                   gacontp_hb2(k,num_conti,i)= & !ghalfp
12642                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12643                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12644                   gacontp_hb3(k,num_conti,i)=gggp(k)
12645                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
12646                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12647                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12648                   gacontm_hb2(k,num_conti,i)= & !ghalfm
12649                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12650                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12651                   gacontm_hb3(k,num_conti,i)=gggm(k)
12652                 enddo
12653               ENDIF ! wcorr
12654               endif  ! num_conti.le.maxconts
12655             endif  ! fcont.gt.0
12656           endif    ! j.gt.i+1
12657           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
12658             do k=1,4
12659               do l=1,3
12660                 ghalf=0.5d0*agg(l,k)
12661                 aggi(l,k)=aggi(l,k)+ghalf
12662                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
12663                 aggj(l,k)=aggj(l,k)+ghalf
12664               enddo
12665             enddo
12666             if (j.eq.nres-1 .and. i.lt.j-2) then
12667               do k=1,4
12668                 do l=1,3
12669                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
12670                 enddo
12671               enddo
12672             endif
12673           endif
12674 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
12675       return
12676       end subroutine eelecij_scale
12677 !-----------------------------------------------------------------------------
12678       subroutine evdwpp_short(evdw1)
12679 !
12680 ! Compute Evdwpp
12681 !
12682 !      implicit real*8 (a-h,o-z)
12683 !      include 'DIMENSIONS'
12684 !      include 'COMMON.CONTROL'
12685 !      include 'COMMON.IOUNITS'
12686 !      include 'COMMON.GEO'
12687 !      include 'COMMON.VAR'
12688 !      include 'COMMON.LOCAL'
12689 !      include 'COMMON.CHAIN'
12690 !      include 'COMMON.DERIV'
12691 !      include 'COMMON.INTERACT'
12692 !      include 'COMMON.CONTACTS'
12693 !      include 'COMMON.TORSION'
12694 !      include 'COMMON.VECTORS'
12695 !      include 'COMMON.FFIELD'
12696       real(kind=8),dimension(3) :: ggg
12697 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12698 #ifdef MOMENT
12699       real(kind=8) :: scal_el=1.0d0
12700 #else
12701       real(kind=8) :: scal_el=0.5d0
12702 #endif
12703 !el local variables
12704       integer :: i,j,k,iteli,itelj,num_conti
12705       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
12706       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
12707                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12708                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
12709
12710       evdw1=0.0D0
12711 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
12712 !     & " iatel_e_vdw",iatel_e_vdw
12713       call flush(iout)
12714       do i=iatel_s_vdw,iatel_e_vdw
12715         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
12716         dxi=dc(1,i)
12717         dyi=dc(2,i)
12718         dzi=dc(3,i)
12719         dx_normi=dc_norm(1,i)
12720         dy_normi=dc_norm(2,i)
12721         dz_normi=dc_norm(3,i)
12722         xmedi=c(1,i)+0.5d0*dxi
12723         ymedi=c(2,i)+0.5d0*dyi
12724         zmedi=c(3,i)+0.5d0*dzi
12725         num_conti=0
12726 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
12727 !     &   ' ielend',ielend_vdw(i)
12728         call flush(iout)
12729         do j=ielstart_vdw(i),ielend_vdw(i)
12730           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12731 !el          ind=ind+1
12732           iteli=itel(i)
12733           itelj=itel(j)
12734           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12735           aaa=app(iteli,itelj)
12736           bbb=bpp(iteli,itelj)
12737           dxj=dc(1,j)
12738           dyj=dc(2,j)
12739           dzj=dc(3,j)
12740           dx_normj=dc_norm(1,j)
12741           dy_normj=dc_norm(2,j)
12742           dz_normj=dc_norm(3,j)
12743           xj=c(1,j)+0.5D0*dxj-xmedi
12744           yj=c(2,j)+0.5D0*dyj-ymedi
12745           zj=c(3,j)+0.5D0*dzj-zmedi
12746           rij=xj*xj+yj*yj+zj*zj
12747           rrmij=1.0D0/rij
12748           rij=dsqrt(rij)
12749           sss=sscale(rij/rpp(iteli,itelj))
12750           if (sss.gt.0.0d0) then
12751             rmij=1.0D0/rij
12752             r3ij=rrmij*rmij
12753             r6ij=r3ij*r3ij
12754             ev1=aaa*r6ij*r6ij
12755 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12756             if (j.eq.i+2) ev1=scal_el*ev1
12757             ev2=bbb*r6ij
12758             evdwij=ev1+ev2
12759             if (energy_dec) then
12760               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12761             endif
12762             evdw1=evdw1+evdwij*sss
12763 !
12764 ! Calculate contributions to the Cartesian gradient.
12765 !
12766             facvdw=-6*rrmij*(ev1+evdwij)*sss
12767             ggg(1)=facvdw*xj
12768             ggg(2)=facvdw*yj
12769             ggg(3)=facvdw*zj
12770             do k=1,3
12771               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12772               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12773             enddo
12774           endif
12775         enddo ! j
12776       enddo   ! i
12777       return
12778       end subroutine evdwpp_short
12779 !-----------------------------------------------------------------------------
12780       subroutine escp_long(evdw2,evdw2_14)
12781 !
12782 ! This subroutine calculates the excluded-volume interaction energy between
12783 ! peptide-group centers and side chains and its gradient in virtual-bond and
12784 ! side-chain vectors.
12785 !
12786 !      implicit real*8 (a-h,o-z)
12787 !      include 'DIMENSIONS'
12788 !      include 'COMMON.GEO'
12789 !      include 'COMMON.VAR'
12790 !      include 'COMMON.LOCAL'
12791 !      include 'COMMON.CHAIN'
12792 !      include 'COMMON.DERIV'
12793 !      include 'COMMON.INTERACT'
12794 !      include 'COMMON.FFIELD'
12795 !      include 'COMMON.IOUNITS'
12796 !      include 'COMMON.CONTROL'
12797       real(kind=8),dimension(3) :: ggg
12798 !el local variables
12799       integer :: i,iint,j,k,iteli,itypj
12800       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12801       real(kind=8) :: evdw2,evdw2_14,evdwij
12802       evdw2=0.0D0
12803       evdw2_14=0.0d0
12804 !d    print '(a)','Enter ESCP'
12805 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12806       do i=iatscp_s,iatscp_e
12807         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12808         iteli=itel(i)
12809         xi=0.5D0*(c(1,i)+c(1,i+1))
12810         yi=0.5D0*(c(2,i)+c(2,i+1))
12811         zi=0.5D0*(c(3,i)+c(3,i+1))
12812
12813         do iint=1,nscp_gr(i)
12814
12815         do j=iscpstart(i,iint),iscpend(i,iint)
12816           itypj=itype(j)
12817           if (itypj.eq.ntyp1) cycle
12818 ! Uncomment following three lines for SC-p interactions
12819 !         xj=c(1,nres+j)-xi
12820 !         yj=c(2,nres+j)-yi
12821 !         zj=c(3,nres+j)-zi
12822 ! Uncomment following three lines for Ca-p interactions
12823           xj=c(1,j)-xi
12824           yj=c(2,j)-yi
12825           zj=c(3,j)-zi
12826           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12827
12828           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12829
12830           if (sss.lt.1.0d0) then
12831
12832             fac=rrij**expon2
12833             e1=fac*fac*aad(itypj,iteli)
12834             e2=fac*bad(itypj,iteli)
12835             if (iabs(j-i) .le. 2) then
12836               e1=scal14*e1
12837               e2=scal14*e2
12838               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
12839             endif
12840             evdwij=e1+e2
12841             evdw2=evdw2+evdwij*(1.0d0-sss)
12842             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12843                 'evdw2',i,j,sss,evdwij
12844 !
12845 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12846 !
12847             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
12848             ggg(1)=xj*fac
12849             ggg(2)=yj*fac
12850             ggg(3)=zj*fac
12851 ! Uncomment following three lines for SC-p interactions
12852 !           do k=1,3
12853 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12854 !           enddo
12855 ! Uncomment following line for SC-p interactions
12856 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12857             do k=1,3
12858               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12859               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12860             enddo
12861           endif
12862         enddo
12863
12864         enddo ! iint
12865       enddo ! i
12866       do i=1,nct
12867         do j=1,3
12868           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12869           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12870           gradx_scp(j,i)=expon*gradx_scp(j,i)
12871         enddo
12872       enddo
12873 !******************************************************************************
12874 !
12875 !                              N O T E !!!
12876 !
12877 ! To save time the factor EXPON has been extracted from ALL components
12878 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12879 ! use!
12880 !
12881 !******************************************************************************
12882       return
12883       end subroutine escp_long
12884 !-----------------------------------------------------------------------------
12885       subroutine escp_short(evdw2,evdw2_14)
12886 !
12887 ! This subroutine calculates the excluded-volume interaction energy between
12888 ! peptide-group centers and side chains and its gradient in virtual-bond and
12889 ! side-chain vectors.
12890 !
12891 !      implicit real*8 (a-h,o-z)
12892 !      include 'DIMENSIONS'
12893 !      include 'COMMON.GEO'
12894 !      include 'COMMON.VAR'
12895 !      include 'COMMON.LOCAL'
12896 !      include 'COMMON.CHAIN'
12897 !      include 'COMMON.DERIV'
12898 !      include 'COMMON.INTERACT'
12899 !      include 'COMMON.FFIELD'
12900 !      include 'COMMON.IOUNITS'
12901 !      include 'COMMON.CONTROL'
12902       real(kind=8),dimension(3) :: ggg
12903 !el local variables
12904       integer :: i,iint,j,k,iteli,itypj
12905       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12906       real(kind=8) :: evdw2,evdw2_14,evdwij
12907       evdw2=0.0D0
12908       evdw2_14=0.0d0
12909 !d    print '(a)','Enter ESCP'
12910 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12911       do i=iatscp_s,iatscp_e
12912         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12913         iteli=itel(i)
12914         xi=0.5D0*(c(1,i)+c(1,i+1))
12915         yi=0.5D0*(c(2,i)+c(2,i+1))
12916         zi=0.5D0*(c(3,i)+c(3,i+1))
12917
12918         do iint=1,nscp_gr(i)
12919
12920         do j=iscpstart(i,iint),iscpend(i,iint)
12921           itypj=itype(j)
12922           if (itypj.eq.ntyp1) cycle
12923 ! Uncomment following three lines for SC-p interactions
12924 !         xj=c(1,nres+j)-xi
12925 !         yj=c(2,nres+j)-yi
12926 !         zj=c(3,nres+j)-zi
12927 ! Uncomment following three lines for Ca-p interactions
12928           xj=c(1,j)-xi
12929           yj=c(2,j)-yi
12930           zj=c(3,j)-zi
12931           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12932
12933           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12934
12935           if (sss.gt.0.0d0) then
12936
12937             fac=rrij**expon2
12938             e1=fac*fac*aad(itypj,iteli)
12939             e2=fac*bad(itypj,iteli)
12940             if (iabs(j-i) .le. 2) then
12941               e1=scal14*e1
12942               e2=scal14*e2
12943               evdw2_14=evdw2_14+(e1+e2)*sss
12944             endif
12945             evdwij=e1+e2
12946             evdw2=evdw2+evdwij*sss
12947             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12948                 'evdw2',i,j,sss,evdwij
12949 !
12950 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12951 !
12952             fac=-(evdwij+e1)*rrij*sss
12953             ggg(1)=xj*fac
12954             ggg(2)=yj*fac
12955             ggg(3)=zj*fac
12956 ! Uncomment following three lines for SC-p interactions
12957 !           do k=1,3
12958 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12959 !           enddo
12960 ! Uncomment following line for SC-p interactions
12961 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12962             do k=1,3
12963               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12964               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12965             enddo
12966           endif
12967         enddo
12968
12969         enddo ! iint
12970       enddo ! i
12971       do i=1,nct
12972         do j=1,3
12973           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12974           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12975           gradx_scp(j,i)=expon*gradx_scp(j,i)
12976         enddo
12977       enddo
12978 !******************************************************************************
12979 !
12980 !                              N O T E !!!
12981 !
12982 ! To save time the factor EXPON has been extracted from ALL components
12983 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12984 ! use!
12985 !
12986 !******************************************************************************
12987       return
12988       end subroutine escp_short
12989 !-----------------------------------------------------------------------------
12990 ! energy_p_new-sep_barrier.F
12991 !-----------------------------------------------------------------------------
12992       subroutine sc_grad_scale(scalfac)
12993 !      implicit real*8 (a-h,o-z)
12994       use calc_data
12995 !      include 'DIMENSIONS'
12996 !      include 'COMMON.CHAIN'
12997 !      include 'COMMON.DERIV'
12998 !      include 'COMMON.CALC'
12999 !      include 'COMMON.IOUNITS'
13000       real(kind=8),dimension(3) :: dcosom1,dcosom2
13001       real(kind=8) :: scalfac
13002 !el local variables
13003 !      integer :: i,j,k,l
13004
13005       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13006       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13007       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13008            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13009 ! diagnostics only
13010 !      eom1=0.0d0
13011 !      eom2=0.0d0
13012 !      eom12=evdwij*eps1_om12
13013 ! end diagnostics
13014 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13015 !     &  " sigder",sigder
13016 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13017 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13018       do k=1,3
13019         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13020         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13021       enddo
13022       do k=1,3
13023         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
13024       enddo
13025 !      write (iout,*) "gg",(gg(k),k=1,3)
13026       do k=1,3
13027         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13028                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13029                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac
13030         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13031                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13032                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac
13033 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13034 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13035 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13036 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13037       enddo
13038 !
13039 ! Calculate the components of the gradient in DC and X
13040 !
13041       do l=1,3
13042         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13043         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13044       enddo
13045       return
13046       end subroutine sc_grad_scale
13047 !-----------------------------------------------------------------------------
13048 ! energy_split-sep.F
13049 !-----------------------------------------------------------------------------
13050       subroutine etotal_long(energia)
13051 !
13052 ! Compute the long-range slow-varying contributions to the energy
13053 !
13054 !      implicit real*8 (a-h,o-z)
13055 !      include 'DIMENSIONS'
13056       use MD_data, only: totT
13057 #ifndef ISNAN
13058       external proc_proc
13059 #ifdef WINPGI
13060 !MS$ATTRIBUTES C ::  proc_proc
13061 #endif
13062 #endif
13063 #ifdef MPI
13064       include "mpif.h"
13065       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13066 #endif
13067 !      include 'COMMON.SETUP'
13068 !      include 'COMMON.IOUNITS'
13069 !      include 'COMMON.FFIELD'
13070 !      include 'COMMON.DERIV'
13071 !      include 'COMMON.INTERACT'
13072 !      include 'COMMON.SBRIDGE'
13073 !      include 'COMMON.CHAIN'
13074 !      include 'COMMON.VAR'
13075 !      include 'COMMON.LOCAL'
13076 !      include 'COMMON.MD'
13077       real(kind=8),dimension(0:n_ene) :: energia
13078 !el local variables
13079       integer :: i,n_corr,n_corr1,ierror,ierr
13080       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13081                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13082                   ecorr,ecorr5,ecorr6,eturn6,time00
13083 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13084 !elwrite(iout,*)"in etotal long"
13085
13086       if (modecalc.eq.12.or.modecalc.eq.14) then
13087 #ifdef MPI
13088 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13089 #else
13090         call int_from_cart1(.false.)
13091 #endif
13092       endif
13093 !elwrite(iout,*)"in etotal long"
13094
13095 #ifdef MPI
13096 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13097 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13098       call flush(iout)
13099       if (nfgtasks.gt.1) then
13100         time00=MPI_Wtime()
13101 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13102         if (fg_rank.eq.0) then
13103           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13104 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13105 !          call flush(iout)
13106 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13107 ! FG slaves as WEIGHTS array.
13108           weights_(1)=wsc
13109           weights_(2)=wscp
13110           weights_(3)=welec
13111           weights_(4)=wcorr
13112           weights_(5)=wcorr5
13113           weights_(6)=wcorr6
13114           weights_(7)=wel_loc
13115           weights_(8)=wturn3
13116           weights_(9)=wturn4
13117           weights_(10)=wturn6
13118           weights_(11)=wang
13119           weights_(12)=wscloc
13120           weights_(13)=wtor
13121           weights_(14)=wtor_d
13122           weights_(15)=wstrain
13123           weights_(16)=wvdwpp
13124           weights_(17)=wbond
13125           weights_(18)=scal14
13126           weights_(21)=wsccor
13127 ! FG Master broadcasts the WEIGHTS_ array
13128           call MPI_Bcast(weights_(1),n_ene,&
13129               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13130         else
13131 ! FG slaves receive the WEIGHTS array
13132           call MPI_Bcast(weights(1),n_ene,&
13133               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13134           wsc=weights(1)
13135           wscp=weights(2)
13136           welec=weights(3)
13137           wcorr=weights(4)
13138           wcorr5=weights(5)
13139           wcorr6=weights(6)
13140           wel_loc=weights(7)
13141           wturn3=weights(8)
13142           wturn4=weights(9)
13143           wturn6=weights(10)
13144           wang=weights(11)
13145           wscloc=weights(12)
13146           wtor=weights(13)
13147           wtor_d=weights(14)
13148           wstrain=weights(15)
13149           wvdwpp=weights(16)
13150           wbond=weights(17)
13151           scal14=weights(18)
13152           wsccor=weights(21)
13153         endif
13154         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13155           king,FG_COMM,IERR)
13156          time_Bcast=time_Bcast+MPI_Wtime()-time00
13157          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13158 !        call chainbuild_cart
13159 !        call int_from_cart1(.false.)
13160       endif
13161 !      write (iout,*) 'Processor',myrank,
13162 !     &  ' calling etotal_short ipot=',ipot
13163 !      call flush(iout)
13164 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13165 #endif
13166 !d    print *,'nnt=',nnt,' nct=',nct
13167 !
13168 !elwrite(iout,*)"in etotal long"
13169 ! Compute the side-chain and electrostatic interaction energy
13170 !
13171       goto (101,102,103,104,105,106) ipot
13172 ! Lennard-Jones potential.
13173   101 call elj_long(evdw)
13174 !d    print '(a)','Exit ELJ'
13175       goto 107
13176 ! Lennard-Jones-Kihara potential (shifted).
13177   102 call eljk_long(evdw)
13178       goto 107
13179 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13180   103 call ebp_long(evdw)
13181       goto 107
13182 ! Gay-Berne potential (shifted LJ, angular dependence).
13183   104 call egb_long(evdw)
13184       goto 107
13185 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13186   105 call egbv_long(evdw)
13187       goto 107
13188 ! Soft-sphere potential
13189   106 call e_softsphere(evdw)
13190 !
13191 ! Calculate electrostatic (H-bonding) energy of the main chain.
13192 !
13193   107 continue
13194       call vec_and_deriv
13195       if (ipot.lt.6) then
13196 #ifdef SPLITELE
13197          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13198              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13199              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13200              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13201 #else
13202          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13203              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13204              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13205              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13206 #endif
13207            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13208          else
13209             ees=0
13210             evdw1=0
13211             eel_loc=0
13212             eello_turn3=0
13213             eello_turn4=0
13214          endif
13215       else
13216 !        write (iout,*) "Soft-spheer ELEC potential"
13217         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13218          eello_turn4)
13219       endif
13220 !
13221 ! Calculate excluded-volume interaction energy between peptide groups
13222 ! and side chains.
13223 !
13224       if (ipot.lt.6) then
13225        if(wscp.gt.0d0) then
13226         call escp_long(evdw2,evdw2_14)
13227        else
13228         evdw2=0
13229         evdw2_14=0
13230        endif
13231       else
13232         call escp_soft_sphere(evdw2,evdw2_14)
13233       endif
13234 !
13235 ! 12/1/95 Multi-body terms
13236 !
13237       n_corr=0
13238       n_corr1=0
13239       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13240           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13241          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13242 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13243 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13244       else
13245          ecorr=0.0d0
13246          ecorr5=0.0d0
13247          ecorr6=0.0d0
13248          eturn6=0.0d0
13249       endif
13250       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13251          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13252       endif
13253 !
13254 ! If performing constraint dynamics, call the constraint energy
13255 !  after the equilibration time
13256       if(usampl.and.totT.gt.eq_time) then
13257          call EconstrQ
13258          call Econstr_back
13259       else
13260          Uconst=0.0d0
13261          Uconst_back=0.0d0
13262       endif
13263 !
13264 ! Sum the energies
13265 !
13266       do i=1,n_ene
13267         energia(i)=0.0d0
13268       enddo
13269       energia(1)=evdw
13270 #ifdef SCP14
13271       energia(2)=evdw2-evdw2_14
13272       energia(18)=evdw2_14
13273 #else
13274       energia(2)=evdw2
13275       energia(18)=0.0d0
13276 #endif
13277 #ifdef SPLITELE
13278       energia(3)=ees
13279       energia(16)=evdw1
13280 #else
13281       energia(3)=ees+evdw1
13282       energia(16)=0.0d0
13283 #endif
13284       energia(4)=ecorr
13285       energia(5)=ecorr5
13286       energia(6)=ecorr6
13287       energia(7)=eel_loc
13288       energia(8)=eello_turn3
13289       energia(9)=eello_turn4
13290       energia(10)=eturn6
13291       energia(20)=Uconst+Uconst_back
13292       call sum_energy(energia,.true.)
13293 !      write (iout,*) "Exit ETOTAL_LONG"
13294       call flush(iout)
13295       return
13296       end subroutine etotal_long
13297 !-----------------------------------------------------------------------------
13298       subroutine etotal_short(energia)
13299 !
13300 ! Compute the short-range fast-varying contributions to the energy
13301 !
13302 !      implicit real*8 (a-h,o-z)
13303 !      include 'DIMENSIONS'
13304 #ifndef ISNAN
13305       external proc_proc
13306 #ifdef WINPGI
13307 !MS$ATTRIBUTES C ::  proc_proc
13308 #endif
13309 #endif
13310 #ifdef MPI
13311       include "mpif.h"
13312       integer :: ierror,ierr
13313       real(kind=8),dimension(n_ene) :: weights_
13314       real(kind=8) :: time00
13315 #endif
13316 !      include 'COMMON.SETUP'
13317 !      include 'COMMON.IOUNITS'
13318 !      include 'COMMON.FFIELD'
13319 !      include 'COMMON.DERIV'
13320 !      include 'COMMON.INTERACT'
13321 !      include 'COMMON.SBRIDGE'
13322 !      include 'COMMON.CHAIN'
13323 !      include 'COMMON.VAR'
13324 !      include 'COMMON.LOCAL'
13325       real(kind=8),dimension(0:n_ene) :: energia
13326 !el local variables
13327       integer :: i,nres6
13328       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13329       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13330       nres6=6*nres
13331
13332 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13333 !      call flush(iout)
13334       if (modecalc.eq.12.or.modecalc.eq.14) then
13335 #ifdef MPI
13336         if (fg_rank.eq.0) call int_from_cart1(.false.)
13337 #else
13338         call int_from_cart1(.false.)
13339 #endif
13340       endif
13341 #ifdef MPI
13342 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13343 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13344 !      call flush(iout)
13345       if (nfgtasks.gt.1) then
13346         time00=MPI_Wtime()
13347 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13348         if (fg_rank.eq.0) then
13349           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13350 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13351 !          call flush(iout)
13352 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13353 ! FG slaves as WEIGHTS array.
13354           weights_(1)=wsc
13355           weights_(2)=wscp
13356           weights_(3)=welec
13357           weights_(4)=wcorr
13358           weights_(5)=wcorr5
13359           weights_(6)=wcorr6
13360           weights_(7)=wel_loc
13361           weights_(8)=wturn3
13362           weights_(9)=wturn4
13363           weights_(10)=wturn6
13364           weights_(11)=wang
13365           weights_(12)=wscloc
13366           weights_(13)=wtor
13367           weights_(14)=wtor_d
13368           weights_(15)=wstrain
13369           weights_(16)=wvdwpp
13370           weights_(17)=wbond
13371           weights_(18)=scal14
13372           weights_(21)=wsccor
13373 ! FG Master broadcasts the WEIGHTS_ array
13374           call MPI_Bcast(weights_(1),n_ene,&
13375               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13376         else
13377 ! FG slaves receive the WEIGHTS array
13378           call MPI_Bcast(weights(1),n_ene,&
13379               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13380           wsc=weights(1)
13381           wscp=weights(2)
13382           welec=weights(3)
13383           wcorr=weights(4)
13384           wcorr5=weights(5)
13385           wcorr6=weights(6)
13386           wel_loc=weights(7)
13387           wturn3=weights(8)
13388           wturn4=weights(9)
13389           wturn6=weights(10)
13390           wang=weights(11)
13391           wscloc=weights(12)
13392           wtor=weights(13)
13393           wtor_d=weights(14)
13394           wstrain=weights(15)
13395           wvdwpp=weights(16)
13396           wbond=weights(17)
13397           scal14=weights(18)
13398           wsccor=weights(21)
13399         endif
13400 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13401         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13402           king,FG_COMM,IERR)
13403 !        write (iout,*) "Processor",myrank," BROADCAST c"
13404         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13405           king,FG_COMM,IERR)
13406 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13407         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13408           king,FG_COMM,IERR)
13409 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13410         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13411           king,FG_COMM,IERR)
13412 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13413         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13414           king,FG_COMM,IERR)
13415 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13416         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13417           king,FG_COMM,IERR)
13418 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13419         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13420           king,FG_COMM,IERR)
13421 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13422         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13423           king,FG_COMM,IERR)
13424 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13425         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13426           king,FG_COMM,IERR)
13427          time_Bcast=time_Bcast+MPI_Wtime()-time00
13428 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13429       endif
13430 !      write (iout,*) 'Processor',myrank,
13431 !     &  ' calling etotal_short ipot=',ipot
13432 !      call flush(iout)
13433 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13434 #endif
13435 !      call int_from_cart1(.false.)
13436 !
13437 ! Compute the side-chain and electrostatic interaction energy
13438 !
13439       goto (101,102,103,104,105,106) ipot
13440 ! Lennard-Jones potential.
13441   101 call elj_short(evdw)
13442 !d    print '(a)','Exit ELJ'
13443       goto 107
13444 ! Lennard-Jones-Kihara potential (shifted).
13445   102 call eljk_short(evdw)
13446       goto 107
13447 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13448   103 call ebp_short(evdw)
13449       goto 107
13450 ! Gay-Berne potential (shifted LJ, angular dependence).
13451   104 call egb_short(evdw)
13452       goto 107
13453 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13454   105 call egbv_short(evdw)
13455       goto 107
13456 ! Soft-sphere potential - already dealt with in the long-range part
13457   106 evdw=0.0d0
13458 !  106 call e_softsphere_short(evdw)
13459 !
13460 ! Calculate electrostatic (H-bonding) energy of the main chain.
13461 !
13462   107 continue
13463 !
13464 ! Calculate the short-range part of Evdwpp
13465 !
13466       call evdwpp_short(evdw1)
13467 !
13468 ! Calculate the short-range part of ESCp
13469 !
13470       if (ipot.lt.6) then
13471         call escp_short(evdw2,evdw2_14)
13472       endif
13473 !
13474 ! Calculate the bond-stretching energy
13475 !
13476       call ebond(estr)
13477 !
13478 ! Calculate the disulfide-bridge and other energy and the contributions
13479 ! from other distance constraints.
13480       call edis(ehpb)
13481 !
13482 ! Calculate the virtual-bond-angle energy.
13483 !
13484       call ebend(ebe)
13485 !
13486 ! Calculate the SC local energy.
13487 !
13488       call vec_and_deriv
13489       call esc(escloc)
13490 !
13491 ! Calculate the virtual-bond torsional energy.
13492 !
13493       call etor(etors,edihcnstr)
13494 !
13495 ! 6/23/01 Calculate double-torsional energy
13496 !
13497       call etor_d(etors_d)
13498 !
13499 ! 21/5/07 Calculate local sicdechain correlation energy
13500 !
13501       if (wsccor.gt.0.0d0) then
13502         call eback_sc_corr(esccor)
13503       else
13504         esccor=0.0d0
13505       endif
13506 !
13507 ! Put energy components into an array
13508 !
13509       do i=1,n_ene
13510         energia(i)=0.0d0
13511       enddo
13512       energia(1)=evdw
13513 #ifdef SCP14
13514       energia(2)=evdw2-evdw2_14
13515       energia(18)=evdw2_14
13516 #else
13517       energia(2)=evdw2
13518       energia(18)=0.0d0
13519 #endif
13520 #ifdef SPLITELE
13521       energia(16)=evdw1
13522 #else
13523       energia(3)=evdw1
13524 #endif
13525       energia(11)=ebe
13526       energia(12)=escloc
13527       energia(13)=etors
13528       energia(14)=etors_d
13529       energia(15)=ehpb
13530       energia(17)=estr
13531       energia(19)=edihcnstr
13532       energia(21)=esccor
13533 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
13534       call flush(iout)
13535       call sum_energy(energia,.true.)
13536 !      write (iout,*) "Exit ETOTAL_SHORT"
13537       call flush(iout)
13538       return
13539       end subroutine etotal_short
13540 !-----------------------------------------------------------------------------
13541 ! gnmr1.f
13542 !-----------------------------------------------------------------------------
13543       real(kind=8) function gnmr1(y,ymin,ymax)
13544 !      implicit none
13545       real(kind=8) :: y,ymin,ymax
13546       real(kind=8) :: wykl=4.0d0
13547       if (y.lt.ymin) then
13548         gnmr1=(ymin-y)**wykl/wykl
13549       else if (y.gt.ymax) then
13550         gnmr1=(y-ymax)**wykl/wykl
13551       else
13552         gnmr1=0.0d0
13553       endif
13554       return
13555       end function gnmr1
13556 !-----------------------------------------------------------------------------
13557       real(kind=8) function gnmr1prim(y,ymin,ymax)
13558 !      implicit none
13559       real(kind=8) :: y,ymin,ymax
13560       real(kind=8) :: wykl=4.0d0
13561       if (y.lt.ymin) then
13562         gnmr1prim=-(ymin-y)**(wykl-1)
13563       else if (y.gt.ymax) then
13564         gnmr1prim=(y-ymax)**(wykl-1)
13565       else
13566         gnmr1prim=0.0d0
13567       endif
13568       return
13569       end function gnmr1prim
13570 !-----------------------------------------------------------------------------
13571       real(kind=8) function harmonic(y,ymax)
13572 !      implicit none
13573       real(kind=8) :: y,ymax
13574       real(kind=8) :: wykl=2.0d0
13575       harmonic=(y-ymax)**wykl
13576       return
13577       end function harmonic
13578 !-----------------------------------------------------------------------------
13579       real(kind=8) function harmonicprim(y,ymax)
13580       real(kind=8) :: y,ymin,ymax
13581       real(kind=8) :: wykl=2.0d0
13582       harmonicprim=(y-ymax)*wykl
13583       return
13584       end function harmonicprim
13585 !-----------------------------------------------------------------------------
13586 ! gradient_p.F
13587 !-----------------------------------------------------------------------------
13588       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
13589
13590       use io_base, only:intout,briefout
13591 !      implicit real*8 (a-h,o-z)
13592 !      include 'DIMENSIONS'
13593 !      include 'COMMON.CHAIN'
13594 !      include 'COMMON.DERIV'
13595 !      include 'COMMON.VAR'
13596 !      include 'COMMON.INTERACT'
13597 !      include 'COMMON.FFIELD'
13598 !      include 'COMMON.MD'
13599 !      include 'COMMON.IOUNITS'
13600       real(kind=8),external :: ufparm
13601       integer :: uiparm(1)
13602       real(kind=8) :: urparm(1)
13603       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13604       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
13605       integer :: n,nf,ind,ind1,i,k,j
13606 !
13607 ! This subroutine calculates total internal coordinate gradient.
13608 ! Depending on the number of function evaluations, either whole energy
13609 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
13610 ! internal coordinates are reevaluated or only the cartesian-in-internal
13611 ! coordinate derivatives are evaluated. The subroutine was designed to work
13612 ! with SUMSL.
13613 !
13614 !
13615       icg=mod(nf,2)+1
13616
13617 !d      print *,'grad',nf,icg
13618       if (nf-nfl+1) 20,30,40
13619    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
13620 !    write (iout,*) 'grad 20'
13621       if (nf.eq.0) return
13622       goto 40
13623    30 call var_to_geom(n,x)
13624       call chainbuild
13625 !    write (iout,*) 'grad 30'
13626 !
13627 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
13628 !
13629    40 call cartder
13630 !     write (iout,*) 'grad 40'
13631 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
13632 !
13633 ! Convert the Cartesian gradient into internal-coordinate gradient.
13634 !
13635       ind=0
13636       ind1=0
13637       do i=1,nres-2
13638         gthetai=0.0D0
13639         gphii=0.0D0
13640         do j=i+1,nres-1
13641           ind=ind+1
13642 !         ind=indmat(i,j)
13643 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
13644           do k=1,3
13645             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
13646           enddo
13647           do k=1,3
13648             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
13649           enddo
13650         enddo
13651         do j=i+1,nres-1
13652           ind1=ind1+1
13653 !         ind1=indmat(i,j)
13654 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
13655           do k=1,3
13656             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
13657             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
13658           enddo
13659         enddo
13660         if (i.gt.1) g(i-1)=gphii
13661         if (n.gt.nphi) g(nphi+i)=gthetai
13662       enddo
13663       if (n.le.nphi+ntheta) goto 10
13664       do i=2,nres-1
13665         if (itype(i).ne.10) then
13666           galphai=0.0D0
13667           gomegai=0.0D0
13668           do k=1,3
13669             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
13670           enddo
13671           do k=1,3
13672             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
13673           enddo
13674           g(ialph(i,1))=galphai
13675           g(ialph(i,1)+nside)=gomegai
13676         endif
13677       enddo
13678 !
13679 ! Add the components corresponding to local energy terms.
13680 !
13681    10 continue
13682       do i=1,nvar
13683 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
13684         g(i)=g(i)+gloc(i,icg)
13685       enddo
13686 ! Uncomment following three lines for diagnostics.
13687 !d    call intout
13688 !elwrite(iout,*) "in gradient after calling intout"
13689 !d    call briefout(0,0.0d0)
13690 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
13691       return
13692       end subroutine gradient
13693 !-----------------------------------------------------------------------------
13694       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
13695
13696       use comm_chu
13697 !      implicit real*8 (a-h,o-z)
13698 !      include 'DIMENSIONS'
13699 !      include 'COMMON.DERIV'
13700 !      include 'COMMON.IOUNITS'
13701 !      include 'COMMON.GEO'
13702       integer :: n,nf
13703 !el      integer :: jjj
13704 !el      common /chuju/ jjj
13705       real(kind=8) :: energia(0:n_ene)
13706       integer :: uiparm(1)
13707       real(kind=8) :: urparm(1)
13708       real(kind=8) :: f
13709       real(kind=8),external :: ufparm
13710       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
13711 !     if (jjj.gt.0) then
13712 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13713 !     endif
13714       nfl=nf
13715       icg=mod(nf,2)+1
13716 !d      print *,'func',nf,nfl,icg
13717       call var_to_geom(n,x)
13718       call zerograd
13719       call chainbuild
13720 !d    write (iout,*) 'ETOTAL called from FUNC'
13721       call etotal(energia)
13722       call sum_gradient
13723       f=energia(0)
13724 !     if (jjj.gt.0) then
13725 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13726 !       write (iout,*) 'f=',etot
13727 !       jjj=0
13728 !     endif
13729       return
13730       end subroutine func
13731 !-----------------------------------------------------------------------------
13732       subroutine cartgrad
13733 !      implicit real*8 (a-h,o-z)
13734 !      include 'DIMENSIONS'
13735       use energy_data
13736       use MD_data, only: totT
13737 #ifdef MPI
13738       include 'mpif.h'
13739 #endif
13740 !      include 'COMMON.CHAIN'
13741 !      include 'COMMON.DERIV'
13742 !      include 'COMMON.VAR'
13743 !      include 'COMMON.INTERACT'
13744 !      include 'COMMON.FFIELD'
13745 !      include 'COMMON.MD'
13746 !      include 'COMMON.IOUNITS'
13747 !      include 'COMMON.TIME1'
13748 !
13749       integer :: i,j
13750
13751 ! This subrouting calculates total Cartesian coordinate gradient.
13752 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
13753 !
13754 !el#define DEBUG
13755 #ifdef TIMING
13756       time00=MPI_Wtime()
13757 #endif
13758       icg=1
13759       call sum_gradient
13760 #ifdef TIMING
13761 #endif
13762 !el      write (iout,*) "After sum_gradient"
13763 #ifdef DEBUG
13764 !el      write (iout,*) "After sum_gradient"
13765       do i=1,nres-1
13766         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
13767         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
13768       enddo
13769 #endif
13770 ! If performing constraint dynamics, add the gradients of the constraint energy
13771       if(usampl.and.totT.gt.eq_time) then
13772          do i=1,nct
13773            do j=1,3
13774              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
13775              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
13776            enddo
13777          enddo
13778          do i=1,nres-3
13779            gloc(i,icg)=gloc(i,icg)+dugamma(i)
13780          enddo
13781          do i=1,nres-2
13782            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
13783          enddo
13784       endif
13785 !elwrite (iout,*) "After sum_gradient"
13786 #ifdef TIMING
13787       time01=MPI_Wtime()
13788 #endif
13789       call intcartderiv
13790 !elwrite (iout,*) "After sum_gradient"
13791 #ifdef TIMING
13792       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
13793 #endif
13794 !     call checkintcartgrad
13795 !     write(iout,*) 'calling int_to_cart'
13796 #ifdef DEBUG
13797       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
13798 #endif
13799       do i=1,nct
13800         do j=1,3
13801           gcart(j,i)=gradc(j,i,icg)
13802           gxcart(j,i)=gradx(j,i,icg)
13803         enddo
13804 #ifdef DEBUG
13805         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
13806           (gxcart(j,i),j=1,3),gloc(i,icg)
13807 #endif
13808       enddo
13809 #ifdef TIMING
13810       time01=MPI_Wtime()
13811 #endif
13812       call int_to_cart
13813 #ifdef TIMING
13814       time_inttocart=time_inttocart+MPI_Wtime()-time01
13815 #endif
13816 #ifdef DEBUG
13817       write (iout,*) "gcart and gxcart after int_to_cart"
13818       do i=0,nres-1
13819         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13820             (gxcart(j,i),j=1,3)
13821       enddo
13822 #endif
13823 #ifdef TIMING
13824       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
13825 #endif
13826 !el#undef DEBUG
13827       return
13828       end subroutine cartgrad
13829 !-----------------------------------------------------------------------------
13830       subroutine zerograd
13831 !      implicit real*8 (a-h,o-z)
13832 !      include 'DIMENSIONS'
13833 !      include 'COMMON.DERIV'
13834 !      include 'COMMON.CHAIN'
13835 !      include 'COMMON.VAR'
13836 !      include 'COMMON.MD'
13837 !      include 'COMMON.SCCOR'
13838 !
13839 !el local variables
13840       integer :: i,j,intertyp
13841 ! Initialize Cartesian-coordinate gradient
13842 !
13843 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
13844 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
13845
13846 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
13847 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
13848 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
13849 !      allocate(gradcorr_long(3,nres))
13850 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
13851 !      allocate(gcorr6_turn_long(3,nres))
13852 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
13853
13854 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
13855
13856 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
13857 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
13858
13859 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
13860 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
13861
13862 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
13863 !      allocate(gscloc(3,nres)) !(3,maxres)
13864 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
13865
13866
13867
13868 !      common /deriv_scloc/
13869 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
13870 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
13871 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
13872 !      common /mpgrad/
13873 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
13874
13875
13876
13877 !          gradc(j,i,icg)=0.0d0
13878 !          gradx(j,i,icg)=0.0d0
13879
13880 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
13881 !elwrite(iout,*) "icg",icg
13882       do i=1,nres
13883         do j=1,3
13884           gvdwx(j,i)=0.0D0
13885           gradx_scp(j,i)=0.0D0
13886           gvdwc(j,i)=0.0D0
13887           gvdwc_scp(j,i)=0.0D0
13888           gvdwc_scpp(j,i)=0.0d0
13889           gelc(j,i)=0.0D0
13890           gelc_long(j,i)=0.0D0
13891           gradb(j,i)=0.0d0
13892           gradbx(j,i)=0.0d0
13893           gvdwpp(j,i)=0.0d0
13894           gel_loc(j,i)=0.0d0
13895           gel_loc_long(j,i)=0.0d0
13896           ghpbc(j,i)=0.0D0
13897           ghpbx(j,i)=0.0D0
13898           gcorr3_turn(j,i)=0.0d0
13899           gcorr4_turn(j,i)=0.0d0
13900           gradcorr(j,i)=0.0d0
13901           gradcorr_long(j,i)=0.0d0
13902           gradcorr5_long(j,i)=0.0d0
13903           gradcorr6_long(j,i)=0.0d0
13904           gcorr6_turn_long(j,i)=0.0d0
13905           gradcorr5(j,i)=0.0d0
13906           gradcorr6(j,i)=0.0d0
13907           gcorr6_turn(j,i)=0.0d0
13908           gsccorc(j,i)=0.0d0
13909           gsccorx(j,i)=0.0d0
13910           gradc(j,i,icg)=0.0d0
13911           gradx(j,i,icg)=0.0d0
13912           gscloc(j,i)=0.0d0
13913           gsclocx(j,i)=0.0d0
13914           do intertyp=1,3
13915            gloc_sc(intertyp,i,icg)=0.0d0
13916           enddo
13917         enddo
13918       enddo
13919 !
13920 ! Initialize the gradient of local energy terms.
13921 !
13922 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
13923 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13924 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13925 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
13926 !      allocate(gel_loc_turn3(nres))
13927 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
13928 !      allocate(gsccor_loc(nres))       !(maxres)
13929
13930       do i=1,4*nres
13931         gloc(i,icg)=0.0D0
13932       enddo
13933       do i=1,nres
13934         gel_loc_loc(i)=0.0d0
13935         gcorr_loc(i)=0.0d0
13936         g_corr5_loc(i)=0.0d0
13937         g_corr6_loc(i)=0.0d0
13938         gel_loc_turn3(i)=0.0d0
13939         gel_loc_turn4(i)=0.0d0
13940         gel_loc_turn6(i)=0.0d0
13941         gsccor_loc(i)=0.0d0
13942       enddo
13943 ! initialize gcart and gxcart
13944 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
13945       do i=0,nres
13946         do j=1,3
13947           gcart(j,i)=0.0d0
13948           gxcart(j,i)=0.0d0
13949         enddo
13950       enddo
13951       return
13952       end subroutine zerograd
13953 !-----------------------------------------------------------------------------
13954       real(kind=8) function fdum()
13955       fdum=0.0D0
13956       return
13957       end function fdum
13958 !-----------------------------------------------------------------------------
13959 ! intcartderiv.F
13960 !-----------------------------------------------------------------------------
13961       subroutine intcartderiv
13962 !      implicit real*8 (a-h,o-z)
13963 !      include 'DIMENSIONS'
13964 #ifdef MPI
13965       include 'mpif.h'
13966 #endif
13967 !      include 'COMMON.SETUP'
13968 !      include 'COMMON.CHAIN'
13969 !      include 'COMMON.VAR'
13970 !      include 'COMMON.GEO'
13971 !      include 'COMMON.INTERACT'
13972 !      include 'COMMON.DERIV'
13973 !      include 'COMMON.IOUNITS'
13974 !      include 'COMMON.LOCAL'
13975 !      include 'COMMON.SCCOR'
13976       real(kind=8) :: pi4,pi34
13977       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
13978       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
13979                     dcosomega,dsinomega !(3,3,maxres)
13980       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
13981
13982       integer :: i,j,k
13983       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
13984                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
13985                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
13986                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
13987       integer :: nres2
13988       nres2=2*nres
13989
13990 !el from module energy-------------
13991 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
13992 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
13993 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
13994
13995 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
13996 !el      allocate(dsintau(3,3,3,0:nres2))
13997 !el      allocate(dtauangle(3,3,3,0:nres2))
13998 !el      allocate(domicron(3,2,2,0:nres2))
13999 !el      allocate(dcosomicron(3,2,2,0:nres2))
14000
14001
14002
14003 #if defined(MPI) && defined(PARINTDER)
14004       if (nfgtasks.gt.1 .and. me.eq.king) &
14005         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14006 #endif
14007       pi4 = 0.5d0*pipol
14008       pi34 = 3*pi4
14009
14010 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14011 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14012
14013 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14014       do i=1,nres
14015         do j=1,3
14016           dtheta(j,1,i)=0.0d0
14017           dtheta(j,2,i)=0.0d0
14018           dphi(j,1,i)=0.0d0
14019           dphi(j,2,i)=0.0d0
14020           dphi(j,3,i)=0.0d0
14021         enddo
14022       enddo
14023 ! Derivatives of theta's
14024 #if defined(MPI) && defined(PARINTDER)
14025 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14026       do i=max0(ithet_start-1,3),ithet_end
14027 #else
14028       do i=3,nres
14029 #endif
14030         cost=dcos(theta(i))
14031         sint=sqrt(1-cost*cost)
14032         do j=1,3
14033           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14034           vbld(i-1)
14035           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14036           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14037           vbld(i)
14038           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14039         enddo
14040       enddo
14041 #if defined(MPI) && defined(PARINTDER)
14042 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14043       do i=max0(ithet_start-1,3),ithet_end
14044 #else
14045       do i=3,nres
14046 #endif
14047       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14048         cost1=dcos(omicron(1,i))
14049         sint1=sqrt(1-cost1*cost1)
14050         cost2=dcos(omicron(2,i))
14051         sint2=sqrt(1-cost2*cost2)
14052        do j=1,3
14053 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14054           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14055           cost1*dc_norm(j,i-2))/ &
14056           vbld(i-1)
14057           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14058           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14059           +cost1*(dc_norm(j,i-1+nres)))/ &
14060           vbld(i-1+nres)
14061           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14062 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14063 !C Looks messy but better than if in loop
14064           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14065           +cost2*dc_norm(j,i-1))/ &
14066           vbld(i)
14067           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14068           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14069            +cost2*(-dc_norm(j,i-1+nres)))/ &
14070           vbld(i-1+nres)
14071 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14072           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14073         enddo
14074        endif
14075       enddo
14076 !elwrite(iout,*) "after vbld write"
14077 ! Derivatives of phi:
14078 ! If phi is 0 or 180 degrees, then the formulas
14079 ! have to be derived by power series expansion of the
14080 ! conventional formulas around 0 and 180.
14081 #ifdef PARINTDER
14082       do i=iphi1_start,iphi1_end
14083 #else
14084       do i=4,nres
14085 #endif
14086 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14087 ! the conventional case
14088         sint=dsin(theta(i))
14089         sint1=dsin(theta(i-1))
14090         sing=dsin(phi(i))
14091         cost=dcos(theta(i))
14092         cost1=dcos(theta(i-1))
14093         cosg=dcos(phi(i))
14094         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14095         fac0=1.0d0/(sint1*sint)
14096         fac1=cost*fac0
14097         fac2=cost1*fac0
14098         fac3=cosg*cost1/(sint1*sint1)
14099         fac4=cosg*cost/(sint*sint)
14100 !    Obtaining the gamma derivatives from sine derivative
14101        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14102            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14103            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14104          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14105          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14106          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14107          do j=1,3
14108             ctgt=cost/sint
14109             ctgt1=cost1/sint1
14110             cosg_inv=1.0d0/cosg
14111             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14112             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14113               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14114             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14115             dsinphi(j,2,i)= &
14116               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14117               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14118             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14119             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14120               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14121 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14122             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14123             endif
14124 ! Bug fixed 3/24/05 (AL)
14125          enddo
14126 !   Obtaining the gamma derivatives from cosine derivative
14127         else
14128            do j=1,3
14129            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14130            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14131            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14132            dc_norm(j,i-3))/vbld(i-2)
14133            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14134            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14135            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14136            dcostheta(j,1,i)
14137            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14138            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14139            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14140            dc_norm(j,i-1))/vbld(i)
14141            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14142            endif
14143          enddo
14144         endif
14145       enddo
14146 !alculate derivative of Tauangle
14147 #ifdef PARINTDER
14148       do i=itau_start,itau_end
14149 #else
14150       do i=3,nres
14151 !elwrite(iout,*) " vecpr",i,nres
14152 #endif
14153        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14154 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14155 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14156 !c dtauangle(j,intertyp,dervityp,residue number)
14157 !c INTERTYP=1 SC...Ca...Ca..Ca
14158 ! the conventional case
14159         sint=dsin(theta(i))
14160         sint1=dsin(omicron(2,i-1))
14161         sing=dsin(tauangle(1,i))
14162         cost=dcos(theta(i))
14163         cost1=dcos(omicron(2,i-1))
14164         cosg=dcos(tauangle(1,i))
14165 !elwrite(iout,*) " vecpr5",i,nres
14166         do j=1,3
14167 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14168 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14169         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14170 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14171         enddo
14172         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14173         fac0=1.0d0/(sint1*sint)
14174         fac1=cost*fac0
14175         fac2=cost1*fac0
14176         fac3=cosg*cost1/(sint1*sint1)
14177         fac4=cosg*cost/(sint*sint)
14178 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14179 !    Obtaining the gamma derivatives from sine derivative
14180        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14181            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14182            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14183          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14184          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14185          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14186         do j=1,3
14187             ctgt=cost/sint
14188             ctgt1=cost1/sint1
14189             cosg_inv=1.0d0/cosg
14190             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14191        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14192        *vbld_inv(i-2+nres)
14193             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14194             dsintau(j,1,2,i)= &
14195               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14196               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14197 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14198             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14199 ! Bug fixed 3/24/05 (AL)
14200             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14201               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14202 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14203             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14204          enddo
14205 !   Obtaining the gamma derivatives from cosine derivative
14206         else
14207            do j=1,3
14208            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14209            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14210            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14211            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14212            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14213            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14214            dcostheta(j,1,i)
14215            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14216            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14217            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14218            dc_norm(j,i-1))/vbld(i)
14219            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14220 !         write (iout,*) "else",i
14221          enddo
14222         endif
14223 !        do k=1,3
14224 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14225 !        enddo
14226       enddo
14227 !C Second case Ca...Ca...Ca...SC
14228 #ifdef PARINTDER
14229       do i=itau_start,itau_end
14230 #else
14231       do i=4,nres
14232 #endif
14233        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14234           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14235 ! the conventional case
14236         sint=dsin(omicron(1,i))
14237         sint1=dsin(theta(i-1))
14238         sing=dsin(tauangle(2,i))
14239         cost=dcos(omicron(1,i))
14240         cost1=dcos(theta(i-1))
14241         cosg=dcos(tauangle(2,i))
14242 !        do j=1,3
14243 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14244 !        enddo
14245         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14246         fac0=1.0d0/(sint1*sint)
14247         fac1=cost*fac0
14248         fac2=cost1*fac0
14249         fac3=cosg*cost1/(sint1*sint1)
14250         fac4=cosg*cost/(sint*sint)
14251 !    Obtaining the gamma derivatives from sine derivative
14252        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14253            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14254            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14255          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14256          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14257          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14258         do j=1,3
14259             ctgt=cost/sint
14260             ctgt1=cost1/sint1
14261             cosg_inv=1.0d0/cosg
14262             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14263               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14264 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14265 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14266             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14267             dsintau(j,2,2,i)= &
14268               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14269               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14270 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14271 !     & sing*ctgt*domicron(j,1,2,i),
14272 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14273             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14274 ! Bug fixed 3/24/05 (AL)
14275             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14276              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14277 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14278             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14279          enddo
14280 !   Obtaining the gamma derivatives from cosine derivative
14281         else
14282            do j=1,3
14283            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14284            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14285            dc_norm(j,i-3))/vbld(i-2)
14286            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14287            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14288            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14289            dcosomicron(j,1,1,i)
14290            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14291            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14292            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14293            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14294            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14295 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14296          enddo
14297         endif
14298       enddo
14299
14300 !CC third case SC...Ca...Ca...SC
14301 #ifdef PARINTDER
14302
14303       do i=itau_start,itau_end
14304 #else
14305       do i=3,nres
14306 #endif
14307 ! the conventional case
14308       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14309       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14310         sint=dsin(omicron(1,i))
14311         sint1=dsin(omicron(2,i-1))
14312         sing=dsin(tauangle(3,i))
14313         cost=dcos(omicron(1,i))
14314         cost1=dcos(omicron(2,i-1))
14315         cosg=dcos(tauangle(3,i))
14316         do j=1,3
14317         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14318 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14319         enddo
14320         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14321         fac0=1.0d0/(sint1*sint)
14322         fac1=cost*fac0
14323         fac2=cost1*fac0
14324         fac3=cosg*cost1/(sint1*sint1)
14325         fac4=cosg*cost/(sint*sint)
14326 !    Obtaining the gamma derivatives from sine derivative
14327        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14328            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14329            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14330          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14331          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14332          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14333         do j=1,3
14334             ctgt=cost/sint
14335             ctgt1=cost1/sint1
14336             cosg_inv=1.0d0/cosg
14337             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14338               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14339               *vbld_inv(i-2+nres)
14340             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14341             dsintau(j,3,2,i)= &
14342               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14343               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14344             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14345 ! Bug fixed 3/24/05 (AL)
14346             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14347               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14348               *vbld_inv(i-1+nres)
14349 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14350             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14351          enddo
14352 !   Obtaining the gamma derivatives from cosine derivative
14353         else
14354            do j=1,3
14355            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14356            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14357            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14358            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14359            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14360            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14361            dcosomicron(j,1,1,i)
14362            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14363            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14364            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14365            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14366            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14367 !          write(iout,*) "else",i
14368          enddo
14369         endif
14370       enddo
14371
14372 #ifdef CRYST_SC
14373 !   Derivatives of side-chain angles alpha and omega
14374 #if defined(MPI) && defined(PARINTDER)
14375         do i=ibond_start,ibond_end
14376 #else
14377         do i=2,nres-1
14378 #endif
14379           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14380              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14381              fac6=fac5/vbld(i)
14382              fac7=fac5*fac5
14383              fac8=fac5/vbld(i+1)
14384              fac9=fac5/vbld(i+nres)
14385              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14386              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14387              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14388              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14389              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14390              sina=sqrt(1-cosa*cosa)
14391              sino=dsin(omeg(i))
14392 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14393              do j=1,3
14394                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14395                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14396                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14397                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14398                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14399                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14400                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14401                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14402                 vbld(i+nres))
14403                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14404             enddo
14405 ! obtaining the derivatives of omega from sines
14406             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14407                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14408                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14409                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14410                dsin(theta(i+1)))
14411                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14412                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14413                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14414                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14415                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14416                coso_inv=1.0d0/dcos(omeg(i))
14417                do j=1,3
14418                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14419                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14420                  (sino*dc_norm(j,i-1))/vbld(i)
14421                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14422                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14423                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14424                  -sino*dc_norm(j,i)/vbld(i+1)
14425                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14426                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14427                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14428                  vbld(i+nres)
14429                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14430               enddo
14431            else
14432 !   obtaining the derivatives of omega from cosines
14433              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14434              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14435              fac12=fac10*sina
14436              fac13=fac12*fac12
14437              fac14=sina*sina
14438              do j=1,3
14439                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14440                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14441                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14442                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14443                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14444                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14445                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14446                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14447                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14448                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14449                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14450                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14451                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14452                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14453                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14454             enddo
14455           endif
14456          else
14457            do j=1,3
14458              do k=1,3
14459                dalpha(k,j,i)=0.0d0
14460                domega(k,j,i)=0.0d0
14461              enddo
14462            enddo
14463          endif
14464        enddo
14465 #endif
14466 #if defined(MPI) && defined(PARINTDER)
14467       if (nfgtasks.gt.1) then
14468 #ifdef DEBUG
14469 !d      write (iout,*) "Gather dtheta"
14470 !d      call flush(iout)
14471       write (iout,*) "dtheta before gather"
14472       do i=1,nres
14473         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14474       enddo
14475 #endif
14476       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14477         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14478         king,FG_COMM,IERROR)
14479 #ifdef DEBUG
14480 !d      write (iout,*) "Gather dphi"
14481 !d      call flush(iout)
14482       write (iout,*) "dphi before gather"
14483       do i=1,nres
14484         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
14485       enddo
14486 #endif
14487       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
14488         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
14489         king,FG_COMM,IERROR)
14490 !d      write (iout,*) "Gather dalpha"
14491 !d      call flush(iout)
14492 #ifdef CRYST_SC
14493       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
14494         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14495         king,FG_COMM,IERROR)
14496 !d      write (iout,*) "Gather domega"
14497 !d      call flush(iout)
14498       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
14499         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14500         king,FG_COMM,IERROR)
14501 #endif
14502       endif
14503 #endif
14504 #ifdef DEBUG
14505       write (iout,*) "dtheta after gather"
14506       do i=1,nres
14507         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
14508       enddo
14509       write (iout,*) "dphi after gather"
14510       do i=1,nres
14511         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
14512       enddo
14513       write (iout,*) "dalpha after gather"
14514       do i=1,nres
14515         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
14516       enddo
14517       write (iout,*) "domega after gather"
14518       do i=1,nres
14519         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
14520       enddo
14521 #endif
14522       return
14523       end subroutine intcartderiv
14524 !-----------------------------------------------------------------------------
14525       subroutine checkintcartgrad
14526 !      implicit real*8 (a-h,o-z)
14527 !      include 'DIMENSIONS'
14528 #ifdef MPI
14529       include 'mpif.h'
14530 #endif
14531 !      include 'COMMON.CHAIN'
14532 !      include 'COMMON.VAR'
14533 !      include 'COMMON.GEO'
14534 !      include 'COMMON.INTERACT'
14535 !      include 'COMMON.DERIV'
14536 !      include 'COMMON.IOUNITS'
14537 !      include 'COMMON.SETUP'
14538       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
14539       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
14540       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
14541       real(kind=8),dimension(3) :: dc_norm_s
14542       real(kind=8) :: aincr=1.0d-5
14543       integer :: i,j
14544       real(kind=8) :: dcji
14545       do i=1,nres
14546         phi_s(i)=phi(i)
14547         theta_s(i)=theta(i)
14548         alph_s(i)=alph(i)
14549         omeg_s(i)=omeg(i)
14550       enddo
14551 ! Check theta gradient
14552       write (iout,*) &
14553        "Analytical (upper) and numerical (lower) gradient of theta"
14554       write (iout,*)
14555       do i=3,nres
14556         do j=1,3
14557           dcji=dc(j,i-2)
14558           dc(j,i-2)=dcji+aincr
14559           call chainbuild_cart
14560           call int_from_cart1(.false.)
14561           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
14562           dc(j,i-2)=dcji
14563           dcji=dc(j,i-1)
14564           dc(j,i-1)=dc(j,i-1)+aincr
14565           call chainbuild_cart
14566           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
14567           dc(j,i-1)=dcji
14568         enddo
14569 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
14570 !el          (dtheta(j,2,i),j=1,3)
14571 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
14572 !el          (dthetanum(j,2,i),j=1,3)
14573 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
14574 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
14575 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
14576 !el        write (iout,*)
14577       enddo
14578 ! Check gamma gradient
14579       write (iout,*) &
14580        "Analytical (upper) and numerical (lower) gradient of gamma"
14581       do i=4,nres
14582         do j=1,3
14583           dcji=dc(j,i-3)
14584           dc(j,i-3)=dcji+aincr
14585           call chainbuild_cart
14586           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
14587           dc(j,i-3)=dcji
14588           dcji=dc(j,i-2)
14589           dc(j,i-2)=dcji+aincr
14590           call chainbuild_cart
14591           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
14592           dc(j,i-2)=dcji
14593           dcji=dc(j,i-1)
14594           dc(j,i-1)=dc(j,i-1)+aincr
14595           call chainbuild_cart
14596           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
14597           dc(j,i-1)=dcji
14598         enddo
14599 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
14600 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
14601 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
14602 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
14603 !el        write (iout,'(5x,3(3f10.5,5x))') &
14604 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
14605 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
14606 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
14607 !el        write (iout,*)
14608       enddo
14609 ! Check alpha gradient
14610       write (iout,*) &
14611        "Analytical (upper) and numerical (lower) gradient of alpha"
14612       do i=2,nres-1
14613        if(itype(i).ne.10) then
14614             do j=1,3
14615               dcji=dc(j,i-1)
14616               dc(j,i-1)=dcji+aincr
14617               call chainbuild_cart
14618               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
14619               /aincr
14620               dc(j,i-1)=dcji
14621               dcji=dc(j,i)
14622               dc(j,i)=dcji+aincr
14623               call chainbuild_cart
14624               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
14625               /aincr
14626               dc(j,i)=dcji
14627               dcji=dc(j,i+nres)
14628               dc(j,i+nres)=dc(j,i+nres)+aincr
14629               call chainbuild_cart
14630               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
14631               /aincr
14632              dc(j,i+nres)=dcji
14633             enddo
14634           endif
14635 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
14636 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
14637 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
14638 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
14639 !el        write (iout,'(5x,3(3f10.5,5x))') &
14640 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
14641 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
14642 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
14643 !el        write (iout,*)
14644       enddo
14645 !     Check omega gradient
14646       write (iout,*) &
14647        "Analytical (upper) and numerical (lower) gradient of omega"
14648       do i=2,nres-1
14649        if(itype(i).ne.10) then
14650             do j=1,3
14651               dcji=dc(j,i-1)
14652               dc(j,i-1)=dcji+aincr
14653               call chainbuild_cart
14654               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
14655               /aincr
14656               dc(j,i-1)=dcji
14657               dcji=dc(j,i)
14658               dc(j,i)=dcji+aincr
14659               call chainbuild_cart
14660               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
14661               /aincr
14662               dc(j,i)=dcji
14663               dcji=dc(j,i+nres)
14664               dc(j,i+nres)=dc(j,i+nres)+aincr
14665               call chainbuild_cart
14666               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
14667               /aincr
14668              dc(j,i+nres)=dcji
14669             enddo
14670           endif
14671 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
14672 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
14673 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
14674 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
14675 !el        write (iout,'(5x,3(3f10.5,5x))') &
14676 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
14677 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
14678 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
14679 !el        write (iout,*)
14680       enddo
14681       return
14682       end subroutine checkintcartgrad
14683 !-----------------------------------------------------------------------------
14684 ! q_measure.F
14685 !-----------------------------------------------------------------------------
14686       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
14687 !      implicit real*8 (a-h,o-z)
14688 !      include 'DIMENSIONS'
14689 !      include 'COMMON.IOUNITS'
14690 !      include 'COMMON.CHAIN'
14691 !      include 'COMMON.INTERACT'
14692 !      include 'COMMON.VAR'
14693       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
14694       integer :: kkk,nsep=3
14695       real(kind=8) :: qm        !dist,
14696       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
14697       logical :: lprn=.false.
14698       logical :: flag
14699 !      real(kind=8) :: sigm,x
14700
14701 !el      sigm(x)=0.25d0*x     ! local function
14702       qqmax=1.0d10
14703       do kkk=1,nperm
14704       qq = 0.0d0
14705       nl=0
14706        if(flag) then
14707         do il=seg1+nsep,seg2
14708           do jl=seg1,il-nsep
14709             nl=nl+1
14710             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
14711                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
14712                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14713             dij=dist(il,jl)
14714             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14715             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14716               nl=nl+1
14717               d0ijCM=dsqrt( &
14718                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14719                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14720                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14721               dijCM=dist(il+nres,jl+nres)
14722               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14723             endif
14724             qq = qq+qqij+qqijCM
14725           enddo
14726         enddo
14727         qq = qq/nl
14728       else
14729       do il=seg1,seg2
14730         if((seg3-il).lt.3) then
14731              secseg=il+3
14732         else
14733              secseg=seg3
14734         endif
14735           do jl=secseg,seg4
14736             nl=nl+1
14737             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14738                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14739                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14740             dij=dist(il,jl)
14741             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14742             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14743               nl=nl+1
14744               d0ijCM=dsqrt( &
14745                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14746                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14747                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14748               dijCM=dist(il+nres,jl+nres)
14749               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14750             endif
14751             qq = qq+qqij+qqijCM
14752           enddo
14753         enddo
14754       qq = qq/nl
14755       endif
14756       if (qqmax.le.qq) qqmax=qq
14757       enddo
14758       qwolynes=1.0d0-qqmax
14759       return
14760       end function qwolynes
14761 !-----------------------------------------------------------------------------
14762       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
14763 !      implicit real*8 (a-h,o-z)
14764 !      include 'DIMENSIONS'
14765 !      include 'COMMON.IOUNITS'
14766 !      include 'COMMON.CHAIN'
14767 !      include 'COMMON.INTERACT'
14768 !      include 'COMMON.VAR'
14769 !      include 'COMMON.MD'
14770       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
14771       integer :: nsep=3, kkk
14772 !el      real(kind=8) :: dist
14773       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
14774       logical :: lprn=.false.
14775       logical :: flag
14776       real(kind=8) :: sim,dd0,fac,ddqij
14777 !el      sigm(x)=0.25d0*x            ! local function
14778       do kkk=1,nperm
14779       do i=0,nres
14780         do j=1,3
14781           dqwol(j,i)=0.0d0
14782           dxqwol(j,i)=0.0d0
14783         enddo
14784       enddo
14785       nl=0
14786        if(flag) then
14787         do il=seg1+nsep,seg2
14788           do jl=seg1,il-nsep
14789             nl=nl+1
14790             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14791                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14792                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14793             dij=dist(il,jl)
14794             sim = 1.0d0/sigm(d0ij)
14795             sim = sim*sim
14796             dd0 = dij-d0ij
14797             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14798             do k=1,3
14799               ddqij = (c(k,il)-c(k,jl))*fac
14800               dqwol(k,il)=dqwol(k,il)+ddqij
14801               dqwol(k,jl)=dqwol(k,jl)-ddqij
14802             enddo
14803
14804             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14805               nl=nl+1
14806               d0ijCM=dsqrt( &
14807                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14808                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14809                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14810               dijCM=dist(il+nres,jl+nres)
14811               sim = 1.0d0/sigm(d0ijCM)
14812               sim = sim*sim
14813               dd0=dijCM-d0ijCM
14814               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14815               do k=1,3
14816                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14817                 dxqwol(k,il)=dxqwol(k,il)+ddqij
14818                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14819               enddo
14820             endif
14821           enddo
14822         enddo
14823        else
14824         do il=seg1,seg2
14825         if((seg3-il).lt.3) then
14826              secseg=il+3
14827         else
14828              secseg=seg3
14829         endif
14830           do jl=secseg,seg4
14831             nl=nl+1
14832             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14833                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14834                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14835             dij=dist(il,jl)
14836             sim = 1.0d0/sigm(d0ij)
14837             sim = sim*sim
14838             dd0 = dij-d0ij
14839             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14840             do k=1,3
14841               ddqij = (c(k,il)-c(k,jl))*fac
14842               dqwol(k,il)=dqwol(k,il)+ddqij
14843               dqwol(k,jl)=dqwol(k,jl)-ddqij
14844             enddo
14845             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14846               nl=nl+1
14847               d0ijCM=dsqrt( &
14848                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14849                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14850                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14851               dijCM=dist(il+nres,jl+nres)
14852               sim = 1.0d0/sigm(d0ijCM)
14853               sim=sim*sim
14854               dd0 = dijCM-d0ijCM
14855               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14856               do k=1,3
14857                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14858                dxqwol(k,il)=dxqwol(k,il)+ddqij
14859                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14860               enddo
14861             endif
14862           enddo
14863         enddo
14864       endif
14865       enddo
14866        do i=0,nres
14867          do j=1,3
14868            dqwol(j,i)=dqwol(j,i)/nl
14869            dxqwol(j,i)=dxqwol(j,i)/nl
14870          enddo
14871        enddo
14872       return
14873       end subroutine qwolynes_prim
14874 !-----------------------------------------------------------------------------
14875       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
14876 !      implicit real*8 (a-h,o-z)
14877 !      include 'DIMENSIONS'
14878 !      include 'COMMON.IOUNITS'
14879 !      include 'COMMON.CHAIN'
14880 !      include 'COMMON.INTERACT'
14881 !      include 'COMMON.VAR'
14882       integer :: seg1,seg2,seg3,seg4
14883       logical :: flag
14884       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
14885       real(kind=8),dimension(3,0:2*nres) :: cdummy
14886       real(kind=8) :: q1,q2
14887       real(kind=8) :: delta=1.0d-10
14888       integer :: i,j
14889
14890       do i=0,nres
14891         do j=1,3
14892           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14893           cdummy(j,i)=c(j,i)
14894           c(j,i)=c(j,i)+delta
14895           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14896           qwolan(j,i)=(q2-q1)/delta
14897           c(j,i)=cdummy(j,i)
14898         enddo
14899       enddo
14900       do i=0,nres
14901         do j=1,3
14902           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14903           cdummy(j,i+nres)=c(j,i+nres)
14904           c(j,i+nres)=c(j,i+nres)+delta
14905           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14906           qwolxan(j,i)=(q2-q1)/delta
14907           c(j,i+nres)=cdummy(j,i+nres)
14908         enddo
14909       enddo
14910 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
14911 !      do i=0,nct
14912 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
14913 !      enddo
14914 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
14915 !      do i=0,nct
14916 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
14917 !      enddo
14918       return
14919       end subroutine qwol_num
14920 !-----------------------------------------------------------------------------
14921       subroutine EconstrQ
14922 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14923 !      implicit real*8 (a-h,o-z)
14924 !      include 'DIMENSIONS'
14925 !      include 'COMMON.CONTROL'
14926 !      include 'COMMON.VAR'
14927 !      include 'COMMON.MD'
14928       use MD_data
14929 !#ifndef LANG0
14930 !      include 'COMMON.LANGEVIN'
14931 !#else
14932 !      include 'COMMON.LANGEVIN.lang0'
14933 !#endif
14934 !      include 'COMMON.CHAIN'
14935 !      include 'COMMON.DERIV'
14936 !      include 'COMMON.GEO'
14937 !      include 'COMMON.LOCAL'
14938 !      include 'COMMON.INTERACT'
14939 !      include 'COMMON.IOUNITS'
14940 !      include 'COMMON.NAMES'
14941 !      include 'COMMON.TIME1'
14942       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
14943       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
14944                    duconst,duxconst
14945       integer :: kstart,kend,lstart,lend,idummy
14946       real(kind=8) :: delta=1.0d-7
14947       integer :: i,j,k,ii
14948       do i=0,nres
14949          do j=1,3
14950             duconst(j,i)=0.0d0
14951             dudconst(j,i)=0.0d0
14952             duxconst(j,i)=0.0d0
14953             dudxconst(j,i)=0.0d0
14954          enddo
14955       enddo
14956       Uconst=0.0d0
14957       do i=1,nfrag
14958          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14959            idummy,idummy)
14960          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
14961 ! Calculating the derivatives of Constraint energy with respect to Q
14962          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
14963            qinfrag(i,iset))
14964 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
14965 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
14966 !         hmnum=(hm2-hm1)/delta
14967 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
14968 !     &   qinfrag(i,iset))
14969 !         write(iout,*) "harmonicnum frag", hmnum
14970 ! Calculating the derivatives of Q with respect to cartesian coordinates
14971          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14972           idummy,idummy)
14973 !         write(iout,*) "dqwol "
14974 !         do ii=1,nres
14975 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
14976 !         enddo
14977 !         write(iout,*) "dxqwol "
14978 !         do ii=1,nres
14979 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
14980 !         enddo
14981 ! Calculating numerical gradients of dU/dQi and dQi/dxi
14982 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
14983 !     &  ,idummy,idummy)
14984 !  The gradients of Uconst in Cs
14985          do ii=0,nres
14986             do j=1,3
14987                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
14988                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
14989             enddo
14990          enddo
14991       enddo
14992       do i=1,npair
14993          kstart=ifrag(1,ipair(1,i,iset),iset)
14994          kend=ifrag(2,ipair(1,i,iset),iset)
14995          lstart=ifrag(1,ipair(2,i,iset),iset)
14996          lend=ifrag(2,ipair(2,i,iset),iset)
14997          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
14998          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
14999 !  Calculating dU/dQ
15000          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15001 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15002 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15003 !         hmnum=(hm2-hm1)/delta
15004 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15005 !     &   qinpair(i,iset))
15006 !         write(iout,*) "harmonicnum pair ", hmnum
15007 ! Calculating dQ/dXi
15008          call qwolynes_prim(kstart,kend,.false.,&
15009           lstart,lend)
15010 !         write(iout,*) "dqwol "
15011 !         do ii=1,nres
15012 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15013 !         enddo
15014 !         write(iout,*) "dxqwol "
15015 !         do ii=1,nres
15016 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15017 !        enddo
15018 ! Calculating numerical gradients
15019 !        call qwol_num(kstart,kend,.false.
15020 !     &  ,lstart,lend)
15021 ! The gradients of Uconst in Cs
15022          do ii=0,nres
15023             do j=1,3
15024                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15025                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15026             enddo
15027          enddo
15028       enddo
15029 !      write(iout,*) "Uconst inside subroutine ", Uconst
15030 ! Transforming the gradients from Cs to dCs for the backbone
15031       do i=0,nres
15032          do j=i+1,nres
15033            do k=1,3
15034              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15035            enddo
15036          enddo
15037       enddo
15038 !  Transforming the gradients from Cs to dCs for the side chains
15039       do i=1,nres
15040          do j=1,3
15041            dudxconst(j,i)=duxconst(j,i)
15042          enddo
15043       enddo
15044 !      write(iout,*) "dU/ddc backbone "
15045 !       do ii=0,nres
15046 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15047 !      enddo
15048 !      write(iout,*) "dU/ddX side chain "
15049 !      do ii=1,nres
15050 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15051 !      enddo
15052 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15053 !      call dEconstrQ_num
15054       return
15055       end subroutine EconstrQ
15056 !-----------------------------------------------------------------------------
15057       subroutine dEconstrQ_num
15058 ! Calculating numerical dUconst/ddc and dUconst/ddx
15059 !      implicit real*8 (a-h,o-z)
15060 !      include 'DIMENSIONS'
15061 !      include 'COMMON.CONTROL'
15062 !      include 'COMMON.VAR'
15063 !      include 'COMMON.MD'
15064       use MD_data
15065 !#ifndef LANG0
15066 !      include 'COMMON.LANGEVIN'
15067 !#else
15068 !      include 'COMMON.LANGEVIN.lang0'
15069 !#endif
15070 !      include 'COMMON.CHAIN'
15071 !      include 'COMMON.DERIV'
15072 !      include 'COMMON.GEO'
15073 !      include 'COMMON.LOCAL'
15074 !      include 'COMMON.INTERACT'
15075 !      include 'COMMON.IOUNITS'
15076 !      include 'COMMON.NAMES'
15077 !      include 'COMMON.TIME1'
15078       real(kind=8) :: uzap1,uzap2
15079       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15080       integer :: kstart,kend,lstart,lend,idummy
15081       real(kind=8) :: delta=1.0d-7
15082 !el local variables
15083       integer :: i,ii,j
15084 !     real(kind=8) ::
15085 !     For the backbone
15086       do i=0,nres-1
15087          do j=1,3
15088             dUcartan(j,i)=0.0d0
15089             cdummy(j,i)=dc(j,i)
15090             dc(j,i)=dc(j,i)+delta
15091             call chainbuild_cart
15092             uzap2=0.0d0
15093             do ii=1,nfrag
15094              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15095                 idummy,idummy)
15096                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15097                 qinfrag(ii,iset))
15098             enddo
15099             do ii=1,npair
15100                kstart=ifrag(1,ipair(1,ii,iset),iset)
15101                kend=ifrag(2,ipair(1,ii,iset),iset)
15102                lstart=ifrag(1,ipair(2,ii,iset),iset)
15103                lend=ifrag(2,ipair(2,ii,iset),iset)
15104                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15105                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15106                  qinpair(ii,iset))
15107             enddo
15108             dc(j,i)=cdummy(j,i)
15109             call chainbuild_cart
15110             uzap1=0.0d0
15111              do ii=1,nfrag
15112              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15113                 idummy,idummy)
15114                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15115                 qinfrag(ii,iset))
15116             enddo
15117             do ii=1,npair
15118                kstart=ifrag(1,ipair(1,ii,iset),iset)
15119                kend=ifrag(2,ipair(1,ii,iset),iset)
15120                lstart=ifrag(1,ipair(2,ii,iset),iset)
15121                lend=ifrag(2,ipair(2,ii,iset),iset)
15122                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15123                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15124                 qinpair(ii,iset))
15125             enddo
15126             ducartan(j,i)=(uzap2-uzap1)/(delta)
15127          enddo
15128       enddo
15129 ! Calculating numerical gradients for dU/ddx
15130       do i=0,nres-1
15131          duxcartan(j,i)=0.0d0
15132          do j=1,3
15133             cdummy(j,i)=dc(j,i+nres)
15134             dc(j,i+nres)=dc(j,i+nres)+delta
15135             call chainbuild_cart
15136             uzap2=0.0d0
15137             do ii=1,nfrag
15138              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15139                 idummy,idummy)
15140                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15141                 qinfrag(ii,iset))
15142             enddo
15143             do ii=1,npair
15144                kstart=ifrag(1,ipair(1,ii,iset),iset)
15145                kend=ifrag(2,ipair(1,ii,iset),iset)
15146                lstart=ifrag(1,ipair(2,ii,iset),iset)
15147                lend=ifrag(2,ipair(2,ii,iset),iset)
15148                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15149                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15150                 qinpair(ii,iset))
15151             enddo
15152             dc(j,i+nres)=cdummy(j,i)
15153             call chainbuild_cart
15154             uzap1=0.0d0
15155              do ii=1,nfrag
15156                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15157                 ifrag(2,ii,iset),.true.,idummy,idummy)
15158                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15159                 qinfrag(ii,iset))
15160             enddo
15161             do ii=1,npair
15162                kstart=ifrag(1,ipair(1,ii,iset),iset)
15163                kend=ifrag(2,ipair(1,ii,iset),iset)
15164                lstart=ifrag(1,ipair(2,ii,iset),iset)
15165                lend=ifrag(2,ipair(2,ii,iset),iset)
15166                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15167                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15168                 qinpair(ii,iset))
15169             enddo
15170             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15171          enddo
15172       enddo
15173       write(iout,*) "Numerical dUconst/ddc backbone "
15174       do ii=0,nres
15175         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15176       enddo
15177 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15178 !      do ii=1,nres
15179 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15180 !      enddo
15181       return
15182       end subroutine dEconstrQ_num
15183 !-----------------------------------------------------------------------------
15184 ! ssMD.F
15185 !-----------------------------------------------------------------------------
15186       subroutine check_energies
15187
15188 !      use random, only: ran_number
15189
15190 !      implicit none
15191 !     Includes
15192 !      include 'DIMENSIONS'
15193 !      include 'COMMON.CHAIN'
15194 !      include 'COMMON.VAR'
15195 !      include 'COMMON.IOUNITS'
15196 !      include 'COMMON.SBRIDGE'
15197 !      include 'COMMON.LOCAL'
15198 !      include 'COMMON.GEO'
15199
15200 !     External functions
15201 !EL      double precision ran_number
15202 !EL      external ran_number
15203
15204 !     Local variables
15205       integer :: i,j,k,l,lmax,p,pmax
15206       real(kind=8) :: rmin,rmax
15207       real(kind=8) :: eij
15208
15209       real(kind=8) :: d
15210       real(kind=8) :: wi,rij,tj,pj
15211 !      return
15212
15213       i=5
15214       j=14
15215
15216       d=dsc(1)
15217       rmin=2.0D0
15218       rmax=12.0D0
15219
15220       lmax=10000
15221       pmax=1
15222
15223       do k=1,3
15224         c(k,i)=0.0D0
15225         c(k,j)=0.0D0
15226         c(k,nres+i)=0.0D0
15227         c(k,nres+j)=0.0D0
15228       enddo
15229
15230       do l=1,lmax
15231
15232 !t        wi=ran_number(0.0D0,pi)
15233 !        wi=ran_number(0.0D0,pi/6.0D0)
15234 !        wi=0.0D0
15235 !t        tj=ran_number(0.0D0,pi)
15236 !t        pj=ran_number(0.0D0,pi)
15237 !        pj=ran_number(0.0D0,pi/6.0D0)
15238 !        pj=0.0D0
15239
15240         do p=1,pmax
15241 !t           rij=ran_number(rmin,rmax)
15242
15243            c(1,j)=d*sin(pj)*cos(tj)
15244            c(2,j)=d*sin(pj)*sin(tj)
15245            c(3,j)=d*cos(pj)
15246
15247            c(3,nres+i)=-rij
15248
15249            c(1,i)=d*sin(wi)
15250            c(3,i)=-rij-d*cos(wi)
15251
15252            do k=1,3
15253               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15254               dc_norm(k,nres+i)=dc(k,nres+i)/d
15255               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15256               dc_norm(k,nres+j)=dc(k,nres+j)/d
15257            enddo
15258
15259            call dyn_ssbond_ene(i,j,eij)
15260         enddo
15261       enddo
15262       call exit(1)
15263       return
15264       end subroutine check_energies
15265 !-----------------------------------------------------------------------------
15266       subroutine dyn_ssbond_ene(resi,resj,eij)
15267 !      implicit none
15268 !      Includes
15269       use calc_data
15270       use comm_sschecks
15271 !      include 'DIMENSIONS'
15272 !      include 'COMMON.SBRIDGE'
15273 !      include 'COMMON.CHAIN'
15274 !      include 'COMMON.DERIV'
15275 !      include 'COMMON.LOCAL'
15276 !      include 'COMMON.INTERACT'
15277 !      include 'COMMON.VAR'
15278 !      include 'COMMON.IOUNITS'
15279 !      include 'COMMON.CALC'
15280 #ifndef CLUST
15281 #ifndef WHAM
15282        use MD_data
15283 !      include 'COMMON.MD'
15284 !      use MD, only: totT,t_bath
15285 #endif
15286 #endif
15287 !     External functions
15288 !EL      double precision h_base
15289 !EL      external h_base
15290
15291 !     Input arguments
15292       integer :: resi,resj
15293
15294 !     Output arguments
15295       real(kind=8) :: eij
15296
15297 !     Local variables
15298       logical :: havebond
15299       integer itypi,itypj
15300       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15301       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15302       real(kind=8),dimension(3) :: dcosom1,dcosom2
15303       real(kind=8) :: ed
15304       real(kind=8) :: pom1,pom2
15305       real(kind=8) :: ljA,ljB,ljXs
15306       real(kind=8),dimension(1:3) :: d_ljB
15307       real(kind=8) :: ssA,ssB,ssC,ssXs
15308       real(kind=8) :: ssxm,ljxm,ssm,ljm
15309       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15310       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15311       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15312 !-------FIRST METHOD
15313       real(kind=8) :: xm
15314       real(kind=8),dimension(1:3) :: d_xm
15315 !-------END FIRST METHOD
15316 !-------SECOND METHOD
15317 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15318 !-------END SECOND METHOD
15319
15320 !-------TESTING CODE
15321 !el      logical :: checkstop,transgrad
15322 !el      common /sschecks/ checkstop,transgrad
15323
15324       integer :: icheck,nicheck,jcheck,njcheck
15325       real(kind=8),dimension(-1:1) :: echeck
15326       real(kind=8) :: deps,ssx0,ljx0
15327 !-------END TESTING CODE
15328
15329       eij=0.0d0
15330       i=resi
15331       j=resj
15332
15333 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15334 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15335
15336       itypi=itype(i)
15337       dxi=dc_norm(1,nres+i)
15338       dyi=dc_norm(2,nres+i)
15339       dzi=dc_norm(3,nres+i)
15340       dsci_inv=vbld_inv(i+nres)
15341
15342       itypj=itype(j)
15343       xj=c(1,nres+j)-c(1,nres+i)
15344       yj=c(2,nres+j)-c(2,nres+i)
15345       zj=c(3,nres+j)-c(3,nres+i)
15346       dxj=dc_norm(1,nres+j)
15347       dyj=dc_norm(2,nres+j)
15348       dzj=dc_norm(3,nres+j)
15349       dscj_inv=vbld_inv(j+nres)
15350
15351       chi1=chi(itypi,itypj)
15352       chi2=chi(itypj,itypi)
15353       chi12=chi1*chi2
15354       chip1=chip(itypi)
15355       chip2=chip(itypj)
15356       chip12=chip1*chip2
15357       alf1=alp(itypi)
15358       alf2=alp(itypj)
15359       alf12=0.5D0*(alf1+alf2)
15360
15361       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15362       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15363 !     The following are set in sc_angular
15364 !      erij(1)=xj*rij
15365 !      erij(2)=yj*rij
15366 !      erij(3)=zj*rij
15367 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15368 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15369 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15370       call sc_angular
15371       rij=1.0D0/rij  ! Reset this so it makes sense
15372
15373       sig0ij=sigma(itypi,itypj)
15374       sig=sig0ij*dsqrt(1.0D0/sigsq)
15375
15376       ljXs=sig-sig0ij
15377       ljA=eps1*eps2rt**2*eps3rt**2
15378       ljB=ljA*bb(itypi,itypj)
15379       ljA=ljA*aa(itypi,itypj)
15380       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15381
15382       ssXs=d0cm
15383       deltat1=1.0d0-om1
15384       deltat2=1.0d0+om2
15385       deltat12=om2-om1+2.0d0
15386       cosphi=om12-om1*om2
15387       ssA=akcm
15388       ssB=akct*deltat12
15389       ssC=ss_depth &
15390            +akth*(deltat1*deltat1+deltat2*deltat2) &
15391            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15392       ssxm=ssXs-0.5D0*ssB/ssA
15393
15394 !-------TESTING CODE
15395 !$$$c     Some extra output
15396 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15397 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15398 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15399 !$$$      if (ssx0.gt.0.0d0) then
15400 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15401 !$$$      else
15402 !$$$        ssx0=ssxm
15403 !$$$      endif
15404 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15405 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15406 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15407 !$$$      return
15408 !-------END TESTING CODE
15409
15410 !-------TESTING CODE
15411 !     Stop and plot energy and derivative as a function of distance
15412       if (checkstop) then
15413         ssm=ssC-0.25D0*ssB*ssB/ssA
15414         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15415         if (ssm.lt.ljm .and. &
15416              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15417           nicheck=1000
15418           njcheck=1
15419           deps=0.5d-7
15420         else
15421           checkstop=.false.
15422         endif
15423       endif
15424       if (.not.checkstop) then
15425         nicheck=0
15426         njcheck=-1
15427       endif
15428
15429       do icheck=0,nicheck
15430       do jcheck=-1,njcheck
15431       if (checkstop) rij=(ssxm-1.0d0)+ &
15432              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15433 !-------END TESTING CODE
15434
15435       if (rij.gt.ljxm) then
15436         havebond=.false.
15437         ljd=rij-ljXs
15438         fac=(1.0D0/ljd)**expon
15439         e1=fac*fac*aa(itypi,itypj)
15440         e2=fac*bb(itypi,itypj)
15441         eij=eps1*eps2rt*eps3rt*(e1+e2)
15442         eps2der=eij*eps3rt
15443         eps3der=eij*eps2rt
15444         eij=eij*eps2rt*eps3rt
15445
15446         sigder=-sig/sigsq
15447         e1=e1*eps1*eps2rt**2*eps3rt**2
15448         ed=-expon*(e1+eij)/ljd
15449         sigder=ed*sigder
15450         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15451         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15452         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15453              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15454       else if (rij.lt.ssxm) then
15455         havebond=.true.
15456         ssd=rij-ssXs
15457         eij=ssA*ssd*ssd+ssB*ssd+ssC
15458
15459         ed=2*akcm*ssd+akct*deltat12
15460         pom1=akct*ssd
15461         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15462         eom1=-2*akth*deltat1-pom1-om2*pom2
15463         eom2= 2*akth*deltat2+pom1-om1*pom2
15464         eom12=pom2
15465       else
15466         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15467
15468         d_ssxm(1)=0.5D0*akct/ssA
15469         d_ssxm(2)=-d_ssxm(1)
15470         d_ssxm(3)=0.0D0
15471
15472         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15473         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15474         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15475         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15476
15477 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15478         xm=0.5d0*(ssxm+ljxm)
15479         do k=1,3
15480           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15481         enddo
15482         if (rij.lt.xm) then
15483           havebond=.true.
15484           ssm=ssC-0.25D0*ssB*ssB/ssA
15485           d_ssm(1)=0.5D0*akct*ssB/ssA
15486           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15487           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15488           d_ssm(3)=omega
15489           f1=(rij-xm)/(ssxm-xm)
15490           f2=(rij-ssxm)/(xm-ssxm)
15491           h1=h_base(f1,hd1)
15492           h2=h_base(f2,hd2)
15493           eij=ssm*h1+Ht*h2
15494           delta_inv=1.0d0/(xm-ssxm)
15495           deltasq_inv=delta_inv*delta_inv
15496           fac=ssm*hd1-Ht*hd2
15497           fac1=deltasq_inv*fac*(xm-rij)
15498           fac2=deltasq_inv*fac*(rij-ssxm)
15499           ed=delta_inv*(Ht*hd2-ssm*hd1)
15500           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
15501           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
15502           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
15503         else
15504           havebond=.false.
15505           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15506           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
15507           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
15508           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
15509                alf12/eps3rt)
15510           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
15511           f1=(rij-ljxm)/(xm-ljxm)
15512           f2=(rij-xm)/(ljxm-xm)
15513           h1=h_base(f1,hd1)
15514           h2=h_base(f2,hd2)
15515           eij=Ht*h1+ljm*h2
15516           delta_inv=1.0d0/(ljxm-xm)
15517           deltasq_inv=delta_inv*delta_inv
15518           fac=Ht*hd1-ljm*hd2
15519           fac1=deltasq_inv*fac*(ljxm-rij)
15520           fac2=deltasq_inv*fac*(rij-xm)
15521           ed=delta_inv*(ljm*hd2-Ht*hd1)
15522           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
15523           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
15524           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
15525         endif
15526 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15527
15528 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15529 !$$$        ssd=rij-ssXs
15530 !$$$        ljd=rij-ljXs
15531 !$$$        fac1=rij-ljxm
15532 !$$$        fac2=rij-ssxm
15533 !$$$
15534 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
15535 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
15536 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
15537 !$$$
15538 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
15539 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
15540 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15541 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15542 !$$$        d_ssm(3)=omega
15543 !$$$
15544 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
15545 !$$$        do k=1,3
15546 !$$$          d_ljm(k)=ljm*d_ljB(k)
15547 !$$$        enddo
15548 !$$$        ljm=ljm*ljB
15549 !$$$
15550 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
15551 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
15552 !$$$        d_ss(2)=akct*ssd
15553 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
15554 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
15555 !$$$        d_ss(3)=omega
15556 !$$$
15557 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
15558 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
15559 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
15560 !$$$        do k=1,3
15561 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
15562 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
15563 !$$$        enddo
15564 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
15565 !$$$
15566 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
15567 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
15568 !$$$        h1=h_base(f1,hd1)
15569 !$$$        h2=h_base(f2,hd2)
15570 !$$$        eij=ss*h1+ljf*h2
15571 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
15572 !$$$        deltasq_inv=delta_inv*delta_inv
15573 !$$$        fac=ljf*hd2-ss*hd1
15574 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
15575 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
15576 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
15577 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
15578 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
15579 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
15580 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
15581 !$$$
15582 !$$$        havebond=.false.
15583 !$$$        if (ed.gt.0.0d0) havebond=.true.
15584 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15585
15586       endif
15587
15588       if (havebond) then
15589 !#ifndef CLUST
15590 !#ifndef WHAM
15591 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
15592 !          write(iout,'(a15,f12.2,f8.1,2i5)')
15593 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
15594 !        endif
15595 !#endif
15596 !#endif
15597         dyn_ssbond_ij(i,j)=eij
15598       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
15599         dyn_ssbond_ij(i,j)=1.0d300
15600 !#ifndef CLUST
15601 !#ifndef WHAM
15602 !        write(iout,'(a15,f12.2,f8.1,2i5)')
15603 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
15604 !#endif
15605 !#endif
15606       endif
15607
15608 !-------TESTING CODE
15609 !el      if (checkstop) then
15610         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
15611              "CHECKSTOP",rij,eij,ed
15612         echeck(jcheck)=eij
15613 !el      endif
15614       enddo
15615       if (checkstop) then
15616         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
15617       endif
15618       enddo
15619       if (checkstop) then
15620         transgrad=.true.
15621         checkstop=.false.
15622       endif
15623 !-------END TESTING CODE
15624
15625       do k=1,3
15626         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
15627         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
15628       enddo
15629       do k=1,3
15630         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
15631       enddo
15632       do k=1,3
15633         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15634              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15635              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15636         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15637              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15638              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15639       enddo
15640 !grad      do k=i,j-1
15641 !grad        do l=1,3
15642 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
15643 !grad        enddo
15644 !grad      enddo
15645
15646       do l=1,3
15647         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15648         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15649       enddo
15650
15651       return
15652       end subroutine dyn_ssbond_ene
15653 !-----------------------------------------------------------------------------
15654       real(kind=8) function h_base(x,deriv)
15655 !     A smooth function going 0->1 in range [0,1]
15656 !     It should NOT be called outside range [0,1], it will not work there.
15657       implicit none
15658
15659 !     Input arguments
15660       real(kind=8) :: x
15661
15662 !     Output arguments
15663       real(kind=8) :: deriv
15664
15665 !     Local variables
15666       real(kind=8) :: xsq
15667
15668
15669 !     Two parabolas put together.  First derivative zero at extrema
15670 !$$$      if (x.lt.0.5D0) then
15671 !$$$        h_base=2.0D0*x*x
15672 !$$$        deriv=4.0D0*x
15673 !$$$      else
15674 !$$$        deriv=1.0D0-x
15675 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
15676 !$$$        deriv=4.0D0*deriv
15677 !$$$      endif
15678
15679 !     Third degree polynomial.  First derivative zero at extrema
15680       h_base=x*x*(3.0d0-2.0d0*x)
15681       deriv=6.0d0*x*(1.0d0-x)
15682
15683 !     Fifth degree polynomial.  First and second derivatives zero at extrema
15684 !$$$      xsq=x*x
15685 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
15686 !$$$      deriv=x-1.0d0
15687 !$$$      deriv=deriv*deriv
15688 !$$$      deriv=30.0d0*xsq*deriv
15689
15690       return
15691       end function h_base
15692 !-----------------------------------------------------------------------------
15693       subroutine dyn_set_nss
15694 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
15695 !      implicit none
15696       use MD_data, only: totT,t_bath
15697 !     Includes
15698 !      include 'DIMENSIONS'
15699 #ifdef MPI
15700       include "mpif.h"
15701 #endif
15702 !      include 'COMMON.SBRIDGE'
15703 !      include 'COMMON.CHAIN'
15704 !      include 'COMMON.IOUNITS'
15705 !      include 'COMMON.SETUP'
15706 !      include 'COMMON.MD'
15707 !     Local variables
15708       real(kind=8) :: emin
15709       integer :: i,j,imin,ierr
15710       integer :: diff,allnss,newnss
15711       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15712                 newihpb,newjhpb
15713       logical :: found
15714       integer,dimension(0:nfgtasks) :: i_newnss
15715       integer,dimension(0:nfgtasks) :: displ
15716       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15717       integer :: g_newnss
15718
15719       allnss=0
15720       do i=1,nres-1
15721         do j=i+1,nres
15722           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
15723             allnss=allnss+1
15724             allflag(allnss)=0
15725             allihpb(allnss)=i
15726             alljhpb(allnss)=j
15727           endif
15728         enddo
15729       enddo
15730
15731 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15732
15733  1    emin=1.0d300
15734       do i=1,allnss
15735         if (allflag(i).eq.0 .and. &
15736              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
15737           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
15738           imin=i
15739         endif
15740       enddo
15741       if (emin.lt.1.0d300) then
15742         allflag(imin)=1
15743         do i=1,allnss
15744           if (allflag(i).eq.0 .and. &
15745                (allihpb(i).eq.allihpb(imin) .or. &
15746                alljhpb(i).eq.allihpb(imin) .or. &
15747                allihpb(i).eq.alljhpb(imin) .or. &
15748                alljhpb(i).eq.alljhpb(imin))) then
15749             allflag(i)=-1
15750           endif
15751         enddo
15752         goto 1
15753       endif
15754
15755 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15756
15757       newnss=0
15758       do i=1,allnss
15759         if (allflag(i).eq.1) then
15760           newnss=newnss+1
15761           newihpb(newnss)=allihpb(i)
15762           newjhpb(newnss)=alljhpb(i)
15763         endif
15764       enddo
15765
15766 #ifdef MPI
15767       if (nfgtasks.gt.1)then
15768
15769         call MPI_Reduce(newnss,g_newnss,1,&
15770           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
15771         call MPI_Gather(newnss,1,MPI_INTEGER,&
15772                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
15773         displ(0)=0
15774         do i=1,nfgtasks-1,1
15775           displ(i)=i_newnss(i-1)+displ(i-1)
15776         enddo
15777         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
15778                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
15779                          king,FG_COMM,IERR)
15780         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
15781                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
15782                          king,FG_COMM,IERR)
15783         if(fg_rank.eq.0) then
15784 !         print *,'g_newnss',g_newnss
15785 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
15786 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
15787          newnss=g_newnss
15788          do i=1,newnss
15789           newihpb(i)=g_newihpb(i)
15790           newjhpb(i)=g_newjhpb(i)
15791          enddo
15792         endif
15793       endif
15794 #endif
15795
15796       diff=newnss-nss
15797
15798 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
15799
15800       do i=1,nss
15801         found=.false.
15802         do j=1,newnss
15803           if (idssb(i).eq.newihpb(j) .and. &
15804                jdssb(i).eq.newjhpb(j)) found=.true.
15805         enddo
15806 #ifndef CLUST
15807 #ifndef WHAM
15808         if (.not.found.and.fg_rank.eq.0) &
15809             write(iout,'(a15,f12.2,f8.1,2i5)') &
15810              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
15811 #endif
15812 #endif
15813       enddo
15814
15815       do i=1,newnss
15816         found=.false.
15817         do j=1,nss
15818           if (newihpb(i).eq.idssb(j) .and. &
15819                newjhpb(i).eq.jdssb(j)) found=.true.
15820         enddo
15821 #ifndef CLUST
15822 #ifndef WHAM
15823         if (.not.found.and.fg_rank.eq.0) &
15824             write(iout,'(a15,f12.2,f8.1,2i5)') &
15825              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
15826 #endif
15827 #endif
15828       enddo
15829
15830       nss=newnss
15831       do i=1,nss
15832         idssb(i)=newihpb(i)
15833         jdssb(i)=newjhpb(i)
15834       enddo
15835
15836       return
15837       end subroutine dyn_set_nss
15838 !-----------------------------------------------------------------------------
15839 #ifdef WHAM
15840       subroutine read_ssHist
15841 !      implicit none
15842 !      Includes
15843 !      include 'DIMENSIONS'
15844 !      include "DIMENSIONS.FREE"
15845 !      include 'COMMON.FREE'
15846 !     Local variables
15847       integer :: i,j
15848       character(len=80) :: controlcard
15849
15850       do i=1,dyn_nssHist
15851         call card_concat(controlcard,.true.)
15852         read(controlcard,*) &
15853              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
15854       enddo
15855
15856       return
15857       end subroutine read_ssHist
15858 #endif
15859 !-----------------------------------------------------------------------------
15860       integer function indmat(i,j)
15861 !el
15862 ! get the position of the jth ijth fragment of the chain coordinate system
15863 ! in the fromto array.
15864         integer :: i,j
15865
15866         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
15867       return
15868       end function indmat
15869 !-----------------------------------------------------------------------------
15870       real(kind=8) function sigm(x)
15871 !el
15872        real(kind=8) :: x
15873         sigm=0.25d0*x
15874       return
15875       end function sigm
15876 !-----------------------------------------------------------------------------
15877 !-----------------------------------------------------------------------------
15878       subroutine alloc_ener_arrays
15879 !EL Allocation of arrays used by module energy
15880
15881 !el local variables
15882       integer :: i,j
15883
15884       if(nres.lt.100) then
15885         maxconts=nres
15886       elseif(nres.lt.200) then
15887         maxconts=0.8*nres       ! Max. number of contacts per residue
15888       else
15889         maxconts=0.6*nres ! (maxconts=maxres/4)
15890       endif
15891       maxcont=12*nres   ! Max. number of SC contacts
15892       maxvar=6*nres     ! Max. number of variables
15893 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15894       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15895 !----------------------
15896 ! arrays in subroutine init_int_table
15897 !el#ifdef MPI
15898 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
15899 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
15900 !el#endif
15901       allocate(nint_gr(nres))
15902       allocate(nscp_gr(nres))
15903       allocate(ielstart(nres))
15904       allocate(ielend(nres))
15905 !(maxres)
15906       allocate(istart(nres,maxint_gr))
15907       allocate(iend(nres,maxint_gr))
15908 !(maxres,maxint_gr)
15909       allocate(iscpstart(nres,maxint_gr))
15910       allocate(iscpend(nres,maxint_gr))
15911 !(maxres,maxint_gr)
15912       allocate(ielstart_vdw(nres))
15913       allocate(ielend_vdw(nres))
15914 !(maxres)
15915
15916       allocate(lentyp(0:nfgtasks-1))
15917 !(0:maxprocs-1)
15918 !----------------------
15919 ! commom.contacts
15920 !      common /contacts/
15921       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
15922       allocate(icont(2,maxcont))
15923 !(2,maxcont)
15924 !      common /contacts1/
15925       allocate(num_cont(0:nres+4))
15926 !(maxres)
15927       allocate(jcont(maxconts,nres))
15928 !(maxconts,maxres)
15929       allocate(facont(maxconts,nres))
15930 !(maxconts,maxres)
15931       allocate(gacont(3,maxconts,nres))
15932 !(3,maxconts,maxres)
15933 !      common /contacts_hb/
15934       allocate(gacontp_hb1(3,maxconts,nres))
15935       allocate(gacontp_hb2(3,maxconts,nres))
15936       allocate(gacontp_hb3(3,maxconts,nres))
15937       allocate(gacontm_hb1(3,maxconts,nres))
15938       allocate(gacontm_hb2(3,maxconts,nres))
15939       allocate(gacontm_hb3(3,maxconts,nres))
15940       allocate(gacont_hbr(3,maxconts,nres))
15941       allocate(grij_hb_cont(3,maxconts,nres))
15942 !(3,maxconts,maxres)
15943       allocate(facont_hb(maxconts,nres))
15944       allocate(ees0p(maxconts,nres))
15945       allocate(ees0m(maxconts,nres))
15946       allocate(d_cont(maxconts,nres))
15947 !(maxconts,maxres)
15948       allocate(num_cont_hb(nres))
15949 !(maxres)
15950       allocate(jcont_hb(maxconts,nres))
15951 !(maxconts,maxres)
15952 !      common /rotat/
15953       allocate(Ug(2,2,nres))
15954       allocate(Ugder(2,2,nres))
15955       allocate(Ug2(2,2,nres))
15956       allocate(Ug2der(2,2,nres))
15957 !(2,2,maxres)
15958       allocate(obrot(2,nres))
15959       allocate(obrot2(2,nres))
15960       allocate(obrot_der(2,nres))
15961       allocate(obrot2_der(2,nres))
15962 !(2,maxres)
15963 !      common /precomp1/
15964       allocate(mu(2,nres))
15965       allocate(muder(2,nres))
15966       allocate(Ub2(2,nres))
15967         do i=1,nres
15968           Ub2(1,i)=0.0d0
15969           Ub2(2,i)=0.0d0
15970         enddo
15971       allocate(Ub2der(2,nres))
15972       allocate(Ctobr(2,nres))
15973       allocate(Ctobrder(2,nres))
15974       allocate(Dtobr2(2,nres))
15975       allocate(Dtobr2der(2,nres))
15976 !(2,maxres)
15977       allocate(EUg(2,2,nres))
15978       allocate(EUgder(2,2,nres))
15979       allocate(CUg(2,2,nres))
15980       allocate(CUgder(2,2,nres))
15981       allocate(DUg(2,2,nres))
15982       allocate(Dugder(2,2,nres))
15983       allocate(DtUg2(2,2,nres))
15984       allocate(DtUg2der(2,2,nres))
15985 !(2,2,maxres)
15986 !      common /precomp2/
15987       allocate(Ug2Db1t(2,nres))
15988       allocate(Ug2Db1tder(2,nres))
15989       allocate(CUgb2(2,nres))
15990       allocate(CUgb2der(2,nres))
15991 !(2,maxres)
15992       allocate(EUgC(2,2,nres))
15993       allocate(EUgCder(2,2,nres))
15994       allocate(EUgD(2,2,nres))
15995       allocate(EUgDder(2,2,nres))
15996       allocate(DtUg2EUg(2,2,nres))
15997       allocate(Ug2DtEUg(2,2,nres))
15998 !(2,2,maxres)
15999       allocate(Ug2DtEUgder(2,2,2,nres))
16000       allocate(DtUg2EUgder(2,2,2,nres))
16001 !(2,2,2,maxres)
16002 !      common /rotat_old/
16003       allocate(costab(nres))
16004       allocate(sintab(nres))
16005       allocate(costab2(nres))
16006       allocate(sintab2(nres))
16007 !(maxres)
16008 !      common /dipmat/
16009       allocate(a_chuj(2,2,maxconts,nres))
16010 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16011       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16012 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16013 !      common /contdistrib/
16014       allocate(ncont_sent(nres))
16015       allocate(ncont_recv(nres))
16016
16017       allocate(iat_sent(nres))
16018 !(maxres)
16019       allocate(iint_sent(4,nres,nres))
16020       allocate(iint_sent_local(4,nres,nres))
16021 !(4,maxres,maxres)
16022       allocate(iturn3_sent(4,0:nres+4))
16023       allocate(iturn4_sent(4,0:nres+4))
16024       allocate(iturn3_sent_local(4,nres))
16025       allocate(iturn4_sent_local(4,nres))
16026 !(4,maxres)
16027       allocate(itask_cont_from(0:nfgtasks-1))
16028       allocate(itask_cont_to(0:nfgtasks-1))
16029 !(0:max_fg_procs-1)
16030
16031
16032
16033 !----------------------
16034 ! commom.deriv;
16035 !      common /derivat/
16036       allocate(dcdv(6,maxdim))
16037       allocate(dxdv(6,maxdim))
16038 !(6,maxdim)
16039       allocate(dxds(6,nres))
16040 !(6,maxres)
16041       allocate(gradx(3,nres,0:2))
16042       allocate(gradc(3,nres,0:2))
16043 !(3,maxres,2)
16044       allocate(gvdwx(3,nres))
16045       allocate(gvdwc(3,nres))
16046       allocate(gelc(3,nres))
16047       allocate(gelc_long(3,nres))
16048       allocate(gvdwpp(3,nres))
16049       allocate(gvdwc_scpp(3,nres))
16050       allocate(gradx_scp(3,nres))
16051       allocate(gvdwc_scp(3,nres))
16052       allocate(ghpbx(3,nres))
16053       allocate(ghpbc(3,nres))
16054       allocate(gradcorr(3,nres))
16055       allocate(gradcorr_long(3,nres))
16056       allocate(gradcorr5_long(3,nres))
16057       allocate(gradcorr6_long(3,nres))
16058       allocate(gcorr6_turn_long(3,nres))
16059       allocate(gradxorr(3,nres))
16060       allocate(gradcorr5(3,nres))
16061       allocate(gradcorr6(3,nres))
16062 !(3,maxres)
16063       allocate(gloc(0:maxvar,0:2))
16064       allocate(gloc_x(0:maxvar,2))
16065 !(maxvar,2)
16066       allocate(gel_loc(3,nres))
16067       allocate(gel_loc_long(3,nres))
16068       allocate(gcorr3_turn(3,nres))
16069       allocate(gcorr4_turn(3,nres))
16070       allocate(gcorr6_turn(3,nres))
16071       allocate(gradb(3,nres))
16072       allocate(gradbx(3,nres))
16073 !(3,maxres)
16074       allocate(gel_loc_loc(maxvar))
16075       allocate(gel_loc_turn3(maxvar))
16076       allocate(gel_loc_turn4(maxvar))
16077       allocate(gel_loc_turn6(maxvar))
16078       allocate(gcorr_loc(maxvar))
16079       allocate(g_corr5_loc(maxvar))
16080       allocate(g_corr6_loc(maxvar))
16081 !(maxvar)
16082       allocate(gsccorc(3,nres))
16083       allocate(gsccorx(3,nres))
16084 !(3,maxres)
16085       allocate(gsccor_loc(nres))
16086 !(maxres)
16087       allocate(dtheta(3,2,nres))
16088 !(3,2,maxres)
16089       allocate(gscloc(3,nres))
16090       allocate(gsclocx(3,nres))
16091 !(3,maxres)
16092       allocate(dphi(3,3,nres))
16093       allocate(dalpha(3,3,nres))
16094       allocate(domega(3,3,nres))
16095 !(3,3,maxres)
16096 !      common /deriv_scloc/
16097       allocate(dXX_C1tab(3,nres))
16098       allocate(dYY_C1tab(3,nres))
16099       allocate(dZZ_C1tab(3,nres))
16100       allocate(dXX_Ctab(3,nres))
16101       allocate(dYY_Ctab(3,nres))
16102       allocate(dZZ_Ctab(3,nres))
16103       allocate(dXX_XYZtab(3,nres))
16104       allocate(dYY_XYZtab(3,nres))
16105       allocate(dZZ_XYZtab(3,nres))
16106 !(3,maxres)
16107 !      common /mpgrad/
16108       allocate(jgrad_start(nres))
16109       allocate(jgrad_end(nres))
16110 !(maxres)
16111 !----------------------
16112
16113 !      common /indices/
16114       allocate(ibond_displ(0:nfgtasks-1))
16115       allocate(ibond_count(0:nfgtasks-1))
16116       allocate(ithet_displ(0:nfgtasks-1))
16117       allocate(ithet_count(0:nfgtasks-1))
16118       allocate(iphi_displ(0:nfgtasks-1))
16119       allocate(iphi_count(0:nfgtasks-1))
16120       allocate(iphi1_displ(0:nfgtasks-1))
16121       allocate(iphi1_count(0:nfgtasks-1))
16122       allocate(ivec_displ(0:nfgtasks-1))
16123       allocate(ivec_count(0:nfgtasks-1))
16124       allocate(iset_displ(0:nfgtasks-1))
16125       allocate(iset_count(0:nfgtasks-1))
16126       allocate(iint_count(0:nfgtasks-1))
16127       allocate(iint_displ(0:nfgtasks-1))
16128 !(0:max_fg_procs-1)
16129 !----------------------
16130 ! common.MD
16131 !      common /mdgrad/
16132       allocate(gcart(3,0:nres))
16133       allocate(gxcart(3,0:nres))
16134 !(3,0:MAXRES)
16135       allocate(gradcag(3,nres))
16136       allocate(gradxag(3,nres))
16137 !(3,MAXRES)
16138 !      common /back_constr/
16139 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16140       allocate(dutheta(nres))
16141       allocate(dugamma(nres))
16142 !(maxres)
16143       allocate(duscdiff(3,nres))
16144       allocate(duscdiffx(3,nres))
16145 !(3,maxres)
16146 !el i io:read_fragments
16147 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16148 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16149 !      common /qmeas/
16150 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16151 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16152       allocate(mset(0:nprocs))  !(maxprocs/20)
16153       do i=0,nprocs
16154         mset(i)=0
16155       enddo
16156 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16157 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16158       allocate(dUdconst(3,0:nres))
16159       allocate(dUdxconst(3,0:nres))
16160       allocate(dqwol(3,0:nres))
16161       allocate(dxqwol(3,0:nres))
16162 !(3,0:MAXRES)
16163 !----------------------
16164 ! common.sbridge
16165 !      common /sbridge/ in io_common: read_bridge
16166 !el    allocate((:),allocatable :: iss  !(maxss)
16167 !      common /links/  in io_common: read_bridge
16168 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16169 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16170 !      common /dyn_ssbond/
16171 ! and side-chain vectors in theta or phi.
16172       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16173 !(maxres,maxres)
16174       do i=1,nres
16175         do j=i+1,nres
16176           dyn_ssbond_ij(i,j)=1.0d300
16177         enddo
16178       enddo
16179
16180       if (nss.gt.0) then
16181         allocate(idssb(nss),jdssb(nss))
16182 !(maxdim)
16183       endif
16184       allocate(dyn_ss_mask(nres))
16185 !(maxres)
16186       do i=1,nres
16187         dyn_ss_mask(i)=.false.
16188       enddo
16189 !----------------------
16190 ! common.sccor
16191 ! Parameters of the SCCOR term
16192 !      common/sccor/
16193 !el in io_conf: parmread
16194 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16195 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16196 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16197 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16198 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16199 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16200 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16201 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16202 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16203 !----------------
16204       allocate(gloc_sc(3,0:2*nres,0:10))
16205 !(3,0:maxres2,10)maxres2=2*maxres
16206       allocate(dcostau(3,3,3,2*nres))
16207       allocate(dsintau(3,3,3,2*nres))
16208       allocate(dtauangle(3,3,3,2*nres))
16209       allocate(dcosomicron(3,3,3,2*nres))
16210       allocate(domicron(3,3,3,2*nres))
16211 !(3,3,3,maxres2)maxres2=2*maxres
16212 !----------------------
16213 ! common.var
16214 !      common /restr/
16215       allocate(varall(maxvar))
16216 !(maxvar)(maxvar=6*maxres)
16217       allocate(mask_theta(nres))
16218       allocate(mask_phi(nres))
16219       allocate(mask_side(nres))
16220 !(maxres)
16221 !----------------------
16222 ! common.vectors
16223 !      common /vectors/
16224       allocate(uy(3,nres))
16225       allocate(uz(3,nres))
16226 !(3,maxres)
16227       allocate(uygrad(3,3,2,nres))
16228       allocate(uzgrad(3,3,2,nres))
16229 !(3,3,2,maxres)
16230
16231       return
16232       end subroutine alloc_ener_arrays
16233 !-----------------------------------------------------------------------------
16234 !-----------------------------------------------------------------------------
16235       end module energy