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)') 'evdw1',i,j,evdwij
2801               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2802           endif
2803 !
2804 ! Calculate contributions to the Cartesian gradient.
2805 !
2806 #ifdef SPLITELE
2807           facvdw=-6*rrmij*(ev1+evdwij)
2808           facel=-3*rrmij*(el1+eesij)
2809           fac1=fac
2810           erij(1)=xj*rmij
2811           erij(2)=yj*rmij
2812           erij(3)=zj*rmij
2813 !
2814 ! Radial derivatives. First process both termini of the fragment (i,j)
2815 !
2816           ggg(1)=facel*xj
2817           ggg(2)=facel*yj
2818           ggg(3)=facel*zj
2819 !          do k=1,3
2820 !            ghalf=0.5D0*ggg(k)
2821 !            gelc(k,i)=gelc(k,i)+ghalf
2822 !            gelc(k,j)=gelc(k,j)+ghalf
2823 !          enddo
2824 ! 9/28/08 AL Gradient compotents will be summed only at the end
2825           do k=1,3
2826             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2827             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2828           enddo
2829 !
2830 ! Loop over residues i+1 thru j-1.
2831 !
2832 !grad          do k=i+1,j-1
2833 !grad            do l=1,3
2834 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2835 !grad            enddo
2836 !grad          enddo
2837           ggg(1)=facvdw*xj
2838           ggg(2)=facvdw*yj
2839           ggg(3)=facvdw*zj
2840 !          do k=1,3
2841 !            ghalf=0.5D0*ggg(k)
2842 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2843 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2844 !          enddo
2845 ! 9/28/08 AL Gradient compotents will be summed only at the end
2846           do k=1,3
2847             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2848             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2849           enddo
2850 !
2851 ! Loop over residues i+1 thru j-1.
2852 !
2853 !grad          do k=i+1,j-1
2854 !grad            do l=1,3
2855 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2856 !grad            enddo
2857 !grad          enddo
2858 #else
2859           facvdw=ev1+evdwij
2860           facel=el1+eesij
2861           fac1=fac
2862           fac=-3*rrmij*(facvdw+facvdw+facel)
2863           erij(1)=xj*rmij
2864           erij(2)=yj*rmij
2865           erij(3)=zj*rmij
2866 !
2867 ! Radial derivatives. First process both termini of the fragment (i,j)
2868 !
2869           ggg(1)=fac*xj
2870           ggg(2)=fac*yj
2871           ggg(3)=fac*zj
2872 !          do k=1,3
2873 !            ghalf=0.5D0*ggg(k)
2874 !            gelc(k,i)=gelc(k,i)+ghalf
2875 !            gelc(k,j)=gelc(k,j)+ghalf
2876 !          enddo
2877 ! 9/28/08 AL Gradient compotents will be summed only at the end
2878           do k=1,3
2879             gelc_long(k,j)=gelc(k,j)+ggg(k)
2880             gelc_long(k,i)=gelc(k,i)-ggg(k)
2881           enddo
2882 !
2883 ! Loop over residues i+1 thru j-1.
2884 !
2885 !grad          do k=i+1,j-1
2886 !grad            do l=1,3
2887 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2888 !grad            enddo
2889 !grad          enddo
2890 ! 9/28/08 AL Gradient compotents will be summed only at the end
2891           ggg(1)=facvdw*xj
2892           ggg(2)=facvdw*yj
2893           ggg(3)=facvdw*zj
2894           do k=1,3
2895             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2896             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2897           enddo
2898 #endif
2899 !
2900 ! Angular part
2901 !
2902           ecosa=2.0D0*fac3*fac1+fac4
2903           fac4=-3.0D0*fac4
2904           fac3=-6.0D0*fac3
2905           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2906           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2907           do k=1,3
2908             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2909             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2910           enddo
2911 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2912 !d   &          (dcosg(k),k=1,3)
2913           do k=1,3
2914             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2915           enddo
2916 !          do k=1,3
2917 !            ghalf=0.5D0*ggg(k)
2918 !            gelc(k,i)=gelc(k,i)+ghalf
2919 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2920 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2921 !            gelc(k,j)=gelc(k,j)+ghalf
2922 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2923 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2924 !          enddo
2925 !grad          do k=i+1,j-1
2926 !grad            do l=1,3
2927 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2928 !grad            enddo
2929 !grad          enddo
2930           do k=1,3
2931             gelc(k,i)=gelc(k,i) &
2932                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2933                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2934             gelc(k,j)=gelc(k,j) &
2935                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
2936                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2937             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2938             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2939           enddo
2940           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2941               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
2942               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2943 !
2944 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2945 !   energy of a peptide unit is assumed in the form of a second-order
2946 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2947 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2948 !   are computed for EVERY pair of non-contiguous peptide groups.
2949 !
2950           if (j.lt.nres-1) then
2951             j1=j+1
2952             j2=j-1
2953           else
2954             j1=j-1
2955             j2=j-2
2956           endif
2957           kkk=0
2958           do k=1,2
2959             do l=1,2
2960               kkk=kkk+1
2961               muij(kkk)=mu(k,i)*mu(l,j)
2962             enddo
2963           enddo
2964 !d         write (iout,*) 'EELEC: i',i,' j',j
2965 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
2966 !d          write(iout,*) 'muij',muij
2967           ury=scalar(uy(1,i),erij)
2968           urz=scalar(uz(1,i),erij)
2969           vry=scalar(uy(1,j),erij)
2970           vrz=scalar(uz(1,j),erij)
2971           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2972           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2973           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2974           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2975           fac=dsqrt(-ael6i)*r3ij
2976           a22=a22*fac
2977           a23=a23*fac
2978           a32=a32*fac
2979           a33=a33*fac
2980 !d          write (iout,'(4i5,4f10.5)')
2981 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2982 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2983 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2984 !d     &      uy(:,j),uz(:,j)
2985 !d          write (iout,'(4f10.5)')
2986 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2987 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2988 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
2989 !d           write (iout,'(9f10.5/)')
2990 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2991 ! Derivatives of the elements of A in virtual-bond vectors
2992           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2993           do k=1,3
2994             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2995             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2996             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2997             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2998             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2999             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3000             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3001             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3002             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3003             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3004             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3005             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3006           enddo
3007 ! Compute radial contributions to the gradient
3008           facr=-3.0d0*rrmij
3009           a22der=a22*facr
3010           a23der=a23*facr
3011           a32der=a32*facr
3012           a33der=a33*facr
3013           agg(1,1)=a22der*xj
3014           agg(2,1)=a22der*yj
3015           agg(3,1)=a22der*zj
3016           agg(1,2)=a23der*xj
3017           agg(2,2)=a23der*yj
3018           agg(3,2)=a23der*zj
3019           agg(1,3)=a32der*xj
3020           agg(2,3)=a32der*yj
3021           agg(3,3)=a32der*zj
3022           agg(1,4)=a33der*xj
3023           agg(2,4)=a33der*yj
3024           agg(3,4)=a33der*zj
3025 ! Add the contributions coming from er
3026           fac3=-3.0d0*fac
3027           do k=1,3
3028             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3029             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3030             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3031             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3032           enddo
3033           do k=1,3
3034 ! Derivatives in DC(i)
3035 !grad            ghalf1=0.5d0*agg(k,1)
3036 !grad            ghalf2=0.5d0*agg(k,2)
3037 !grad            ghalf3=0.5d0*agg(k,3)
3038 !grad            ghalf4=0.5d0*agg(k,4)
3039             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3040             -3.0d0*uryg(k,2)*vry)!+ghalf1
3041             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3042             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3043             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3044             -3.0d0*urzg(k,2)*vry)!+ghalf3
3045             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3046             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3047 ! Derivatives in DC(i+1)
3048             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3049             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3050             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3051             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3052             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3053             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3054             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3055             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3056 ! Derivatives in DC(j)
3057             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3058             -3.0d0*vryg(k,2)*ury)!+ghalf1
3059             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3060             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3061             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3062             -3.0d0*vryg(k,2)*urz)!+ghalf3
3063             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3064             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3065 ! Derivatives in DC(j+1) or DC(nres-1)
3066             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3067             -3.0d0*vryg(k,3)*ury)
3068             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3069             -3.0d0*vrzg(k,3)*ury)
3070             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3071             -3.0d0*vryg(k,3)*urz)
3072             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3073             -3.0d0*vrzg(k,3)*urz)
3074 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3075 !grad              do l=1,4
3076 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3077 !grad              enddo
3078 !grad            endif
3079           enddo
3080           acipa(1,1)=a22
3081           acipa(1,2)=a23
3082           acipa(2,1)=a32
3083           acipa(2,2)=a33
3084           a22=-a22
3085           a23=-a23
3086           do l=1,2
3087             do k=1,3
3088               agg(k,l)=-agg(k,l)
3089               aggi(k,l)=-aggi(k,l)
3090               aggi1(k,l)=-aggi1(k,l)
3091               aggj(k,l)=-aggj(k,l)
3092               aggj1(k,l)=-aggj1(k,l)
3093             enddo
3094           enddo
3095           if (j.lt.nres-1) then
3096             a22=-a22
3097             a32=-a32
3098             do l=1,3,2
3099               do k=1,3
3100                 agg(k,l)=-agg(k,l)
3101                 aggi(k,l)=-aggi(k,l)
3102                 aggi1(k,l)=-aggi1(k,l)
3103                 aggj(k,l)=-aggj(k,l)
3104                 aggj1(k,l)=-aggj1(k,l)
3105               enddo
3106             enddo
3107           else
3108             a22=-a22
3109             a23=-a23
3110             a32=-a32
3111             a33=-a33
3112             do l=1,4
3113               do k=1,3
3114                 agg(k,l)=-agg(k,l)
3115                 aggi(k,l)=-aggi(k,l)
3116                 aggi1(k,l)=-aggi1(k,l)
3117                 aggj(k,l)=-aggj(k,l)
3118                 aggj1(k,l)=-aggj1(k,l)
3119               enddo
3120             enddo
3121           endif
3122           ENDIF ! WCORR
3123           IF (wel_loc.gt.0.0d0) THEN
3124 ! Contribution to the local-electrostatic energy coming from the i-j pair
3125           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3126            +a33*muij(4)
3127 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3128
3129           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3130                   'eelloc',i,j,eel_loc_ij
3131 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3132 !          if (energy_dec) write (iout,*) "muij",muij
3133 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3134
3135           eel_loc=eel_loc+eel_loc_ij
3136 ! Partial derivatives in virtual-bond dihedral angles gamma
3137           if (i.gt.1) &
3138           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3139                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3140                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3141           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3142                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3143                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3144 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3145           do l=1,3
3146             ggg(l)=agg(l,1)*muij(1)+ &
3147                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3148             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3149             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3150 !grad            ghalf=0.5d0*ggg(l)
3151 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3152 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3153           enddo
3154 !grad          do k=i+1,j2
3155 !grad            do l=1,3
3156 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3157 !grad            enddo
3158 !grad          enddo
3159 ! Remaining derivatives of eello
3160           do l=1,3
3161             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3162                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3163             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3164                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3165             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3166                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3167             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3168                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3169           enddo
3170           ENDIF
3171 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3172 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3173           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3174              .and. num_conti.le.maxconts) then
3175 !            write (iout,*) i,j," entered corr"
3176 !
3177 ! Calculate the contact function. The ith column of the array JCONT will
3178 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3179 ! greater than I). The arrays FACONT and GACONT will contain the values of
3180 ! the contact function and its derivative.
3181 !           r0ij=1.02D0*rpp(iteli,itelj)
3182 !           r0ij=1.11D0*rpp(iteli,itelj)
3183             r0ij=2.20D0*rpp(iteli,itelj)
3184 !           r0ij=1.55D0*rpp(iteli,itelj)
3185             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3186 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3187             if (fcont.gt.0.0D0) then
3188               num_conti=num_conti+1
3189               if (num_conti.gt.maxconts) then
3190 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3191 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3192                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3193                                ' will skip next contacts for this conf.', num_conti
3194               else
3195                 jcont_hb(num_conti,i)=j
3196 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3197 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3198                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3199                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3200 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3201 !  terms.
3202                 d_cont(num_conti,i)=rij
3203 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3204 !     --- Electrostatic-interaction matrix ---
3205                 a_chuj(1,1,num_conti,i)=a22
3206                 a_chuj(1,2,num_conti,i)=a23
3207                 a_chuj(2,1,num_conti,i)=a32
3208                 a_chuj(2,2,num_conti,i)=a33
3209 !     --- Gradient of rij
3210                 do kkk=1,3
3211                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3212                 enddo
3213                 kkll=0
3214                 do k=1,2
3215                   do l=1,2
3216                     kkll=kkll+1
3217                     do m=1,3
3218                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3219                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3220                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3221                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3222                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3223                     enddo
3224                   enddo
3225                 enddo
3226                 ENDIF
3227                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3228 ! Calculate contact energies
3229                 cosa4=4.0D0*cosa
3230                 wij=cosa-3.0D0*cosb*cosg
3231                 cosbg1=cosb+cosg
3232                 cosbg2=cosb-cosg
3233 !               fac3=dsqrt(-ael6i)/r0ij**3
3234                 fac3=dsqrt(-ael6i)*r3ij
3235 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3236                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3237                 if (ees0tmp.gt.0) then
3238                   ees0pij=dsqrt(ees0tmp)
3239                 else
3240                   ees0pij=0
3241                 endif
3242 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3243                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3244                 if (ees0tmp.gt.0) then
3245                   ees0mij=dsqrt(ees0tmp)
3246                 else
3247                   ees0mij=0
3248                 endif
3249 !               ees0mij=0.0D0
3250                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3251                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3252 ! Diagnostics. Comment out or remove after debugging!
3253 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3254 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3255 !               ees0m(num_conti,i)=0.0D0
3256 ! End diagnostics.
3257 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3258 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3259 ! Angular derivatives of the contact function
3260                 ees0pij1=fac3/ees0pij
3261                 ees0mij1=fac3/ees0mij
3262                 fac3p=-3.0D0*fac3*rrmij
3263                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3264                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3265 !               ees0mij1=0.0D0
3266                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3267                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3268                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3269                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3270                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3271                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3272                 ecosap=ecosa1+ecosa2
3273                 ecosbp=ecosb1+ecosb2
3274                 ecosgp=ecosg1+ecosg2
3275                 ecosam=ecosa1-ecosa2
3276                 ecosbm=ecosb1-ecosb2
3277                 ecosgm=ecosg1-ecosg2
3278 ! Diagnostics
3279 !               ecosap=ecosa1
3280 !               ecosbp=ecosb1
3281 !               ecosgp=ecosg1
3282 !               ecosam=0.0D0
3283 !               ecosbm=0.0D0
3284 !               ecosgm=0.0D0
3285 ! End diagnostics
3286                 facont_hb(num_conti,i)=fcont
3287                 fprimcont=fprimcont/rij
3288 !d              facont_hb(num_conti,i)=1.0D0
3289 ! Following line is for diagnostics.
3290 !d              fprimcont=0.0D0
3291                 do k=1,3
3292                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3293                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3294                 enddo
3295                 do k=1,3
3296                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3297                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3298                 enddo
3299                 gggp(1)=gggp(1)+ees0pijp*xj
3300                 gggp(2)=gggp(2)+ees0pijp*yj
3301                 gggp(3)=gggp(3)+ees0pijp*zj
3302                 gggm(1)=gggm(1)+ees0mijp*xj
3303                 gggm(2)=gggm(2)+ees0mijp*yj
3304                 gggm(3)=gggm(3)+ees0mijp*zj
3305 ! Derivatives due to the contact function
3306                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3307                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3308                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3309                 do k=1,3
3310 !
3311 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3312 !          following the change of gradient-summation algorithm.
3313 !
3314 !grad                  ghalfp=0.5D0*gggp(k)
3315 !grad                  ghalfm=0.5D0*gggm(k)
3316                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3317                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3318                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3319                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3320                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3321                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3322                   gacontp_hb3(k,num_conti,i)=gggp(k)
3323                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3324                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3325                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3326                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3327                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3328                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3329                   gacontm_hb3(k,num_conti,i)=gggm(k)
3330                 enddo
3331 ! Diagnostics. Comment out or remove after debugging!
3332 !diag           do k=1,3
3333 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3334 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3335 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3336 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3337 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3338 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3339 !diag           enddo
3340               ENDIF ! wcorr
3341               endif  ! num_conti.le.maxconts
3342             endif  ! fcont.gt.0
3343           endif    ! j.gt.i+1
3344           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3345             do k=1,4
3346               do l=1,3
3347                 ghalf=0.5d0*agg(l,k)
3348                 aggi(l,k)=aggi(l,k)+ghalf
3349                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3350                 aggj(l,k)=aggj(l,k)+ghalf
3351               enddo
3352             enddo
3353             if (j.eq.nres-1 .and. i.lt.j-2) then
3354               do k=1,4
3355                 do l=1,3
3356                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3357                 enddo
3358               enddo
3359             endif
3360           endif
3361 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3362       return
3363       end subroutine eelecij
3364 !-----------------------------------------------------------------------------
3365       subroutine eturn3(i,eello_turn3)
3366 ! Third- and fourth-order contributions from turns
3367
3368       use comm_locel
3369 !      implicit real*8 (a-h,o-z)
3370 !      include 'DIMENSIONS'
3371 !      include 'COMMON.IOUNITS'
3372 !      include 'COMMON.GEO'
3373 !      include 'COMMON.VAR'
3374 !      include 'COMMON.LOCAL'
3375 !      include 'COMMON.CHAIN'
3376 !      include 'COMMON.DERIV'
3377 !      include 'COMMON.INTERACT'
3378 !      include 'COMMON.CONTACTS'
3379 !      include 'COMMON.TORSION'
3380 !      include 'COMMON.VECTORS'
3381 !      include 'COMMON.FFIELD'
3382 !      include 'COMMON.CONTROL'
3383       real(kind=8),dimension(3) :: ggg
3384       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3385         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3386       real(kind=8),dimension(2) :: auxvec,auxvec1
3387 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3388       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3389 !el      integer :: num_conti,j1,j2
3390 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3391 !el        dz_normi,xmedi,ymedi,zmedi
3392
3393 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3394 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3395 !el         num_conti,j1,j2
3396 !el local variables
3397       integer :: i,j,l
3398       real(kind=8) :: eello_turn3
3399
3400       j=i+2
3401 !      write (iout,*) "eturn3",i,j,j1,j2
3402       a_temp(1,1)=a22
3403       a_temp(1,2)=a23
3404       a_temp(2,1)=a32
3405       a_temp(2,2)=a33
3406 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3407 !
3408 !               Third-order contributions
3409 !
3410 !                 (i+2)o----(i+3)
3411 !                      | |
3412 !                      | |
3413 !                 (i+1)o----i
3414 !
3415 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3416 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3417         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3418         call transpose2(auxmat(1,1),auxmat1(1,1))
3419         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3420         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3421         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3422                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3423 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3424 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3425 !d     &    ' eello_turn3_num',4*eello_turn3_num
3426 ! Derivatives in gamma(i)
3427         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3428         call transpose2(auxmat2(1,1),auxmat3(1,1))
3429         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3430         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3431 ! Derivatives in gamma(i+1)
3432         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3433         call transpose2(auxmat2(1,1),auxmat3(1,1))
3434         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3435         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3436           +0.5d0*(pizda(1,1)+pizda(2,2))
3437 ! Cartesian derivatives
3438         do l=1,3
3439 !            ghalf1=0.5d0*agg(l,1)
3440 !            ghalf2=0.5d0*agg(l,2)
3441 !            ghalf3=0.5d0*agg(l,3)
3442 !            ghalf4=0.5d0*agg(l,4)
3443           a_temp(1,1)=aggi(l,1)!+ghalf1
3444           a_temp(1,2)=aggi(l,2)!+ghalf2
3445           a_temp(2,1)=aggi(l,3)!+ghalf3
3446           a_temp(2,2)=aggi(l,4)!+ghalf4
3447           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3448           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3449             +0.5d0*(pizda(1,1)+pizda(2,2))
3450           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3451           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3452           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3453           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3455           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3456             +0.5d0*(pizda(1,1)+pizda(2,2))
3457           a_temp(1,1)=aggj(l,1)!+ghalf1
3458           a_temp(1,2)=aggj(l,2)!+ghalf2
3459           a_temp(2,1)=aggj(l,3)!+ghalf3
3460           a_temp(2,2)=aggj(l,4)!+ghalf4
3461           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3462           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3463             +0.5d0*(pizda(1,1)+pizda(2,2))
3464           a_temp(1,1)=aggj1(l,1)
3465           a_temp(1,2)=aggj1(l,2)
3466           a_temp(2,1)=aggj1(l,3)
3467           a_temp(2,2)=aggj1(l,4)
3468           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3469           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3470             +0.5d0*(pizda(1,1)+pizda(2,2))
3471         enddo
3472       return
3473       end subroutine eturn3
3474 !-----------------------------------------------------------------------------
3475       subroutine eturn4(i,eello_turn4)
3476 ! Third- and fourth-order contributions from turns
3477
3478       use comm_locel
3479 !      implicit real*8 (a-h,o-z)
3480 !      include 'DIMENSIONS'
3481 !      include 'COMMON.IOUNITS'
3482 !      include 'COMMON.GEO'
3483 !      include 'COMMON.VAR'
3484 !      include 'COMMON.LOCAL'
3485 !      include 'COMMON.CHAIN'
3486 !      include 'COMMON.DERIV'
3487 !      include 'COMMON.INTERACT'
3488 !      include 'COMMON.CONTACTS'
3489 !      include 'COMMON.TORSION'
3490 !      include 'COMMON.VECTORS'
3491 !      include 'COMMON.FFIELD'
3492 !      include 'COMMON.CONTROL'
3493       real(kind=8),dimension(3) :: ggg
3494       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3495         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3496       real(kind=8),dimension(2) :: auxvec,auxvec1
3497 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3498       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3499 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3500 !el        dz_normi,xmedi,ymedi,zmedi
3501 !el      integer :: num_conti,j1,j2
3502 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3503 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3504 !el          num_conti,j1,j2
3505 !el local variables
3506       integer :: i,j,iti1,iti2,iti3,l
3507       real(kind=8) :: eello_turn4,s1,s2,s3
3508
3509       j=i+3
3510 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3511 !
3512 !               Fourth-order contributions
3513 !
3514 !                 (i+3)o----(i+4)
3515 !                     /  |
3516 !               (i+2)o   |
3517 !                     \  |
3518 !                 (i+1)o----i
3519 !
3520 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3521 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3522 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3523         a_temp(1,1)=a22
3524         a_temp(1,2)=a23
3525         a_temp(2,1)=a32
3526         a_temp(2,2)=a33
3527         iti1=itortyp(itype(i+1))
3528         iti2=itortyp(itype(i+2))
3529         iti3=itortyp(itype(i+3))
3530 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3531         call transpose2(EUg(1,1,i+1),e1t(1,1))
3532         call transpose2(Eug(1,1,i+2),e2t(1,1))
3533         call transpose2(Eug(1,1,i+3),e3t(1,1))
3534         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3535         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3536         s1=scalar2(b1(1,iti2),auxvec(1))
3537         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3538         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3539         s2=scalar2(b1(1,iti1),auxvec(1))
3540         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3541         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3542         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3543         eello_turn4=eello_turn4-(s1+s2+s3)
3544         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3545            'eturn4',i,j,-(s1+s2+s3)
3546 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3547 !d     &    ' eello_turn4_num',8*eello_turn4_num
3548 ! Derivatives in gamma(i)
3549         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3550         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3551         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3552         s1=scalar2(b1(1,iti2),auxvec(1))
3553         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3554         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3555         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3556 ! Derivatives in gamma(i+1)
3557         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3558         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3559         s2=scalar2(b1(1,iti1),auxvec(1))
3560         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3561         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3562         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3563         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3564 ! Derivatives in gamma(i+2)
3565         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3566         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3567         s1=scalar2(b1(1,iti2),auxvec(1))
3568         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3569         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3570         s2=scalar2(b1(1,iti1),auxvec(1))
3571         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3572         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3573         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3574         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3575 ! Cartesian derivatives
3576 ! Derivatives of this turn contributions in DC(i+2)
3577         if (j.lt.nres-1) then
3578           do l=1,3
3579             a_temp(1,1)=agg(l,1)
3580             a_temp(1,2)=agg(l,2)
3581             a_temp(2,1)=agg(l,3)
3582             a_temp(2,2)=agg(l,4)
3583             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3584             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3585             s1=scalar2(b1(1,iti2),auxvec(1))
3586             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3587             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3588             s2=scalar2(b1(1,iti1),auxvec(1))
3589             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3590             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3591             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3592             ggg(l)=-(s1+s2+s3)
3593             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3594           enddo
3595         endif
3596 ! Remaining derivatives of this turn contribution
3597         do l=1,3
3598           a_temp(1,1)=aggi(l,1)
3599           a_temp(1,2)=aggi(l,2)
3600           a_temp(2,1)=aggi(l,3)
3601           a_temp(2,2)=aggi(l,4)
3602           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3603           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3604           s1=scalar2(b1(1,iti2),auxvec(1))
3605           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3606           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3607           s2=scalar2(b1(1,iti1),auxvec(1))
3608           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3609           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3610           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3611           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3612           a_temp(1,1)=aggi1(l,1)
3613           a_temp(1,2)=aggi1(l,2)
3614           a_temp(2,1)=aggi1(l,3)
3615           a_temp(2,2)=aggi1(l,4)
3616           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3617           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3618           s1=scalar2(b1(1,iti2),auxvec(1))
3619           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3620           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3621           s2=scalar2(b1(1,iti1),auxvec(1))
3622           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3623           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3624           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3625           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3626           a_temp(1,1)=aggj(l,1)
3627           a_temp(1,2)=aggj(l,2)
3628           a_temp(2,1)=aggj(l,3)
3629           a_temp(2,2)=aggj(l,4)
3630           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3631           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3632           s1=scalar2(b1(1,iti2),auxvec(1))
3633           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3634           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3635           s2=scalar2(b1(1,iti1),auxvec(1))
3636           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3637           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3638           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3639           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3640           a_temp(1,1)=aggj1(l,1)
3641           a_temp(1,2)=aggj1(l,2)
3642           a_temp(2,1)=aggj1(l,3)
3643           a_temp(2,2)=aggj1(l,4)
3644           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3645           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3646           s1=scalar2(b1(1,iti2),auxvec(1))
3647           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3648           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3649           s2=scalar2(b1(1,iti1),auxvec(1))
3650           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3651           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3652           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3653 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3654           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3655         enddo
3656       return
3657       end subroutine eturn4
3658 !-----------------------------------------------------------------------------
3659       subroutine unormderiv(u,ugrad,unorm,ungrad)
3660 ! This subroutine computes the derivatives of a normalized vector u, given
3661 ! the derivatives computed without normalization conditions, ugrad. Returns
3662 ! ungrad.
3663 !      implicit none
3664       real(kind=8),dimension(3) :: u,vec
3665       real(kind=8),dimension(3,3) ::ugrad,ungrad
3666       real(kind=8) :: unorm     !,scalar
3667       integer :: i,j
3668 !      write (2,*) 'ugrad',ugrad
3669 !      write (2,*) 'u',u
3670       do i=1,3
3671         vec(i)=scalar(ugrad(1,i),u(1))
3672       enddo
3673 !      write (2,*) 'vec',vec
3674       do i=1,3
3675         do j=1,3
3676           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3677         enddo
3678       enddo
3679 !      write (2,*) 'ungrad',ungrad
3680       return
3681       end subroutine unormderiv
3682 !-----------------------------------------------------------------------------
3683       subroutine escp_soft_sphere(evdw2,evdw2_14)
3684 !
3685 ! This subroutine calculates the excluded-volume interaction energy between
3686 ! peptide-group centers and side chains and its gradient in virtual-bond and
3687 ! side-chain vectors.
3688 !
3689 !      implicit real*8 (a-h,o-z)
3690 !      include 'DIMENSIONS'
3691 !      include 'COMMON.GEO'
3692 !      include 'COMMON.VAR'
3693 !      include 'COMMON.LOCAL'
3694 !      include 'COMMON.CHAIN'
3695 !      include 'COMMON.DERIV'
3696 !      include 'COMMON.INTERACT'
3697 !      include 'COMMON.FFIELD'
3698 !      include 'COMMON.IOUNITS'
3699 !      include 'COMMON.CONTROL'
3700       real(kind=8),dimension(3) :: ggg
3701 !el local variables
3702       integer :: i,iint,j,k,iteli,itypj
3703       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3704                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3705
3706       evdw2=0.0D0
3707       evdw2_14=0.0d0
3708       r0_scp=4.5d0
3709 !d    print '(a)','Enter ESCP'
3710 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3711       do i=iatscp_s,iatscp_e
3712         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3713         iteli=itel(i)
3714         xi=0.5D0*(c(1,i)+c(1,i+1))
3715         yi=0.5D0*(c(2,i)+c(2,i+1))
3716         zi=0.5D0*(c(3,i)+c(3,i+1))
3717
3718         do iint=1,nscp_gr(i)
3719
3720         do j=iscpstart(i,iint),iscpend(i,iint)
3721           if (itype(j).eq.ntyp1) cycle
3722           itypj=iabs(itype(j))
3723 ! Uncomment following three lines for SC-p interactions
3724 !         xj=c(1,nres+j)-xi
3725 !         yj=c(2,nres+j)-yi
3726 !         zj=c(3,nres+j)-zi
3727 ! Uncomment following three lines for Ca-p interactions
3728           xj=c(1,j)-xi
3729           yj=c(2,j)-yi
3730           zj=c(3,j)-zi
3731           rij=xj*xj+yj*yj+zj*zj
3732           r0ij=r0_scp
3733           r0ijsq=r0ij*r0ij
3734           if (rij.lt.r0ijsq) then
3735             evdwij=0.25d0*(rij-r0ijsq)**2
3736             fac=rij-r0ijsq
3737           else
3738             evdwij=0.0d0
3739             fac=0.0d0
3740           endif
3741           evdw2=evdw2+evdwij
3742 !
3743 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3744 !
3745           ggg(1)=xj*fac
3746           ggg(2)=yj*fac
3747           ggg(3)=zj*fac
3748 !grad          if (j.lt.i) then
3749 !d          write (iout,*) 'j<i'
3750 ! Uncomment following three lines for SC-p interactions
3751 !           do k=1,3
3752 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3753 !           enddo
3754 !grad          else
3755 !d          write (iout,*) 'j>i'
3756 !grad            do k=1,3
3757 !grad              ggg(k)=-ggg(k)
3758 ! Uncomment following line for SC-p interactions
3759 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3760 !grad            enddo
3761 !grad          endif
3762 !grad          do k=1,3
3763 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3764 !grad          enddo
3765 !grad          kstart=min0(i+1,j)
3766 !grad          kend=max0(i-1,j-1)
3767 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3768 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3769 !grad          do k=kstart,kend
3770 !grad            do l=1,3
3771 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3772 !grad            enddo
3773 !grad          enddo
3774           do k=1,3
3775             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3776             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3777           enddo
3778         enddo
3779
3780         enddo ! iint
3781       enddo ! i
3782       return
3783       end subroutine escp_soft_sphere
3784 !-----------------------------------------------------------------------------
3785       subroutine escp(evdw2,evdw2_14)
3786 !
3787 ! This subroutine calculates the excluded-volume interaction energy between
3788 ! peptide-group centers and side chains and its gradient in virtual-bond and
3789 ! side-chain vectors.
3790 !
3791 !      implicit real*8 (a-h,o-z)
3792 !      include 'DIMENSIONS'
3793 !      include 'COMMON.GEO'
3794 !      include 'COMMON.VAR'
3795 !      include 'COMMON.LOCAL'
3796 !      include 'COMMON.CHAIN'
3797 !      include 'COMMON.DERIV'
3798 !      include 'COMMON.INTERACT'
3799 !      include 'COMMON.FFIELD'
3800 !      include 'COMMON.IOUNITS'
3801 !      include 'COMMON.CONTROL'
3802       real(kind=8),dimension(3) :: ggg
3803 !el local variables
3804       integer :: i,iint,j,k,iteli,itypj
3805       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3806                    e1,e2,evdwij
3807
3808       evdw2=0.0D0
3809       evdw2_14=0.0d0
3810 !d    print '(a)','Enter ESCP'
3811 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3812       do i=iatscp_s,iatscp_e
3813         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3814         iteli=itel(i)
3815         xi=0.5D0*(c(1,i)+c(1,i+1))
3816         yi=0.5D0*(c(2,i)+c(2,i+1))
3817         zi=0.5D0*(c(3,i)+c(3,i+1))
3818
3819         do iint=1,nscp_gr(i)
3820
3821         do j=iscpstart(i,iint),iscpend(i,iint)
3822           itypj=iabs(itype(j))
3823           if (itypj.eq.ntyp1) cycle
3824 ! Uncomment following three lines for SC-p interactions
3825 !         xj=c(1,nres+j)-xi
3826 !         yj=c(2,nres+j)-yi
3827 !         zj=c(3,nres+j)-zi
3828 ! Uncomment following three lines for Ca-p interactions
3829           xj=c(1,j)-xi
3830           yj=c(2,j)-yi
3831           zj=c(3,j)-zi
3832           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3833           fac=rrij**expon2
3834           e1=fac*fac*aad(itypj,iteli)
3835           e2=fac*bad(itypj,iteli)
3836           if (iabs(j-i) .le. 2) then
3837             e1=scal14*e1
3838             e2=scal14*e2
3839             evdw2_14=evdw2_14+e1+e2
3840           endif
3841           evdwij=e1+e2
3842           evdw2=evdw2+evdwij
3843 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3844 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3845           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3846              'evdw2',i,j,evdwij
3847 !
3848 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3849 !
3850           fac=-(evdwij+e1)*rrij
3851           ggg(1)=xj*fac
3852           ggg(2)=yj*fac
3853           ggg(3)=zj*fac
3854 !grad          if (j.lt.i) then
3855 !d          write (iout,*) 'j<i'
3856 ! Uncomment following three lines for SC-p interactions
3857 !           do k=1,3
3858 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3859 !           enddo
3860 !grad          else
3861 !d          write (iout,*) 'j>i'
3862 !grad            do k=1,3
3863 !grad              ggg(k)=-ggg(k)
3864 ! Uncomment following line for SC-p interactions
3865 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3866 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3867 !grad            enddo
3868 !grad          endif
3869 !grad          do k=1,3
3870 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3871 !grad          enddo
3872 !grad          kstart=min0(i+1,j)
3873 !grad          kend=max0(i-1,j-1)
3874 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3875 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3876 !grad          do k=kstart,kend
3877 !grad            do l=1,3
3878 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3879 !grad            enddo
3880 !grad          enddo
3881           do k=1,3
3882             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3883             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3884           enddo
3885         enddo
3886
3887         enddo ! iint
3888       enddo ! i
3889       do i=1,nct
3890         do j=1,3
3891           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3892           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3893           gradx_scp(j,i)=expon*gradx_scp(j,i)
3894         enddo
3895       enddo
3896 !******************************************************************************
3897 !
3898 !                              N O T E !!!
3899 !
3900 ! To save time the factor EXPON has been extracted from ALL components
3901 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3902 ! use!
3903 !
3904 !******************************************************************************
3905       return
3906       end subroutine escp
3907 !-----------------------------------------------------------------------------
3908       subroutine edis(ehpb)
3909 !
3910 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3911 !
3912 !      implicit real*8 (a-h,o-z)
3913 !      include 'DIMENSIONS'
3914 !      include 'COMMON.SBRIDGE'
3915 !      include 'COMMON.CHAIN'
3916 !      include 'COMMON.DERIV'
3917 !      include 'COMMON.VAR'
3918 !      include 'COMMON.INTERACT'
3919 !      include 'COMMON.IOUNITS'
3920       real(kind=8),dimension(3) :: ggg
3921 !el local variables
3922       integer :: i,j,ii,jj,iii,jjj,k
3923       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3924
3925       ehpb=0.0D0
3926 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3927 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3928       if (link_end.eq.0) return
3929       do i=link_start,link_end
3930 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3931 ! CA-CA distance used in regularization of structure.
3932         ii=ihpb(i)
3933         jj=jhpb(i)
3934 ! iii and jjj point to the residues for which the distance is assigned.
3935         if (ii.gt.nres) then
3936           iii=ii-nres
3937           jjj=jj-nres
3938         else
3939           iii=ii
3940           jjj=jj
3941         endif
3942 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3943 !     &    dhpb(i),dhpb1(i),forcon(i)
3944 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
3945 !    distance and angle dependent SS bond potential.
3946 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3947 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3948         if (.not.dyn_ss .and. i.le.nss) then
3949 ! 15/02/13 CC dynamic SSbond - additional check
3950          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
3951         iabs(itype(jjj)).eq.1) then
3952           call ssbond_ene(iii,jjj,eij)
3953           ehpb=ehpb+2*eij
3954 !d          write (iout,*) "eij",eij
3955          endif
3956         else
3957 ! Calculate the distance between the two points and its difference from the
3958 ! target distance.
3959         dd=dist(ii,jj)
3960         rdis=dd-dhpb(i)
3961 ! Get the force constant corresponding to this distance.
3962         waga=forcon(i)
3963 ! Calculate the contribution to energy.
3964         ehpb=ehpb+waga*rdis*rdis
3965 !
3966 ! Evaluate gradient.
3967 !
3968         fac=waga*rdis/dd
3969 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3970 !d   &   ' waga=',waga,' fac=',fac
3971         do j=1,3
3972           ggg(j)=fac*(c(j,jj)-c(j,ii))
3973         enddo
3974 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3975 ! If this is a SC-SC distance, we need to calculate the contributions to the
3976 ! Cartesian gradient in the SC vectors (ghpbx).
3977         if (iii.lt.ii) then
3978           do j=1,3
3979             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3980             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3981           enddo
3982         endif
3983 !grad        do j=iii,jjj-1
3984 !grad          do k=1,3
3985 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3986 !grad          enddo
3987 !grad        enddo
3988         do k=1,3
3989           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3990           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3991         enddo
3992         endif
3993       enddo
3994       ehpb=0.5D0*ehpb
3995       return
3996       end subroutine edis
3997 !-----------------------------------------------------------------------------
3998       subroutine ssbond_ene(i,j,eij)
3999 !
4000 ! Calculate the distance and angle dependent SS-bond potential energy
4001 ! using a free-energy function derived based on RHF/6-31G** ab initio
4002 ! calculations of diethyl disulfide.
4003 !
4004 ! A. Liwo and U. Kozlowska, 11/24/03
4005 !
4006 !      implicit real*8 (a-h,o-z)
4007 !      include 'DIMENSIONS'
4008 !      include 'COMMON.SBRIDGE'
4009 !      include 'COMMON.CHAIN'
4010 !      include 'COMMON.DERIV'
4011 !      include 'COMMON.LOCAL'
4012 !      include 'COMMON.INTERACT'
4013 !      include 'COMMON.VAR'
4014 !      include 'COMMON.IOUNITS'
4015       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4016 !el local variables
4017       integer :: i,j,itypi,itypj,k
4018       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4019                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4020                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4021                    cosphi,ggk
4022
4023       itypi=iabs(itype(i))
4024       xi=c(1,nres+i)
4025       yi=c(2,nres+i)
4026       zi=c(3,nres+i)
4027       dxi=dc_norm(1,nres+i)
4028       dyi=dc_norm(2,nres+i)
4029       dzi=dc_norm(3,nres+i)
4030 !      dsci_inv=dsc_inv(itypi)
4031       dsci_inv=vbld_inv(nres+i)
4032       itypj=iabs(itype(j))
4033 !      dscj_inv=dsc_inv(itypj)
4034       dscj_inv=vbld_inv(nres+j)
4035       xj=c(1,nres+j)-xi
4036       yj=c(2,nres+j)-yi
4037       zj=c(3,nres+j)-zi
4038       dxj=dc_norm(1,nres+j)
4039       dyj=dc_norm(2,nres+j)
4040       dzj=dc_norm(3,nres+j)
4041       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4042       rij=dsqrt(rrij)
4043       erij(1)=xj*rij
4044       erij(2)=yj*rij
4045       erij(3)=zj*rij
4046       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4047       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4048       om12=dxi*dxj+dyi*dyj+dzi*dzj
4049       do k=1,3
4050         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4051         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4052       enddo
4053       rij=1.0d0/rij
4054       deltad=rij-d0cm
4055       deltat1=1.0d0-om1
4056       deltat2=1.0d0+om2
4057       deltat12=om2-om1+2.0d0
4058       cosphi=om12-om1*om2
4059       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4060         +akct*deltad*deltat12 &
4061         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4062 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4063 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4064 !     &  " deltat12",deltat12," eij",eij
4065       ed=2*akcm*deltad+akct*deltat12
4066       pom1=akct*deltad
4067       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4068       eom1=-2*akth*deltat1-pom1-om2*pom2
4069       eom2= 2*akth*deltat2+pom1-om1*pom2
4070       eom12=pom2
4071       do k=1,3
4072         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4073         ghpbx(k,i)=ghpbx(k,i)-ggk &
4074                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4075                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4076         ghpbx(k,j)=ghpbx(k,j)+ggk &
4077                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4078                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4079         ghpbc(k,i)=ghpbc(k,i)-ggk
4080         ghpbc(k,j)=ghpbc(k,j)+ggk
4081       enddo
4082 !
4083 ! Calculate the components of the gradient in DC and X
4084 !
4085 !grad      do k=i,j-1
4086 !grad        do l=1,3
4087 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4088 !grad        enddo
4089 !grad      enddo
4090       return
4091       end subroutine ssbond_ene
4092 !-----------------------------------------------------------------------------
4093       subroutine ebond(estr)
4094 !
4095 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4096 !
4097 !      implicit real*8 (a-h,o-z)
4098 !      include 'DIMENSIONS'
4099 !      include 'COMMON.LOCAL'
4100 !      include 'COMMON.GEO'
4101 !      include 'COMMON.INTERACT'
4102 !      include 'COMMON.DERIV'
4103 !      include 'COMMON.VAR'
4104 !      include 'COMMON.CHAIN'
4105 !      include 'COMMON.IOUNITS'
4106 !      include 'COMMON.NAMES'
4107 !      include 'COMMON.FFIELD'
4108 !      include 'COMMON.CONTROL'
4109 !      include 'COMMON.SETUP'
4110       real(kind=8),dimension(3) :: u,ud
4111 !el local variables
4112       integer :: i,j,iti,nbi,k
4113       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4114                    uprod1,uprod2
4115
4116       estr=0.0d0
4117       estr1=0.0d0
4118 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4119 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4120
4121       do i=ibondp_start,ibondp_end
4122         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4123           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4124           do j=1,3
4125           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4126             *dc(j,i-1)/vbld(i)
4127           enddo
4128           if (energy_dec) write(iout,*) &
4129              "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4130         else
4131         diff = vbld(i)-vbldp0
4132         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4133            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4134         estr=estr+diff*diff
4135         do j=1,3
4136           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4137         enddo
4138 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4139         endif
4140       enddo
4141       estr=0.5d0*AKP*estr+estr1
4142 !
4143 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4144 !
4145       do i=ibond_start,ibond_end
4146         iti=iabs(itype(i))
4147         if (iti.ne.10 .and. iti.ne.ntyp1) then
4148           nbi=nbondterm(iti)
4149           if (nbi.eq.1) then
4150             diff=vbld(i+nres)-vbldsc0(1,iti)
4151             if (energy_dec) write (iout,*) &
4152             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4153             AKSC(1,iti),AKSC(1,iti)*diff*diff
4154             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4155             do j=1,3
4156               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4157             enddo
4158           else
4159             do j=1,nbi
4160               diff=vbld(i+nres)-vbldsc0(j,iti)
4161               ud(j)=aksc(j,iti)*diff
4162               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4163             enddo
4164             uprod=u(1)
4165             do j=2,nbi
4166               uprod=uprod*u(j)
4167             enddo
4168             usum=0.0d0
4169             usumsqder=0.0d0
4170             do j=1,nbi
4171               uprod1=1.0d0
4172               uprod2=1.0d0
4173               do k=1,nbi
4174                 if (k.ne.j) then
4175                   uprod1=uprod1*u(k)
4176                   uprod2=uprod2*u(k)*u(k)
4177                 endif
4178               enddo
4179               usum=usum+uprod1
4180               usumsqder=usumsqder+ud(j)*uprod2
4181             enddo
4182             estr=estr+uprod/usum
4183             do j=1,3
4184              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4185             enddo
4186           endif
4187         endif
4188       enddo
4189       return
4190       end subroutine ebond
4191 #ifdef CRYST_THETA
4192 !-----------------------------------------------------------------------------
4193       subroutine ebend(etheta)
4194 !
4195 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4196 ! angles gamma and its derivatives in consecutive thetas and gammas.
4197 !
4198       use comm_calcthet
4199 !      implicit real*8 (a-h,o-z)
4200 !      include 'DIMENSIONS'
4201 !      include 'COMMON.LOCAL'
4202 !      include 'COMMON.GEO'
4203 !      include 'COMMON.INTERACT'
4204 !      include 'COMMON.DERIV'
4205 !      include 'COMMON.VAR'
4206 !      include 'COMMON.CHAIN'
4207 !      include 'COMMON.IOUNITS'
4208 !      include 'COMMON.NAMES'
4209 !      include 'COMMON.FFIELD'
4210 !      include 'COMMON.CONTROL'
4211 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4212 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4213 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4214 !el      integer :: it
4215 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4216 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4217 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4218 !el local variables
4219       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4220        ichir21,ichir22
4221       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4222        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4223        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4224       real(kind=8),dimension(2) :: y,z
4225
4226       delta=0.02d0*pi
4227 !      time11=dexp(-2*time)
4228 !      time12=1.0d0
4229       etheta=0.0D0
4230 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4231       do i=ithet_start,ithet_end
4232         if (itype(i-1).eq.ntyp1) cycle
4233 ! Zero the energy function and its derivative at 0 or pi.
4234         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4235         it=itype(i-1)
4236         ichir1=isign(1,itype(i-2))
4237         ichir2=isign(1,itype(i))
4238          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4239          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4240          if (itype(i-1).eq.10) then
4241           itype1=isign(10,itype(i-2))
4242           ichir11=isign(1,itype(i-2))
4243           ichir12=isign(1,itype(i-2))
4244           itype2=isign(10,itype(i))
4245           ichir21=isign(1,itype(i))
4246           ichir22=isign(1,itype(i))
4247          endif
4248
4249         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4250 #ifdef OSF
4251           phii=phi(i)
4252           if (phii.ne.phii) phii=150.0
4253 #else
4254           phii=phi(i)
4255 #endif
4256           y(1)=dcos(phii)
4257           y(2)=dsin(phii)
4258         else
4259           y(1)=0.0D0
4260           y(2)=0.0D0
4261         endif
4262         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4263 #ifdef OSF
4264           phii1=phi(i+1)
4265           if (phii1.ne.phii1) phii1=150.0
4266           phii1=pinorm(phii1)
4267           z(1)=cos(phii1)
4268 #else
4269           phii1=phi(i+1)
4270           z(1)=dcos(phii1)
4271 #endif
4272           z(2)=dsin(phii1)
4273         else
4274           z(1)=0.0D0
4275           z(2)=0.0D0
4276         endif
4277 ! Calculate the "mean" value of theta from the part of the distribution
4278 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4279 ! In following comments this theta will be referred to as t_c.
4280         thet_pred_mean=0.0d0
4281         do k=1,2
4282             athetk=athet(k,it,ichir1,ichir2)
4283             bthetk=bthet(k,it,ichir1,ichir2)
4284           if (it.eq.10) then
4285              athetk=athet(k,itype1,ichir11,ichir12)
4286              bthetk=bthet(k,itype2,ichir21,ichir22)
4287           endif
4288          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4289         enddo
4290         dthett=thet_pred_mean*ssd
4291         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4292 ! Derivatives of the "mean" values in gamma1 and gamma2.
4293         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4294                +athet(2,it,ichir1,ichir2)*y(1))*ss
4295         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4296                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4297          if (it.eq.10) then
4298         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4299              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4300         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4301                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4302          endif
4303         if (theta(i).gt.pi-delta) then
4304           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4305                E_tc0)
4306           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4307           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4308           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4309               E_theta)
4310           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4311               E_tc)
4312         else if (theta(i).lt.delta) then
4313           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4314           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4315           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4316               E_theta)
4317           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4318           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4319               E_tc)
4320         else
4321           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4322               E_theta,E_tc)
4323         endif
4324         etheta=etheta+ethetai
4325         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4326             'ebend',i,ethetai
4327         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4328         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4329         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4330       enddo
4331 ! Ufff.... We've done all this!!!
4332       return
4333       end subroutine ebend
4334 !-----------------------------------------------------------------------------
4335       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4336
4337       use comm_calcthet
4338 !      implicit real*8 (a-h,o-z)
4339 !      include 'DIMENSIONS'
4340 !      include 'COMMON.LOCAL'
4341 !      include 'COMMON.IOUNITS'
4342 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4343 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4344 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4345       integer :: i,j,k
4346       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4347 !el      integer :: it
4348 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4349 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4350 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4351 !el local variables
4352       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4353        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4354
4355 ! Calculate the contributions to both Gaussian lobes.
4356 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4357 ! The "polynomial part" of the "standard deviation" of this part of
4358 ! the distribution.
4359         sig=polthet(3,it)
4360         do j=2,0,-1
4361           sig=sig*thet_pred_mean+polthet(j,it)
4362         enddo
4363 ! Derivative of the "interior part" of the "standard deviation of the"
4364 ! gamma-dependent Gaussian lobe in t_c.
4365         sigtc=3*polthet(3,it)
4366         do j=2,1,-1
4367           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4368         enddo
4369         sigtc=sig*sigtc
4370 ! Set the parameters of both Gaussian lobes of the distribution.
4371 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4372         fac=sig*sig+sigc0(it)
4373         sigcsq=fac+fac
4374         sigc=1.0D0/sigcsq
4375 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4376         sigsqtc=-4.0D0*sigcsq*sigtc
4377 !       print *,i,sig,sigtc,sigsqtc
4378 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4379         sigtc=-sigtc/(fac*fac)
4380 ! Following variable is sigma(t_c)**(-2)
4381         sigcsq=sigcsq*sigcsq
4382         sig0i=sig0(it)
4383         sig0inv=1.0D0/sig0i**2
4384         delthec=thetai-thet_pred_mean
4385         delthe0=thetai-theta0i
4386         term1=-0.5D0*sigcsq*delthec*delthec
4387         term2=-0.5D0*sig0inv*delthe0*delthe0
4388 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4389 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4390 ! to the energy (this being the log of the distribution) at the end of energy
4391 ! term evaluation for this virtual-bond angle.
4392         if (term1.gt.term2) then
4393           termm=term1
4394           term2=dexp(term2-termm)
4395           term1=1.0d0
4396         else
4397           termm=term2
4398           term1=dexp(term1-termm)
4399           term2=1.0d0
4400         endif
4401 ! The ratio between the gamma-independent and gamma-dependent lobes of
4402 ! the distribution is a Gaussian function of thet_pred_mean too.
4403         diffak=gthet(2,it)-thet_pred_mean
4404         ratak=diffak/gthet(3,it)**2
4405         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4406 ! Let's differentiate it in thet_pred_mean NOW.
4407         aktc=ak*ratak
4408 ! Now put together the distribution terms to make complete distribution.
4409         termexp=term1+ak*term2
4410         termpre=sigc+ak*sig0i
4411 ! Contribution of the bending energy from this theta is just the -log of
4412 ! the sum of the contributions from the two lobes and the pre-exponential
4413 ! factor. Simple enough, isn't it?
4414         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4415 ! NOW the derivatives!!!
4416 ! 6/6/97 Take into account the deformation.
4417         E_theta=(delthec*sigcsq*term1 &
4418              +ak*delthe0*sig0inv*term2)/termexp
4419         E_tc=((sigtc+aktc*sig0i)/termpre &
4420             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4421              aktc*term2)/termexp)
4422       return
4423       end subroutine theteng
4424 #else
4425 !-----------------------------------------------------------------------------
4426       subroutine ebend(etheta)
4427 !
4428 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4429 ! angles gamma and its derivatives in consecutive thetas and gammas.
4430 ! ab initio-derived potentials from
4431 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4432 !
4433 !      implicit real*8 (a-h,o-z)
4434 !      include 'DIMENSIONS'
4435 !      include 'COMMON.LOCAL'
4436 !      include 'COMMON.GEO'
4437 !      include 'COMMON.INTERACT'
4438 !      include 'COMMON.DERIV'
4439 !      include 'COMMON.VAR'
4440 !      include 'COMMON.CHAIN'
4441 !      include 'COMMON.IOUNITS'
4442 !      include 'COMMON.NAMES'
4443 !      include 'COMMON.FFIELD'
4444 !      include 'COMMON.CONTROL'
4445       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4446       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4447       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4448       logical :: lprn=.false., lprn1=.false.
4449 !el local variables
4450       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4451       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4452       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4453
4454       etheta=0.0D0
4455       do i=ithet_start,ithet_end
4456         if (itype(i-1).eq.ntyp1) cycle
4457         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4458         if (iabs(itype(i+1)).eq.20) iblock=2
4459         if (iabs(itype(i+1)).ne.20) iblock=1
4460         dethetai=0.0d0
4461         dephii=0.0d0
4462         dephii1=0.0d0
4463         theti2=0.5d0*theta(i)
4464         ityp2=ithetyp((itype(i-1)))
4465         do k=1,nntheterm
4466           coskt(k)=dcos(k*theti2)
4467           sinkt(k)=dsin(k*theti2)
4468         enddo
4469         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4470 #ifdef OSF
4471           phii=phi(i)
4472           if (phii.ne.phii) phii=150.0
4473 #else
4474           phii=phi(i)
4475 #endif
4476           ityp1=ithetyp((itype(i-2)))
4477 ! propagation of chirality for glycine type
4478           do k=1,nsingle
4479             cosph1(k)=dcos(k*phii)
4480             sinph1(k)=dsin(k*phii)
4481           enddo
4482         else
4483           phii=0.0d0
4484           ityp1=ithetyp(itype(i-2))
4485           do k=1,nsingle
4486             cosph1(k)=0.0d0
4487             sinph1(k)=0.0d0
4488           enddo
4489         endif
4490         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4491 #ifdef OSF
4492           phii1=phi(i+1)
4493           if (phii1.ne.phii1) phii1=150.0
4494           phii1=pinorm(phii1)
4495 #else
4496           phii1=phi(i+1)
4497 #endif
4498           ityp3=ithetyp((itype(i)))
4499           do k=1,nsingle
4500             cosph2(k)=dcos(k*phii1)
4501             sinph2(k)=dsin(k*phii1)
4502           enddo
4503         else
4504           phii1=0.0d0
4505           ityp3=ithetyp(itype(i))
4506           do k=1,nsingle
4507             cosph2(k)=0.0d0
4508             sinph2(k)=0.0d0
4509           enddo
4510         endif
4511         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4512         do k=1,ndouble
4513           do l=1,k-1
4514             ccl=cosph1(l)*cosph2(k-l)
4515             ssl=sinph1(l)*sinph2(k-l)
4516             scl=sinph1(l)*cosph2(k-l)
4517             csl=cosph1(l)*sinph2(k-l)
4518             cosph1ph2(l,k)=ccl-ssl
4519             cosph1ph2(k,l)=ccl+ssl
4520             sinph1ph2(l,k)=scl+csl
4521             sinph1ph2(k,l)=scl-csl
4522           enddo
4523         enddo
4524         if (lprn) then
4525         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4526           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4527         write (iout,*) "coskt and sinkt"
4528         do k=1,nntheterm
4529           write (iout,*) k,coskt(k),sinkt(k)
4530         enddo
4531         endif
4532         do k=1,ntheterm
4533           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4534           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4535             *coskt(k)
4536           if (lprn) &
4537           write (iout,*) "k",k,&
4538            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4539            " ethetai",ethetai
4540         enddo
4541         if (lprn) then
4542         write (iout,*) "cosph and sinph"
4543         do k=1,nsingle
4544           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4545         enddo
4546         write (iout,*) "cosph1ph2 and sinph2ph2"
4547         do k=2,ndouble
4548           do l=1,k-1
4549             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4550                sinph1ph2(l,k),sinph1ph2(k,l)
4551           enddo
4552         enddo
4553         write(iout,*) "ethetai",ethetai
4554         endif
4555         do m=1,ntheterm2
4556           do k=1,nsingle
4557             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4558                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4559                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4560                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4561             ethetai=ethetai+sinkt(m)*aux
4562             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4563             dephii=dephii+k*sinkt(m)* &
4564                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4565                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4566             dephii1=dephii1+k*sinkt(m)* &
4567                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4568                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4569             if (lprn) &
4570             write (iout,*) "m",m," k",k," bbthet", &
4571                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4572                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4573                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4574                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4575           enddo
4576         enddo
4577         if (lprn) &
4578         write(iout,*) "ethetai",ethetai
4579         do m=1,ntheterm3
4580           do k=2,ndouble
4581             do l=1,k-1
4582               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4583                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4584                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4585                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4586               ethetai=ethetai+sinkt(m)*aux
4587               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4588               dephii=dephii+l*sinkt(m)* &
4589                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4590                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4591                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4592                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4593               dephii1=dephii1+(k-l)*sinkt(m)* &
4594                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4595                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4596                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4597                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4598               if (lprn) then
4599               write (iout,*) "m",m," k",k," l",l," ffthet",&
4600                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4601                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4602                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4603                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4604                   " ethetai",ethetai
4605               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4606                   cosph1ph2(k,l)*sinkt(m),&
4607                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4608               endif
4609             enddo
4610           enddo
4611         enddo
4612 10      continue
4613 !        lprn1=.true.
4614         if (lprn1) &
4615           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4616          i,theta(i)*rad2deg,phii*rad2deg,&
4617          phii1*rad2deg,ethetai
4618 !        lprn1=.false.
4619         etheta=etheta+ethetai
4620         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4621                                     'ebend',i,ethetai
4622         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4623         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4624         gloc(nphi+i-2,icg)=wang*dethetai
4625       enddo
4626       return
4627       end subroutine ebend
4628 #endif
4629 #ifdef CRYST_SC
4630 !-----------------------------------------------------------------------------
4631       subroutine esc(escloc)
4632 ! Calculate the local energy of a side chain and its derivatives in the
4633 ! corresponding virtual-bond valence angles THETA and the spherical angles
4634 ! ALPHA and OMEGA.
4635 !
4636       use comm_sccalc
4637 !      implicit real*8 (a-h,o-z)
4638 !      include 'DIMENSIONS'
4639 !      include 'COMMON.GEO'
4640 !      include 'COMMON.LOCAL'
4641 !      include 'COMMON.VAR'
4642 !      include 'COMMON.INTERACT'
4643 !      include 'COMMON.DERIV'
4644 !      include 'COMMON.CHAIN'
4645 !      include 'COMMON.IOUNITS'
4646 !      include 'COMMON.NAMES'
4647 !      include 'COMMON.FFIELD'
4648 !      include 'COMMON.CONTROL'
4649       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4650          ddersc0,ddummy,xtemp,temp
4651 !el      real(kind=8) :: time11,time12,time112,theti
4652       real(kind=8) :: escloc,delta
4653 !el      integer :: it,nlobit
4654 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4655 !el local variables
4656       integer :: i,k
4657       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4658        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4659       delta=0.02d0*pi
4660       escloc=0.0D0
4661 !     write (iout,'(a)') 'ESC'
4662       do i=loc_start,loc_end
4663         it=itype(i)
4664         if (it.eq.ntyp1) cycle
4665         if (it.eq.10) goto 1
4666         nlobit=nlob(iabs(it))
4667 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4668 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4669         theti=theta(i+1)-pipol
4670         x(1)=dtan(theti)
4671         x(2)=alph(i)
4672         x(3)=omeg(i)
4673
4674         if (x(2).gt.pi-delta) then
4675           xtemp(1)=x(1)
4676           xtemp(2)=pi-delta
4677           xtemp(3)=x(3)
4678           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4679           xtemp(2)=pi
4680           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4681           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4682               escloci,dersc(2))
4683           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4684               ddersc0(1),dersc(1))
4685           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4686               ddersc0(3),dersc(3))
4687           xtemp(2)=pi-delta
4688           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4689           xtemp(2)=pi
4690           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4691           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4692                   dersc0(2),esclocbi,dersc02)
4693           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4694                   dersc12,dersc01)
4695           call splinthet(x(2),0.5d0*delta,ss,ssd)
4696           dersc0(1)=dersc01
4697           dersc0(2)=dersc02
4698           dersc0(3)=0.0d0
4699           do k=1,3
4700             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4701           enddo
4702           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4703 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4704 !    &             esclocbi,ss,ssd
4705           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4706 !         escloci=esclocbi
4707 !         write (iout,*) escloci
4708         else if (x(2).lt.delta) then
4709           xtemp(1)=x(1)
4710           xtemp(2)=delta
4711           xtemp(3)=x(3)
4712           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4713           xtemp(2)=0.0d0
4714           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4715           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4716               escloci,dersc(2))
4717           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4718               ddersc0(1),dersc(1))
4719           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4720               ddersc0(3),dersc(3))
4721           xtemp(2)=delta
4722           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4723           xtemp(2)=0.0d0
4724           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4725           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4726                   dersc0(2),esclocbi,dersc02)
4727           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4728                   dersc12,dersc01)
4729           dersc0(1)=dersc01
4730           dersc0(2)=dersc02
4731           dersc0(3)=0.0d0
4732           call splinthet(x(2),0.5d0*delta,ss,ssd)
4733           do k=1,3
4734             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4735           enddo
4736           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4737 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4738 !    &             esclocbi,ss,ssd
4739           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4740 !         write (iout,*) escloci
4741         else
4742           call enesc(x,escloci,dersc,ddummy,.false.)
4743         endif
4744
4745         escloc=escloc+escloci
4746         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4747            'escloc',i,escloci
4748 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4749
4750         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4751          wscloc*dersc(1)
4752         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4753         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4754     1   continue
4755       enddo
4756       return
4757       end subroutine esc
4758 !-----------------------------------------------------------------------------
4759       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4760
4761       use comm_sccalc
4762 !      implicit real*8 (a-h,o-z)
4763 !      include 'DIMENSIONS'
4764 !      include 'COMMON.GEO'
4765 !      include 'COMMON.LOCAL'
4766 !      include 'COMMON.IOUNITS'
4767 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4768       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4769       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4770       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4771       real(kind=8) :: escloci
4772       logical :: mixed
4773 !el local variables
4774       integer :: j,iii,l,k !el,it,nlobit
4775       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4776 !el       time11,time12,time112
4777 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4778         escloc_i=0.0D0
4779         do j=1,3
4780           dersc(j)=0.0D0
4781           if (mixed) ddersc(j)=0.0d0
4782         enddo
4783         x3=x(3)
4784
4785 ! Because of periodicity of the dependence of the SC energy in omega we have
4786 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4787 ! To avoid underflows, first compute & store the exponents.
4788
4789         do iii=-1,1
4790
4791           x(3)=x3+iii*dwapi
4792
4793           do j=1,nlobit
4794             do k=1,3
4795               z(k)=x(k)-censc(k,j,it)
4796             enddo
4797             do k=1,3
4798               Axk=0.0D0
4799               do l=1,3
4800                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4801               enddo
4802               Ax(k,j,iii)=Axk
4803             enddo
4804             expfac=0.0D0
4805             do k=1,3
4806               expfac=expfac+Ax(k,j,iii)*z(k)
4807             enddo
4808             contr(j,iii)=expfac
4809           enddo ! j
4810
4811         enddo ! iii
4812
4813         x(3)=x3
4814 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4815 ! subsequent NaNs and INFs in energy calculation.
4816 ! Find the largest exponent
4817         emin=contr(1,-1)
4818         do iii=-1,1
4819           do j=1,nlobit
4820             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4821           enddo
4822         enddo
4823         emin=0.5D0*emin
4824 !d      print *,'it=',it,' emin=',emin
4825
4826 ! Compute the contribution to SC energy and derivatives
4827         do iii=-1,1
4828
4829           do j=1,nlobit
4830 #ifdef OSF
4831             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4832             if(adexp.ne.adexp) adexp=1.0
4833             expfac=dexp(adexp)
4834 #else
4835             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4836 #endif
4837 !d          print *,'j=',j,' expfac=',expfac
4838             escloc_i=escloc_i+expfac
4839             do k=1,3
4840               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4841             enddo
4842             if (mixed) then
4843               do k=1,3,2
4844                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4845                   +gaussc(k,2,j,it))*expfac
4846               enddo
4847             endif
4848           enddo
4849
4850         enddo ! iii
4851
4852         dersc(1)=dersc(1)/cos(theti)**2
4853         ddersc(1)=ddersc(1)/cos(theti)**2
4854         ddersc(3)=ddersc(3)
4855
4856         escloci=-(dlog(escloc_i)-emin)
4857         do j=1,3
4858           dersc(j)=dersc(j)/escloc_i
4859         enddo
4860         if (mixed) then
4861           do j=1,3,2
4862             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4863           enddo
4864         endif
4865       return
4866       end subroutine enesc
4867 !-----------------------------------------------------------------------------
4868       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4869
4870       use comm_sccalc
4871 !      implicit real*8 (a-h,o-z)
4872 !      include 'DIMENSIONS'
4873 !      include 'COMMON.GEO'
4874 !      include 'COMMON.LOCAL'
4875 !      include 'COMMON.IOUNITS'
4876 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4877       real(kind=8),dimension(3) :: x,z,dersc
4878       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4879       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4880       real(kind=8) :: escloci,dersc12,emin
4881       logical :: mixed
4882 !el local varables
4883       integer :: j,k,l !el,it,nlobit
4884       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4885
4886       escloc_i=0.0D0
4887
4888       do j=1,3
4889         dersc(j)=0.0D0
4890       enddo
4891
4892       do j=1,nlobit
4893         do k=1,2
4894           z(k)=x(k)-censc(k,j,it)
4895         enddo
4896         z(3)=dwapi
4897         do k=1,3
4898           Axk=0.0D0
4899           do l=1,3
4900             Axk=Axk+gaussc(l,k,j,it)*z(l)
4901           enddo
4902           Ax(k,j)=Axk
4903         enddo
4904         expfac=0.0D0
4905         do k=1,3
4906           expfac=expfac+Ax(k,j)*z(k)
4907         enddo
4908         contr(j)=expfac
4909       enddo ! j
4910
4911 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4912 ! subsequent NaNs and INFs in energy calculation.
4913 ! Find the largest exponent
4914       emin=contr(1)
4915       do j=1,nlobit
4916         if (emin.gt.contr(j)) emin=contr(j)
4917       enddo
4918       emin=0.5D0*emin
4919
4920 ! Compute the contribution to SC energy and derivatives
4921
4922       dersc12=0.0d0
4923       do j=1,nlobit
4924         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4925         escloc_i=escloc_i+expfac
4926         do k=1,2
4927           dersc(k)=dersc(k)+Ax(k,j)*expfac
4928         enddo
4929         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4930                   +gaussc(1,2,j,it))*expfac
4931         dersc(3)=0.0d0
4932       enddo
4933
4934       dersc(1)=dersc(1)/cos(theti)**2
4935       dersc12=dersc12/cos(theti)**2
4936       escloci=-(dlog(escloc_i)-emin)
4937       do j=1,2
4938         dersc(j)=dersc(j)/escloc_i
4939       enddo
4940       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4941       return
4942       end subroutine enesc_bound
4943 #else
4944 !-----------------------------------------------------------------------------
4945       subroutine esc(escloc)
4946 ! Calculate the local energy of a side chain and its derivatives in the
4947 ! corresponding virtual-bond valence angles THETA and the spherical angles
4948 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
4949 ! added by Urszula Kozlowska. 07/11/2007
4950 !
4951       use comm_sccalc
4952 !      implicit real*8 (a-h,o-z)
4953 !      include 'DIMENSIONS'
4954 !      include 'COMMON.GEO'
4955 !      include 'COMMON.LOCAL'
4956 !      include 'COMMON.VAR'
4957 !      include 'COMMON.SCROT'
4958 !      include 'COMMON.INTERACT'
4959 !      include 'COMMON.DERIV'
4960 !      include 'COMMON.CHAIN'
4961 !      include 'COMMON.IOUNITS'
4962 !      include 'COMMON.NAMES'
4963 !      include 'COMMON.FFIELD'
4964 !      include 'COMMON.CONTROL'
4965 !      include 'COMMON.VECTORS'
4966       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
4967       real(kind=8),dimension(65) :: x
4968       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
4969          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
4970       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
4971       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
4972          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
4973 !el local variables
4974       integer :: i,j,k !el,it,nlobit
4975       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
4976 !el      real(kind=8) :: time11,time12,time112,theti
4977 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
4979                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
4980                    sumene1x,sumene2x,sumene3x,sumene4x,&
4981                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
4982                    cosfac2xx,sinfac2yy
4983 #ifdef DEBUG
4984       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
4985                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
4986                    de_dt_num
4987 #endif
4988 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
4989
4990       delta=0.02d0*pi
4991       escloc=0.0D0
4992       do i=loc_start,loc_end
4993         if (itype(i).eq.ntyp1) cycle
4994         costtab(i+1) =dcos(theta(i+1))
4995         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4996         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4997         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4998         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4999         cosfac=dsqrt(cosfac2)
5000         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5001         sinfac=dsqrt(sinfac2)
5002         it=iabs(itype(i))
5003         if (it.eq.10) goto 1
5004 !
5005 !  Compute the axes of tghe local cartesian coordinates system; store in
5006 !   x_prime, y_prime and z_prime
5007 !
5008         do j=1,3
5009           x_prime(j) = 0.00
5010           y_prime(j) = 0.00
5011           z_prime(j) = 0.00
5012         enddo
5013 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5014 !     &   dc_norm(3,i+nres)
5015         do j = 1,3
5016           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5017           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5018         enddo
5019         do j = 1,3
5020           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5021         enddo
5022 !       write (2,*) "i",i
5023 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5024 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5025 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5026 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5027 !      & " xy",scalar(x_prime(1),y_prime(1)),
5028 !      & " xz",scalar(x_prime(1),z_prime(1)),
5029 !      & " yy",scalar(y_prime(1),y_prime(1)),
5030 !      & " yz",scalar(y_prime(1),z_prime(1)),
5031 !      & " zz",scalar(z_prime(1),z_prime(1))
5032 !
5033 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5034 ! to local coordinate system. Store in xx, yy, zz.
5035 !
5036         xx=0.0d0
5037         yy=0.0d0
5038         zz=0.0d0
5039         do j = 1,3
5040           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5041           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5042           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5043         enddo
5044
5045         xxtab(i)=xx
5046         yytab(i)=yy
5047         zztab(i)=zz
5048 !
5049 ! Compute the energy of the ith side cbain
5050 !
5051 !        write (2,*) "xx",xx," yy",yy," zz",zz
5052         it=iabs(itype(i))
5053         do j = 1,65
5054           x(j) = sc_parmin(j,it)
5055         enddo
5056 #ifdef CHECK_COORD
5057 !c diagnostics - remove later
5058         xx1 = dcos(alph(2))
5059         yy1 = dsin(alph(2))*dcos(omeg(2))
5060         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5061         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5062           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5063           xx1,yy1,zz1
5064 !,"  --- ", xx_w,yy_w,zz_w
5065 ! end diagnostics
5066 #endif
5067         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5068          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5069          + x(10)*yy*zz
5070         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5071          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5072          + x(20)*yy*zz
5073         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5074          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5075          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5076          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5077          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5078          +x(40)*xx*yy*zz
5079         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5080          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5081          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5082          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5083          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5084          +x(60)*xx*yy*zz
5085         dsc_i   = 0.743d0+x(61)
5086         dp2_i   = 1.9d0+x(62)
5087         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5088                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5089         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5090                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5091         s1=(1+x(63))/(0.1d0 + dscp1)
5092         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5093         s2=(1+x(65))/(0.1d0 + dscp2)
5094         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5095         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5096       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5097 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5098 !     &   sumene4,
5099 !     &   dscp1,dscp2,sumene
5100 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5101         escloc = escloc + sumene
5102 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5103 !     & ,zz,xx,yy
5104 !#define DEBUG
5105 #ifdef DEBUG
5106 !
5107 ! This section to check the numerical derivatives of the energy of ith side
5108 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5109 ! #define DEBUG in the code to turn it on.
5110 !
5111         write (2,*) "sumene               =",sumene
5112         aincr=1.0d-7
5113         xxsave=xx
5114         xx=xx+aincr
5115         write (2,*) xx,yy,zz
5116         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5117         de_dxx_num=(sumenep-sumene)/aincr
5118         xx=xxsave
5119         write (2,*) "xx+ sumene from enesc=",sumenep
5120         yysave=yy
5121         yy=yy+aincr
5122         write (2,*) xx,yy,zz
5123         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5124         de_dyy_num=(sumenep-sumene)/aincr
5125         yy=yysave
5126         write (2,*) "yy+ sumene from enesc=",sumenep
5127         zzsave=zz
5128         zz=zz+aincr
5129         write (2,*) xx,yy,zz
5130         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5131         de_dzz_num=(sumenep-sumene)/aincr
5132         zz=zzsave
5133         write (2,*) "zz+ sumene from enesc=",sumenep
5134         costsave=cost2tab(i+1)
5135         sintsave=sint2tab(i+1)
5136         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5137         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5138         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5139         de_dt_num=(sumenep-sumene)/aincr
5140         write (2,*) " t+ sumene from enesc=",sumenep
5141         cost2tab(i+1)=costsave
5142         sint2tab(i+1)=sintsave
5143 ! End of diagnostics section.
5144 #endif
5145 !
5146 ! Compute the gradient of esc
5147 !
5148 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5149         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5150         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5151         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5152         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5153         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5154         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5155         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5156         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5157         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5158            *(pom_s1/dscp1+pom_s16*dscp1**4)
5159         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5160            *(pom_s2/dscp2+pom_s26*dscp2**4)
5161         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5162         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5163         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5164         +x(40)*yy*zz
5165         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5166         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5167         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5168         +x(60)*yy*zz
5169         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5170               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5171               +(pom1+pom2)*pom_dx
5172 #ifdef DEBUG
5173         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5174 #endif
5175 !
5176         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5177         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5178         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5179         +x(40)*xx*zz
5180         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5181         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5182         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5183         +x(59)*zz**2 +x(60)*xx*zz
5184         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5185               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5186               +(pom1-pom2)*pom_dy
5187 #ifdef DEBUG
5188         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5189 #endif
5190 !
5191         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5192         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5193         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5194         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5195         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5196         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5197         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5198         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5199 #ifdef DEBUG
5200         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5201 #endif
5202 !
5203         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5204         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5205         +pom1*pom_dt1+pom2*pom_dt2
5206 #ifdef DEBUG
5207         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5208 #endif
5209 !
5210 !
5211        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5212        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5213        cosfac2xx=cosfac2*xx
5214        sinfac2yy=sinfac2*yy
5215        do k = 1,3
5216          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5217             vbld_inv(i+1)
5218          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5219             vbld_inv(i)
5220          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5221          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5222 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5223 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5224 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5225 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5226          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5227          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5228          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5229          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5230          dZZ_Ci1(k)=0.0d0
5231          dZZ_Ci(k)=0.0d0
5232          do j=1,3
5233            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5234            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5235            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5236            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5237          enddo
5238
5239          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5240          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5241          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5242          (z_prime(k)-zz*dC_norm(k,i+nres))
5243 !
5244          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5245          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5246        enddo
5247
5248        do k=1,3
5249          dXX_Ctab(k,i)=dXX_Ci(k)
5250          dXX_C1tab(k,i)=dXX_Ci1(k)
5251          dYY_Ctab(k,i)=dYY_Ci(k)
5252          dYY_C1tab(k,i)=dYY_Ci1(k)
5253          dZZ_Ctab(k,i)=dZZ_Ci(k)
5254          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5255          dXX_XYZtab(k,i)=dXX_XYZ(k)
5256          dYY_XYZtab(k,i)=dYY_XYZ(k)
5257          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5258        enddo
5259
5260        do k = 1,3
5261 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5262 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5263 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5264 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5265 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5266 !     &    dt_dci(k)
5267 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5268 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5269          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5270           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5271          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5272           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5273          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5274           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5275        enddo
5276 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5277 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5278
5279 ! to check gradient call subroutine check_grad
5280
5281     1 continue
5282       enddo
5283       return
5284       end subroutine esc
5285 !-----------------------------------------------------------------------------
5286       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5287 !      implicit none
5288       real(kind=8),dimension(65) :: x
5289       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5290         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5291
5292       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5293         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5294         + x(10)*yy*zz
5295       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5296         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5297         + x(20)*yy*zz
5298       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5299         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5300         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5301         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5302         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5303         +x(40)*xx*yy*zz
5304       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5305         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5306         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5307         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5308         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5309         +x(60)*xx*yy*zz
5310       dsc_i   = 0.743d0+x(61)
5311       dp2_i   = 1.9d0+x(62)
5312       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5313                 *(xx*cost2+yy*sint2))
5314       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5315                 *(xx*cost2-yy*sint2))
5316       s1=(1+x(63))/(0.1d0 + dscp1)
5317       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5318       s2=(1+x(65))/(0.1d0 + dscp2)
5319       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5320       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5321        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5322       enesc=sumene
5323       return
5324       end function enesc
5325 #endif
5326 !-----------------------------------------------------------------------------
5327       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5328 !
5329 ! This procedure calculates two-body contact function g(rij) and its derivative:
5330 !
5331 !           eps0ij                                     !       x < -1
5332 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5333 !            0                                         !       x > 1
5334 !
5335 ! where x=(rij-r0ij)/delta
5336 !
5337 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5338 !
5339 !      implicit none
5340       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5341       real(kind=8) :: x,x2,x4,delta
5342 !     delta=0.02D0*r0ij
5343 !      delta=0.2D0*r0ij
5344       x=(rij-r0ij)/delta
5345       if (x.lt.-1.0D0) then
5346         fcont=eps0ij
5347         fprimcont=0.0D0
5348       else if (x.le.1.0D0) then
5349         x2=x*x
5350         x4=x2*x2
5351         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5352         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5353       else
5354         fcont=0.0D0
5355         fprimcont=0.0D0
5356       endif
5357       return
5358       end subroutine gcont
5359 !-----------------------------------------------------------------------------
5360       subroutine splinthet(theti,delta,ss,ssder)
5361 !      implicit real*8 (a-h,o-z)
5362 !      include 'DIMENSIONS'
5363 !      include 'COMMON.VAR'
5364 !      include 'COMMON.GEO'
5365       real(kind=8) :: theti,delta,ss,ssder
5366       real(kind=8) :: thetup,thetlow
5367       thetup=pi-delta
5368       thetlow=delta
5369       if (theti.gt.pipol) then
5370         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5371       else
5372         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5373         ssder=-ssder
5374       endif
5375       return
5376       end subroutine splinthet
5377 !-----------------------------------------------------------------------------
5378       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5379 !      implicit none
5380       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5381       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5382       a1=fprim0*delta/(f1-f0)
5383       a2=3.0d0-2.0d0*a1
5384       a3=a1-2.0d0
5385       ksi=(x-x0)/delta
5386       ksi2=ksi*ksi
5387       ksi3=ksi2*ksi
5388       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5389       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5390       return
5391       end subroutine spline1
5392 !-----------------------------------------------------------------------------
5393       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5394 !      implicit none
5395       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5396       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5397       ksi=(x-x0)/delta
5398       ksi2=ksi*ksi
5399       ksi3=ksi2*ksi
5400       a1=fprim0x*delta
5401       a2=3*(f1x-f0x)-2*fprim0x*delta
5402       a3=fprim0x*delta-2*(f1x-f0x)
5403       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5404       return
5405       end subroutine spline2
5406 !-----------------------------------------------------------------------------
5407 #ifdef CRYST_TOR
5408 !-----------------------------------------------------------------------------
5409       subroutine etor(etors,edihcnstr)
5410 !      implicit real*8 (a-h,o-z)
5411 !      include 'DIMENSIONS'
5412 !      include 'COMMON.VAR'
5413 !      include 'COMMON.GEO'
5414 !      include 'COMMON.LOCAL'
5415 !      include 'COMMON.TORSION'
5416 !      include 'COMMON.INTERACT'
5417 !      include 'COMMON.DERIV'
5418 !      include 'COMMON.CHAIN'
5419 !      include 'COMMON.NAMES'
5420 !      include 'COMMON.IOUNITS'
5421 !      include 'COMMON.FFIELD'
5422 !      include 'COMMON.TORCNSTR'
5423 !      include 'COMMON.CONTROL'
5424       real(kind=8) :: etors,edihcnstr
5425       logical :: lprn
5426 !el local variables
5427       integer :: i,j,
5428       real(kind=8) :: phii,fac,etors_ii
5429
5430 ! Set lprn=.true. for debugging
5431       lprn=.false.
5432 !      lprn=.true.
5433       etors=0.0D0
5434       do i=iphi_start,iphi_end
5435       etors_ii=0.0D0
5436         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5437             .or. itype(i).eq.ntyp1) cycle
5438         itori=itortyp(itype(i-2))
5439         itori1=itortyp(itype(i-1))
5440         phii=phi(i)
5441         gloci=0.0D0
5442 ! Proline-Proline pair is a special case...
5443         if (itori.eq.3 .and. itori1.eq.3) then
5444           if (phii.gt.-dwapi3) then
5445             cosphi=dcos(3*phii)
5446             fac=1.0D0/(1.0D0-cosphi)
5447             etorsi=v1(1,3,3)*fac
5448             etorsi=etorsi+etorsi
5449             etors=etors+etorsi-v1(1,3,3)
5450             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5451             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5452           endif
5453           do j=1,3
5454             v1ij=v1(j+1,itori,itori1)
5455             v2ij=v2(j+1,itori,itori1)
5456             cosphi=dcos(j*phii)
5457             sinphi=dsin(j*phii)
5458             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5459             if (energy_dec) etors_ii=etors_ii+ &
5460                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5461             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5462           enddo
5463         else
5464           do j=1,nterm_old
5465             v1ij=v1(j,itori,itori1)
5466             v2ij=v2(j,itori,itori1)
5467             cosphi=dcos(j*phii)
5468             sinphi=dsin(j*phii)
5469             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5470             if (energy_dec) etors_ii=etors_ii+ &
5471                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5472             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5473           enddo
5474         endif
5475         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5476              'etor',i,etors_ii
5477         if (lprn) &
5478         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5479         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5480         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5481         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5482 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5483       enddo
5484 ! 6/20/98 - dihedral angle constraints
5485       edihcnstr=0.0d0
5486       do i=1,ndih_constr
5487         itori=idih_constr(i)
5488         phii=phi(itori)
5489         difi=phii-phi0(i)
5490         if (difi.gt.drange(i)) then
5491           difi=difi-drange(i)
5492           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5493           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5494         else if (difi.lt.-drange(i)) then
5495           difi=difi+drange(i)
5496           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5497           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5498         endif
5499 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5500 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5501       enddo
5502 !      write (iout,*) 'edihcnstr',edihcnstr
5503       return
5504       end subroutine etor
5505 !-----------------------------------------------------------------------------
5506       subroutine etor_d(etors_d)
5507       real(kind=8) :: etors_d
5508       etors_d=0.0d0
5509       return
5510       end subroutine etor_d
5511 #else
5512 !-----------------------------------------------------------------------------
5513       subroutine etor(etors,edihcnstr)
5514 !      implicit real*8 (a-h,o-z)
5515 !      include 'DIMENSIONS'
5516 !      include 'COMMON.VAR'
5517 !      include 'COMMON.GEO'
5518 !      include 'COMMON.LOCAL'
5519 !      include 'COMMON.TORSION'
5520 !      include 'COMMON.INTERACT'
5521 !      include 'COMMON.DERIV'
5522 !      include 'COMMON.CHAIN'
5523 !      include 'COMMON.NAMES'
5524 !      include 'COMMON.IOUNITS'
5525 !      include 'COMMON.FFIELD'
5526 !      include 'COMMON.TORCNSTR'
5527 !      include 'COMMON.CONTROL'
5528       real(kind=8) :: etors,edihcnstr
5529       logical :: lprn
5530 !el local variables
5531       integer :: i,j,iblock,itori,itori1
5532       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5533                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5534 ! Set lprn=.true. for debugging
5535       lprn=.false.
5536 !     lprn=.true.
5537       etors=0.0D0
5538       do i=iphi_start,iphi_end
5539         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5540              .or. itype(i).eq.ntyp1) cycle
5541         etors_ii=0.0D0
5542          if (iabs(itype(i)).eq.20) then
5543          iblock=2
5544          else
5545          iblock=1
5546          endif
5547         itori=itortyp(itype(i-2))
5548         itori1=itortyp(itype(i-1))
5549         phii=phi(i)
5550         gloci=0.0D0
5551 ! Regular cosine and sine terms
5552         do j=1,nterm(itori,itori1,iblock)
5553           v1ij=v1(j,itori,itori1,iblock)
5554           v2ij=v2(j,itori,itori1,iblock)
5555           cosphi=dcos(j*phii)
5556           sinphi=dsin(j*phii)
5557           etors=etors+v1ij*cosphi+v2ij*sinphi
5558           if (energy_dec) etors_ii=etors_ii+ &
5559                      v1ij*cosphi+v2ij*sinphi
5560           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5561         enddo
5562 ! Lorentz terms
5563 !                         v1
5564 !  E = SUM ----------------------------------- - v1
5565 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5566 !
5567         cosphi=dcos(0.5d0*phii)
5568         sinphi=dsin(0.5d0*phii)
5569         do j=1,nlor(itori,itori1,iblock)
5570           vl1ij=vlor1(j,itori,itori1)
5571           vl2ij=vlor2(j,itori,itori1)
5572           vl3ij=vlor3(j,itori,itori1)
5573           pom=vl2ij*cosphi+vl3ij*sinphi
5574           pom1=1.0d0/(pom*pom+1.0d0)
5575           etors=etors+vl1ij*pom1
5576           if (energy_dec) etors_ii=etors_ii+ &
5577                      vl1ij*pom1
5578           pom=-pom*pom1*pom1
5579           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5580         enddo
5581 ! Subtract the constant term
5582         etors=etors-v0(itori,itori1,iblock)
5583           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5584                'etor',i,etors_ii-v0(itori,itori1,iblock)
5585         if (lprn) &
5586         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5587         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5588         (v1(j,itori,itori1,iblock),j=1,6),&
5589         (v2(j,itori,itori1,iblock),j=1,6)
5590         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5591 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5592       enddo
5593 ! 6/20/98 - dihedral angle constraints
5594       edihcnstr=0.0d0
5595 !      do i=1,ndih_constr
5596       do i=idihconstr_start,idihconstr_end
5597         itori=idih_constr(i)
5598         phii=phi(itori)
5599         difi=pinorm(phii-phi0(i))
5600         if (difi.gt.drange(i)) then
5601           difi=difi-drange(i)
5602           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5603           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5604         else if (difi.lt.-drange(i)) then
5605           difi=difi+drange(i)
5606           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5607           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5608         else
5609           difi=0.0
5610         endif
5611 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5612 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5613 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5614       enddo
5615 !d       write (iout,*) 'edihcnstr',edihcnstr
5616       return
5617       end subroutine etor
5618 !-----------------------------------------------------------------------------
5619       subroutine etor_d(etors_d)
5620 ! 6/23/01 Compute double torsional energy
5621 !      implicit real*8 (a-h,o-z)
5622 !      include 'DIMENSIONS'
5623 !      include 'COMMON.VAR'
5624 !      include 'COMMON.GEO'
5625 !      include 'COMMON.LOCAL'
5626 !      include 'COMMON.TORSION'
5627 !      include 'COMMON.INTERACT'
5628 !      include 'COMMON.DERIV'
5629 !      include 'COMMON.CHAIN'
5630 !      include 'COMMON.NAMES'
5631 !      include 'COMMON.IOUNITS'
5632 !      include 'COMMON.FFIELD'
5633 !      include 'COMMON.TORCNSTR'
5634       real(kind=8) :: etors_d,etors_d_ii
5635       logical :: lprn
5636 !el local variables
5637       integer :: i,j,k,l,itori,itori1,itori2,iblock
5638       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5639                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5640                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5641                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5642 ! Set lprn=.true. for debugging
5643       lprn=.false.
5644 !     lprn=.true.
5645       etors_d=0.0D0
5646 !      write(iout,*) "a tu??"
5647       do i=iphid_start,iphid_end
5648         etors_d_ii=0.0D0
5649         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5650             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5651         itori=itortyp(itype(i-2))
5652         itori1=itortyp(itype(i-1))
5653         itori2=itortyp(itype(i))
5654         phii=phi(i)
5655         phii1=phi(i+1)
5656         gloci1=0.0D0
5657         gloci2=0.0D0
5658         iblock=1
5659         if (iabs(itype(i+1)).eq.20) iblock=2
5660
5661 ! Regular cosine and sine terms
5662         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5663           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5664           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5665           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5666           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5667           cosphi1=dcos(j*phii)
5668           sinphi1=dsin(j*phii)
5669           cosphi2=dcos(j*phii1)
5670           sinphi2=dsin(j*phii1)
5671           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5672            v2cij*cosphi2+v2sij*sinphi2
5673           if (energy_dec) etors_d_ii=etors_d_ii+ &
5674            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5675           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5676           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5677         enddo
5678         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5679           do l=1,k-1
5680             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5681             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5682             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5683             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5684             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5685             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5686             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5687             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5688             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5689               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5690             if (energy_dec) etors_d_ii=etors_d_ii+ &
5691               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5692               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5693             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5694               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5695             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5696               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5697           enddo
5698         enddo
5699         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5700                             'etor_d',i,etors_d_ii
5701         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5702         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5703       enddo
5704       return
5705       end subroutine etor_d
5706 #endif
5707 !-----------------------------------------------------------------------------
5708       subroutine eback_sc_corr(esccor)
5709 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5710 !        conformational states; temporarily implemented as differences
5711 !        between UNRES torsional potentials (dependent on three types of
5712 !        residues) and the torsional potentials dependent on all 20 types
5713 !        of residues computed from AM1  energy surfaces of terminally-blocked
5714 !        amino-acid residues.
5715 !      implicit real*8 (a-h,o-z)
5716 !      include 'DIMENSIONS'
5717 !      include 'COMMON.VAR'
5718 !      include 'COMMON.GEO'
5719 !      include 'COMMON.LOCAL'
5720 !      include 'COMMON.TORSION'
5721 !      include 'COMMON.SCCOR'
5722 !      include 'COMMON.INTERACT'
5723 !      include 'COMMON.DERIV'
5724 !      include 'COMMON.CHAIN'
5725 !      include 'COMMON.NAMES'
5726 !      include 'COMMON.IOUNITS'
5727 !      include 'COMMON.FFIELD'
5728 !      include 'COMMON.CONTROL'
5729       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5730                    cosphi,sinphi
5731       logical :: lprn
5732       integer :: i,interty,j,isccori,isccori1,intertyp
5733 ! Set lprn=.true. for debugging
5734       lprn=.false.
5735 !      lprn=.true.
5736 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5737       esccor=0.0D0
5738       do i=itau_start,itau_end
5739         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5740         esccor_ii=0.0D0
5741         isccori=isccortyp(itype(i-2))
5742         isccori1=isccortyp(itype(i-1))
5743
5744 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5745         phii=phi(i)
5746         do intertyp=1,3 !intertyp
5747          esccor_ii=0.0D0
5748 !c Added 09 May 2012 (Adasko)
5749 !c  Intertyp means interaction type of backbone mainchain correlation:
5750 !   1 = SC...Ca...Ca...Ca
5751 !   2 = Ca...Ca...Ca...SC
5752 !   3 = SC...Ca...Ca...SCi
5753         gloci=0.0D0
5754         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5755             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5756             (itype(i-1).eq.ntyp1))) &
5757           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5758            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5759            .or.(itype(i).eq.ntyp1))) &
5760           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5761             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5762             (itype(i-3).eq.ntyp1)))) cycle
5763         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5764         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5765        cycle
5766        do j=1,nterm_sccor(isccori,isccori1)
5767           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5768           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5769           cosphi=dcos(j*tauangle(intertyp,i))
5770           sinphi=dsin(j*tauangle(intertyp,i))
5771           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5772           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5773           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5774         enddo
5775         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5776                                 'esccor',i,intertyp,esccor_ii
5777 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5778         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5779         if (lprn) &
5780         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5781         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5782         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5783         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5784         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5785        enddo !intertyp
5786       enddo
5787
5788       return
5789       end subroutine eback_sc_corr
5790 !-----------------------------------------------------------------------------
5791       subroutine multibody(ecorr)
5792 ! This subroutine calculates multi-body contributions to energy following
5793 ! the idea of Skolnick et al. If side chains I and J make a contact and
5794 ! at the same time side chains I+1 and J+1 make a contact, an extra
5795 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5796 !      implicit real*8 (a-h,o-z)
5797 !      include 'DIMENSIONS'
5798 !      include 'COMMON.IOUNITS'
5799 !      include 'COMMON.DERIV'
5800 !      include 'COMMON.INTERACT'
5801 !      include 'COMMON.CONTACTS'
5802       real(kind=8),dimension(3) :: gx,gx1
5803       logical :: lprn
5804       real(kind=8) :: ecorr
5805       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5806 ! Set lprn=.true. for debugging
5807       lprn=.false.
5808
5809       if (lprn) then
5810         write (iout,'(a)') 'Contact function values:'
5811         do i=nnt,nct-2
5812           write (iout,'(i2,20(1x,i2,f10.5))') &
5813               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5814         enddo
5815       endif
5816       ecorr=0.0D0
5817
5818 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5819 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5820       do i=nnt,nct
5821         do j=1,3
5822           gradcorr(j,i)=0.0D0
5823           gradxorr(j,i)=0.0D0
5824         enddo
5825       enddo
5826       do i=nnt,nct-2
5827
5828         DO ISHIFT = 3,4
5829
5830         i1=i+ishift
5831         num_conti=num_cont(i)
5832         num_conti1=num_cont(i1)
5833         do jj=1,num_conti
5834           j=jcont(jj,i)
5835           do kk=1,num_conti1
5836             j1=jcont(kk,i1)
5837             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5838 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5839 !d   &                   ' ishift=',ishift
5840 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5841 ! The system gains extra energy.
5842               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5843             endif   ! j1==j+-ishift
5844           enddo     ! kk
5845         enddo       ! jj
5846
5847         ENDDO ! ISHIFT
5848
5849       enddo         ! i
5850       return
5851       end subroutine multibody
5852 !-----------------------------------------------------------------------------
5853       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5854 !      implicit real*8 (a-h,o-z)
5855 !      include 'DIMENSIONS'
5856 !      include 'COMMON.IOUNITS'
5857 !      include 'COMMON.DERIV'
5858 !      include 'COMMON.INTERACT'
5859 !      include 'COMMON.CONTACTS'
5860       real(kind=8),dimension(3) :: gx,gx1
5861       logical :: lprn
5862       integer :: i,j,k,l,jj,kk,m,ll
5863       real(kind=8) :: eij,ekl
5864       lprn=.false.
5865       eij=facont(jj,i)
5866       ekl=facont(kk,k)
5867 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5868 ! Calculate the multi-body contribution to energy.
5869 ! Calculate multi-body contributions to the gradient.
5870 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5871 !d   & k,l,(gacont(m,kk,k),m=1,3)
5872       do m=1,3
5873         gx(m) =ekl*gacont(m,jj,i)
5874         gx1(m)=eij*gacont(m,kk,k)
5875         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5876         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5877         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5878         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5879       enddo
5880       do m=i,j-1
5881         do ll=1,3
5882           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5883         enddo
5884       enddo
5885       do m=k,l-1
5886         do ll=1,3
5887           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5888         enddo
5889       enddo
5890       esccorr=-eij*ekl
5891       return
5892       end function esccorr
5893 !-----------------------------------------------------------------------------
5894       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5895 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5896 !      implicit real*8 (a-h,o-z)
5897 !      include 'DIMENSIONS'
5898 !      include 'COMMON.IOUNITS'
5899 #ifdef MPI
5900       include "mpif.h"
5901 !      integer :: maxconts !max_cont=maxconts  =nres/4
5902       integer,parameter :: max_dim=26
5903       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5904       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5905 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5906 !el      common /przechowalnia/ zapas
5907       integer :: status(MPI_STATUS_SIZE)
5908       integer,dimension((nres/4)*2) :: req !maxconts*2
5909       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5910 #endif
5911 !      include 'COMMON.SETUP'
5912 !      include 'COMMON.FFIELD'
5913 !      include 'COMMON.DERIV'
5914 !      include 'COMMON.INTERACT'
5915 !      include 'COMMON.CONTACTS'
5916 !      include 'COMMON.CONTROL'
5917 !      include 'COMMON.LOCAL'
5918       real(kind=8),dimension(3) :: gx,gx1
5919       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5920       logical :: lprn,ldone
5921 !el local variables
5922       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5923               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5924
5925 ! Set lprn=.true. for debugging
5926       lprn=.false.
5927 #ifdef MPI
5928 !      maxconts=nres/4
5929       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
5930       n_corr=0
5931       n_corr1=0
5932       if (nfgtasks.le.1) goto 30
5933       if (lprn) then
5934         write (iout,'(a)') 'Contact function values before RECEIVE:'
5935         do i=nnt,nct-2
5936           write (iout,'(2i3,50(1x,i2,f5.2))') &
5937           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
5938           j=1,num_cont_hb(i))
5939         enddo
5940       endif
5941       call flush(iout)
5942       do i=1,ntask_cont_from
5943         ncont_recv(i)=0
5944       enddo
5945       do i=1,ntask_cont_to
5946         ncont_sent(i)=0
5947       enddo
5948 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5949 !     & ntask_cont_to
5950 ! Make the list of contacts to send to send to other procesors
5951 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5952 !      call flush(iout)
5953       do i=iturn3_start,iturn3_end
5954 !        write (iout,*) "make contact list turn3",i," num_cont",
5955 !     &    num_cont_hb(i)
5956         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5957       enddo
5958       do i=iturn4_start,iturn4_end
5959 !        write (iout,*) "make contact list turn4",i," num_cont",
5960 !     &   num_cont_hb(i)
5961         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5962       enddo
5963       do ii=1,nat_sent
5964         i=iat_sent(ii)
5965 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
5966 !     &    num_cont_hb(i)
5967         do j=1,num_cont_hb(i)
5968         do k=1,4
5969           jjc=jcont_hb(j,i)
5970           iproc=iint_sent_local(k,jjc,ii)
5971 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5972           if (iproc.gt.0) then
5973             ncont_sent(iproc)=ncont_sent(iproc)+1
5974             nn=ncont_sent(iproc)
5975             zapas(1,nn,iproc)=i
5976             zapas(2,nn,iproc)=jjc
5977             zapas(3,nn,iproc)=facont_hb(j,i)
5978             zapas(4,nn,iproc)=ees0p(j,i)
5979             zapas(5,nn,iproc)=ees0m(j,i)
5980             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5981             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5982             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5983             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5984             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5985             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5986             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5987             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5988             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5989             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5990             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5991             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5992             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5993             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5994             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5995             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5996             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5997             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5998             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5999             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6000             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6001           endif
6002         enddo
6003         enddo
6004       enddo
6005       if (lprn) then
6006       write (iout,*) &
6007         "Numbers of contacts to be sent to other processors",&
6008         (ncont_sent(i),i=1,ntask_cont_to)
6009       write (iout,*) "Contacts sent"
6010       do ii=1,ntask_cont_to
6011         nn=ncont_sent(ii)
6012         iproc=itask_cont_to(ii)
6013         write (iout,*) nn," contacts to processor",iproc,&
6014          " of CONT_TO_COMM group"
6015         do i=1,nn
6016           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6017         enddo
6018       enddo
6019       call flush(iout)
6020       endif
6021       CorrelType=477
6022       CorrelID=fg_rank+1
6023       CorrelType1=478
6024       CorrelID1=nfgtasks+fg_rank+1
6025       ireq=0
6026 ! Receive the numbers of needed contacts from other processors
6027       do ii=1,ntask_cont_from
6028         iproc=itask_cont_from(ii)
6029         ireq=ireq+1
6030         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6031           FG_COMM,req(ireq),IERR)
6032       enddo
6033 !      write (iout,*) "IRECV ended"
6034 !      call flush(iout)
6035 ! Send the number of contacts needed by other processors
6036       do ii=1,ntask_cont_to
6037         iproc=itask_cont_to(ii)
6038         ireq=ireq+1
6039         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6040           FG_COMM,req(ireq),IERR)
6041       enddo
6042 !      write (iout,*) "ISEND ended"
6043 !      write (iout,*) "number of requests (nn)",ireq
6044       call flush(iout)
6045       if (ireq.gt.0) &
6046         call MPI_Waitall(ireq,req,status_array,ierr)
6047 !      write (iout,*)
6048 !     &  "Numbers of contacts to be received from other processors",
6049 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6050 !      call flush(iout)
6051 ! Receive contacts
6052       ireq=0
6053       do ii=1,ntask_cont_from
6054         iproc=itask_cont_from(ii)
6055         nn=ncont_recv(ii)
6056 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6057 !     &   " of CONT_TO_COMM group"
6058         call flush(iout)
6059         if (nn.gt.0) then
6060           ireq=ireq+1
6061           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6062           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6063 !          write (iout,*) "ireq,req",ireq,req(ireq)
6064         endif
6065       enddo
6066 ! Send the contacts to processors that need them
6067       do ii=1,ntask_cont_to
6068         iproc=itask_cont_to(ii)
6069         nn=ncont_sent(ii)
6070 !        write (iout,*) nn," contacts to processor",iproc,
6071 !     &   " of CONT_TO_COMM group"
6072         if (nn.gt.0) then
6073           ireq=ireq+1
6074           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6075             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6076 !          write (iout,*) "ireq,req",ireq,req(ireq)
6077 !          do i=1,nn
6078 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6079 !          enddo
6080         endif
6081       enddo
6082 !      write (iout,*) "number of requests (contacts)",ireq
6083 !      write (iout,*) "req",(req(i),i=1,4)
6084 !      call flush(iout)
6085       if (ireq.gt.0) &
6086        call MPI_Waitall(ireq,req,status_array,ierr)
6087       do iii=1,ntask_cont_from
6088         iproc=itask_cont_from(iii)
6089         nn=ncont_recv(iii)
6090         if (lprn) then
6091         write (iout,*) "Received",nn," contacts from processor",iproc,&
6092          " of CONT_FROM_COMM group"
6093         call flush(iout)
6094         do i=1,nn
6095           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6096         enddo
6097         call flush(iout)
6098         endif
6099         do i=1,nn
6100           ii=zapas_recv(1,i,iii)
6101 ! Flag the received contacts to prevent double-counting
6102           jj=-zapas_recv(2,i,iii)
6103 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6104 !          call flush(iout)
6105           nnn=num_cont_hb(ii)+1
6106           num_cont_hb(ii)=nnn
6107           jcont_hb(nnn,ii)=jj
6108           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6109           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6110           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6111           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6112           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6113           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6114           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6115           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6116           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6117           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6118           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6119           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6120           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6121           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6122           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6123           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6124           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6125           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6126           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6127           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6128           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6129           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6130           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6131           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6132         enddo
6133       enddo
6134       call flush(iout)
6135       if (lprn) then
6136         write (iout,'(a)') 'Contact function values after receive:'
6137         do i=nnt,nct-2
6138           write (iout,'(2i3,50(1x,i3,f5.2))') &
6139           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6140           j=1,num_cont_hb(i))
6141         enddo
6142         call flush(iout)
6143       endif
6144    30 continue
6145 #endif
6146       if (lprn) then
6147         write (iout,'(a)') 'Contact function values:'
6148         do i=nnt,nct-2
6149           write (iout,'(2i3,50(1x,i3,f5.2))') &
6150           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6151           j=1,num_cont_hb(i))
6152         enddo
6153       endif
6154       ecorr=0.0D0
6155
6156 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6157 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6158 ! Remove the loop below after debugging !!!
6159       do i=nnt,nct
6160         do j=1,3
6161           gradcorr(j,i)=0.0D0
6162           gradxorr(j,i)=0.0D0
6163         enddo
6164       enddo
6165 ! Calculate the local-electrostatic correlation terms
6166       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6167         i1=i+1
6168         num_conti=num_cont_hb(i)
6169         num_conti1=num_cont_hb(i+1)
6170         do jj=1,num_conti
6171           j=jcont_hb(jj,i)
6172           jp=iabs(j)
6173           do kk=1,num_conti1
6174             j1=jcont_hb(kk,i1)
6175             jp1=iabs(j1)
6176 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6177 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6178             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6179                 .or. j.lt.0 .and. j1.gt.0) .and. &
6180                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6181 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6182 ! The system gains extra energy.
6183               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6184               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6185                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6186               n_corr=n_corr+1
6187             else if (j1.eq.j) then
6188 ! Contacts I-J and I-(J+1) occur simultaneously.
6189 ! The system loses extra energy.
6190 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6191             endif
6192           enddo ! kk
6193           do kk=1,num_conti
6194             j1=jcont_hb(kk,i)
6195 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6196 !    &         ' jj=',jj,' kk=',kk
6197             if (j1.eq.j+1) then
6198 ! Contacts I-J and (I+1)-J occur simultaneously.
6199 ! The system loses extra energy.
6200 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6201             endif ! j1==j+1
6202           enddo ! kk
6203         enddo ! jj
6204       enddo ! i
6205       return
6206       end subroutine multibody_hb
6207 !-----------------------------------------------------------------------------
6208       subroutine add_hb_contact(ii,jj,itask)
6209 !      implicit real*8 (a-h,o-z)
6210 !      include "DIMENSIONS"
6211 !      include "COMMON.IOUNITS"
6212 !      include "COMMON.CONTACTS"
6213 !      integer,parameter :: maxconts=nres/4
6214       integer,parameter :: max_dim=26
6215       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6216 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6217 !      common /przechowalnia/ zapas
6218       integer :: i,j,ii,jj,iproc,nn,jjc
6219       integer,dimension(4) :: itask
6220 !      write (iout,*) "itask",itask
6221       do i=1,2
6222         iproc=itask(i)
6223         if (iproc.gt.0) then
6224           do j=1,num_cont_hb(ii)
6225             jjc=jcont_hb(j,ii)
6226 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6227             if (jjc.eq.jj) then
6228               ncont_sent(iproc)=ncont_sent(iproc)+1
6229               nn=ncont_sent(iproc)
6230               zapas(1,nn,iproc)=ii
6231               zapas(2,nn,iproc)=jjc
6232               zapas(3,nn,iproc)=facont_hb(j,ii)
6233               zapas(4,nn,iproc)=ees0p(j,ii)
6234               zapas(5,nn,iproc)=ees0m(j,ii)
6235               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6236               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6237               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6238               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6239               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6240               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6241               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6242               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6243               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6244               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6245               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6246               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6247               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6248               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6249               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6250               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6251               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6252               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6253               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6254               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6255               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6256               exit
6257             endif
6258           enddo
6259         endif
6260       enddo
6261       return
6262       end subroutine add_hb_contact
6263 !-----------------------------------------------------------------------------
6264       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6265 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6266 !      implicit real*8 (a-h,o-z)
6267 !      include 'DIMENSIONS'
6268 !      include 'COMMON.IOUNITS'
6269       integer,parameter :: max_dim=70
6270 #ifdef MPI
6271       include "mpif.h"
6272 !      integer :: maxconts !max_cont=maxconts=nres/4
6273       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6274       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6275 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6276 !      common /przechowalnia/ zapas
6277       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6278         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6279         ierr,iii,nnn
6280 #endif
6281 !      include 'COMMON.SETUP'
6282 !      include 'COMMON.FFIELD'
6283 !      include 'COMMON.DERIV'
6284 !      include 'COMMON.LOCAL'
6285 !      include 'COMMON.INTERACT'
6286 !      include 'COMMON.CONTACTS'
6287 !      include 'COMMON.CHAIN'
6288 !      include 'COMMON.CONTROL'
6289       real(kind=8),dimension(3) :: gx,gx1
6290       integer,dimension(nres) :: num_cont_hb_old
6291       logical :: lprn,ldone
6292 !EL      double precision eello4,eello5,eelo6,eello_turn6
6293 !EL      external eello4,eello5,eello6,eello_turn6
6294 !el local variables
6295       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6296               j1,jp1,i1,num_conti1
6297       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6298       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6299
6300 ! Set lprn=.true. for debugging
6301       lprn=.false.
6302       eturn6=0.0d0
6303 #ifdef MPI
6304 !      maxconts=nres/4
6305       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6306       do i=1,nres
6307         num_cont_hb_old(i)=num_cont_hb(i)
6308       enddo
6309       n_corr=0
6310       n_corr1=0
6311       if (nfgtasks.le.1) goto 30
6312       if (lprn) then
6313         write (iout,'(a)') 'Contact function values before RECEIVE:'
6314         do i=nnt,nct-2
6315           write (iout,'(2i3,50(1x,i2,f5.2))') &
6316           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6317           j=1,num_cont_hb(i))
6318         enddo
6319       endif
6320       call flush(iout)
6321       do i=1,ntask_cont_from
6322         ncont_recv(i)=0
6323       enddo
6324       do i=1,ntask_cont_to
6325         ncont_sent(i)=0
6326       enddo
6327 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6328 !     & ntask_cont_to
6329 ! Make the list of contacts to send to send to other procesors
6330       do i=iturn3_start,iturn3_end
6331 !        write (iout,*) "make contact list turn3",i," num_cont",
6332 !     &    num_cont_hb(i)
6333         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6334       enddo
6335       do i=iturn4_start,iturn4_end
6336 !        write (iout,*) "make contact list turn4",i," num_cont",
6337 !     &   num_cont_hb(i)
6338         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6339       enddo
6340       do ii=1,nat_sent
6341         i=iat_sent(ii)
6342 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6343 !     &    num_cont_hb(i)
6344         do j=1,num_cont_hb(i)
6345         do k=1,4
6346           jjc=jcont_hb(j,i)
6347           iproc=iint_sent_local(k,jjc,ii)
6348 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6349           if (iproc.ne.0) then
6350             ncont_sent(iproc)=ncont_sent(iproc)+1
6351             nn=ncont_sent(iproc)
6352             zapas(1,nn,iproc)=i
6353             zapas(2,nn,iproc)=jjc
6354             zapas(3,nn,iproc)=d_cont(j,i)
6355             ind=3
6356             do kk=1,3
6357               ind=ind+1
6358               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6359             enddo
6360             do kk=1,2
6361               do ll=1,2
6362                 ind=ind+1
6363                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6364               enddo
6365             enddo
6366             do jj=1,5
6367               do kk=1,3
6368                 do ll=1,2
6369                   do mm=1,2
6370                     ind=ind+1
6371                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6372                   enddo
6373                 enddo
6374               enddo
6375             enddo
6376           endif
6377         enddo
6378         enddo
6379       enddo
6380       if (lprn) then
6381       write (iout,*) &
6382         "Numbers of contacts to be sent to other processors",&
6383         (ncont_sent(i),i=1,ntask_cont_to)
6384       write (iout,*) "Contacts sent"
6385       do ii=1,ntask_cont_to
6386         nn=ncont_sent(ii)
6387         iproc=itask_cont_to(ii)
6388         write (iout,*) nn," contacts to processor",iproc,&
6389          " of CONT_TO_COMM group"
6390         do i=1,nn
6391           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6392         enddo
6393       enddo
6394       call flush(iout)
6395       endif
6396       CorrelType=477
6397       CorrelID=fg_rank+1
6398       CorrelType1=478
6399       CorrelID1=nfgtasks+fg_rank+1
6400       ireq=0
6401 ! Receive the numbers of needed contacts from other processors
6402       do ii=1,ntask_cont_from
6403         iproc=itask_cont_from(ii)
6404         ireq=ireq+1
6405         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6406           FG_COMM,req(ireq),IERR)
6407       enddo
6408 !      write (iout,*) "IRECV ended"
6409 !      call flush(iout)
6410 ! Send the number of contacts needed by other processors
6411       do ii=1,ntask_cont_to
6412         iproc=itask_cont_to(ii)
6413         ireq=ireq+1
6414         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6415           FG_COMM,req(ireq),IERR)
6416       enddo
6417 !      write (iout,*) "ISEND ended"
6418 !      write (iout,*) "number of requests (nn)",ireq
6419       call flush(iout)
6420       if (ireq.gt.0) &
6421         call MPI_Waitall(ireq,req,status_array,ierr)
6422 !      write (iout,*)
6423 !     &  "Numbers of contacts to be received from other processors",
6424 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6425 !      call flush(iout)
6426 ! Receive contacts
6427       ireq=0
6428       do ii=1,ntask_cont_from
6429         iproc=itask_cont_from(ii)
6430         nn=ncont_recv(ii)
6431 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6432 !     &   " of CONT_TO_COMM group"
6433         call flush(iout)
6434         if (nn.gt.0) then
6435           ireq=ireq+1
6436           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6437           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6438 !          write (iout,*) "ireq,req",ireq,req(ireq)
6439         endif
6440       enddo
6441 ! Send the contacts to processors that need them
6442       do ii=1,ntask_cont_to
6443         iproc=itask_cont_to(ii)
6444         nn=ncont_sent(ii)
6445 !        write (iout,*) nn," contacts to processor",iproc,
6446 !     &   " of CONT_TO_COMM group"
6447         if (nn.gt.0) then
6448           ireq=ireq+1
6449           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6450             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6451 !          write (iout,*) "ireq,req",ireq,req(ireq)
6452 !          do i=1,nn
6453 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6454 !          enddo
6455         endif
6456       enddo
6457 !      write (iout,*) "number of requests (contacts)",ireq
6458 !      write (iout,*) "req",(req(i),i=1,4)
6459 !      call flush(iout)
6460       if (ireq.gt.0) &
6461        call MPI_Waitall(ireq,req,status_array,ierr)
6462       do iii=1,ntask_cont_from
6463         iproc=itask_cont_from(iii)
6464         nn=ncont_recv(iii)
6465         if (lprn) then
6466         write (iout,*) "Received",nn," contacts from processor",iproc,&
6467          " of CONT_FROM_COMM group"
6468         call flush(iout)
6469         do i=1,nn
6470           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6471         enddo
6472         call flush(iout)
6473         endif
6474         do i=1,nn
6475           ii=zapas_recv(1,i,iii)
6476 ! Flag the received contacts to prevent double-counting
6477           jj=-zapas_recv(2,i,iii)
6478 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6479 !          call flush(iout)
6480           nnn=num_cont_hb(ii)+1
6481           num_cont_hb(ii)=nnn
6482           jcont_hb(nnn,ii)=jj
6483           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6484           ind=3
6485           do kk=1,3
6486             ind=ind+1
6487             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6488           enddo
6489           do kk=1,2
6490             do ll=1,2
6491               ind=ind+1
6492               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6493             enddo
6494           enddo
6495           do jj=1,5
6496             do kk=1,3
6497               do ll=1,2
6498                 do mm=1,2
6499                   ind=ind+1
6500                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6501                 enddo
6502               enddo
6503             enddo
6504           enddo
6505         enddo
6506       enddo
6507       call flush(iout)
6508       if (lprn) then
6509         write (iout,'(a)') 'Contact function values after receive:'
6510         do i=nnt,nct-2
6511           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6512           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6513           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6514         enddo
6515         call flush(iout)
6516       endif
6517    30 continue
6518 #endif
6519       if (lprn) then
6520         write (iout,'(a)') 'Contact function values:'
6521         do i=nnt,nct-2
6522           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6523           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6524           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6525         enddo
6526       endif
6527       ecorr=0.0D0
6528       ecorr5=0.0d0
6529       ecorr6=0.0d0
6530
6531 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6532 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6533 ! Remove the loop below after debugging !!!
6534       do i=nnt,nct
6535         do j=1,3
6536           gradcorr(j,i)=0.0D0
6537           gradxorr(j,i)=0.0D0
6538         enddo
6539       enddo
6540 ! Calculate the dipole-dipole interaction energies
6541       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6542       do i=iatel_s,iatel_e+1
6543         num_conti=num_cont_hb(i)
6544         do jj=1,num_conti
6545           j=jcont_hb(jj,i)
6546 #ifdef MOMENT
6547           call dipole(i,j,jj)
6548 #endif
6549         enddo
6550       enddo
6551       endif
6552 ! Calculate the local-electrostatic correlation terms
6553 !                write (iout,*) "gradcorr5 in eello5 before loop"
6554 !                do iii=1,nres
6555 !                  write (iout,'(i5,3f10.5)')
6556 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6557 !                enddo
6558       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6559 !        write (iout,*) "corr loop i",i
6560         i1=i+1
6561         num_conti=num_cont_hb(i)
6562         num_conti1=num_cont_hb(i+1)
6563         do jj=1,num_conti
6564           j=jcont_hb(jj,i)
6565           jp=iabs(j)
6566           do kk=1,num_conti1
6567             j1=jcont_hb(kk,i1)
6568             jp1=iabs(j1)
6569 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6570 !     &         ' jj=',jj,' kk=',kk
6571 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6572             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6573                 .or. j.lt.0 .and. j1.gt.0) .and. &
6574                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6575 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6576 ! The system gains extra energy.
6577               n_corr=n_corr+1
6578               sqd1=dsqrt(d_cont(jj,i))
6579               sqd2=dsqrt(d_cont(kk,i1))
6580               sred_geom = sqd1*sqd2
6581               IF (sred_geom.lt.cutoff_corr) THEN
6582                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6583                   ekont,fprimcont)
6584 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6585 !d     &         ' jj=',jj,' kk=',kk
6586                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6587                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6588                 do l=1,3
6589                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6590                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6591                 enddo
6592                 n_corr1=n_corr1+1
6593 !d               write (iout,*) 'sred_geom=',sred_geom,
6594 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6595 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6596 !d               write (iout,*) "g_contij",g_contij
6597 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6598 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6599                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6600                 if (wcorr4.gt.0.0d0) &
6601                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6602                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6603                        write (iout,'(a6,4i5,0pf7.3)') &
6604                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6605 !                write (iout,*) "gradcorr5 before eello5"
6606 !                do iii=1,nres
6607 !                  write (iout,'(i5,3f10.5)')
6608 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6609 !                enddo
6610                 if (wcorr5.gt.0.0d0) &
6611                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6612 !                write (iout,*) "gradcorr5 after eello5"
6613 !                do iii=1,nres
6614 !                  write (iout,'(i5,3f10.5)')
6615 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6616 !                enddo
6617                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6618                        write (iout,'(a6,4i5,0pf7.3)') &
6619                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6620 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6621 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6622                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6623                      .or. wturn6.eq.0.0d0))then
6624 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6625                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6626                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6627                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6628 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6629 !d     &            'ecorr6=',ecorr6
6630 !d                write (iout,'(4e15.5)') sred_geom,
6631 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6632 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6633 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6634                 else if (wturn6.gt.0.0d0 &
6635                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6636 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6637                   eturn6=eturn6+eello_turn6(i,jj,kk)
6638                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6639                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6640 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6641                 endif
6642               ENDIF
6643 1111          continue
6644             endif
6645           enddo ! kk
6646         enddo ! jj
6647       enddo ! i
6648       do i=1,nres
6649         num_cont_hb(i)=num_cont_hb_old(i)
6650       enddo
6651 !                write (iout,*) "gradcorr5 in eello5"
6652 !                do iii=1,nres
6653 !                  write (iout,'(i5,3f10.5)')
6654 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6655 !                enddo
6656       return
6657       end subroutine multibody_eello
6658 !-----------------------------------------------------------------------------
6659       subroutine add_hb_contact_eello(ii,jj,itask)
6660 !      implicit real*8 (a-h,o-z)
6661 !      include "DIMENSIONS"
6662 !      include "COMMON.IOUNITS"
6663 !      include "COMMON.CONTACTS"
6664 !      integer,parameter :: maxconts=nres/4
6665       integer,parameter :: max_dim=70
6666       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6667 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6668 !      common /przechowalnia/ zapas
6669
6670       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6671       integer,dimension(4) ::itask
6672 !      write (iout,*) "itask",itask
6673       do i=1,2
6674         iproc=itask(i)
6675         if (iproc.gt.0) then
6676           do j=1,num_cont_hb(ii)
6677             jjc=jcont_hb(j,ii)
6678 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6679             if (jjc.eq.jj) then
6680               ncont_sent(iproc)=ncont_sent(iproc)+1
6681               nn=ncont_sent(iproc)
6682               zapas(1,nn,iproc)=ii
6683               zapas(2,nn,iproc)=jjc
6684               zapas(3,nn,iproc)=d_cont(j,ii)
6685               ind=3
6686               do kk=1,3
6687                 ind=ind+1
6688                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6689               enddo
6690               do kk=1,2
6691                 do ll=1,2
6692                   ind=ind+1
6693                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6694                 enddo
6695               enddo
6696               do jj=1,5
6697                 do kk=1,3
6698                   do ll=1,2
6699                     do mm=1,2
6700                       ind=ind+1
6701                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6702                     enddo
6703                   enddo
6704                 enddo
6705               enddo
6706               exit
6707             endif
6708           enddo
6709         endif
6710       enddo
6711       return
6712       end subroutine add_hb_contact_eello
6713 !-----------------------------------------------------------------------------
6714       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6715 !      implicit real*8 (a-h,o-z)
6716 !      include 'DIMENSIONS'
6717 !      include 'COMMON.IOUNITS'
6718 !      include 'COMMON.DERIV'
6719 !      include 'COMMON.INTERACT'
6720 !      include 'COMMON.CONTACTS'
6721       real(kind=8),dimension(3) :: gx,gx1
6722       logical :: lprn
6723 !el local variables
6724       integer :: i,j,k,l,jj,kk,ll
6725       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6726                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6727                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6728
6729       lprn=.false.
6730       eij=facont_hb(jj,i)
6731       ekl=facont_hb(kk,k)
6732       ees0pij=ees0p(jj,i)
6733       ees0pkl=ees0p(kk,k)
6734       ees0mij=ees0m(jj,i)
6735       ees0mkl=ees0m(kk,k)
6736       ekont=eij*ekl
6737       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6738 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6739 ! Following 4 lines for diagnostics.
6740 !d    ees0pkl=0.0D0
6741 !d    ees0pij=1.0D0
6742 !d    ees0mkl=0.0D0
6743 !d    ees0mij=1.0D0
6744 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6745 !     & 'Contacts ',i,j,
6746 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6747 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6748 !     & 'gradcorr_long'
6749 ! Calculate the multi-body contribution to energy.
6750 !      ecorr=ecorr+ekont*ees
6751 ! Calculate multi-body contributions to the gradient.
6752       coeffpees0pij=coeffp*ees0pij
6753       coeffmees0mij=coeffm*ees0mij
6754       coeffpees0pkl=coeffp*ees0pkl
6755       coeffmees0mkl=coeffm*ees0mkl
6756       do ll=1,3
6757 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6758         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6759         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6760         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6761         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6762         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6763         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6764 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6765         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6766         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6767         coeffmees0mij*gacontm_hb1(ll,kk,k))
6768         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6769         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6770         coeffmees0mij*gacontm_hb2(ll,kk,k))
6771         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6772            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6773            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6774         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6775         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6776         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6777            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6778            coeffmees0mij*gacontm_hb3(ll,kk,k))
6779         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6780         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6781 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6782       enddo
6783 !      write (iout,*)
6784 !grad      do m=i+1,j-1
6785 !grad        do ll=1,3
6786 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6787 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6788 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6789 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6790 !grad        enddo
6791 !grad      enddo
6792 !grad      do m=k+1,l-1
6793 !grad        do ll=1,3
6794 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6795 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6796 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6797 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6798 !grad        enddo
6799 !grad      enddo
6800 !      write (iout,*) "ehbcorr",ekont*ees
6801       ehbcorr=ekont*ees
6802       return
6803       end function ehbcorr
6804 #ifdef MOMENT
6805 !-----------------------------------------------------------------------------
6806       subroutine dipole(i,j,jj)
6807 !      implicit real*8 (a-h,o-z)
6808 !      include 'DIMENSIONS'
6809 !      include 'COMMON.IOUNITS'
6810 !      include 'COMMON.CHAIN'
6811 !      include 'COMMON.FFIELD'
6812 !      include 'COMMON.DERIV'
6813 !      include 'COMMON.INTERACT'
6814 !      include 'COMMON.CONTACTS'
6815 !      include 'COMMON.TORSION'
6816 !      include 'COMMON.VAR'
6817 !      include 'COMMON.GEO'
6818       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6819       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6820       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6821
6822       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6823       allocate(dipderx(3,5,4,maxconts,nres))
6824 !
6825
6826       iti1 = itortyp(itype(i+1))
6827       if (j.lt.nres-1) then
6828         itj1 = itortyp(itype(j+1))
6829       else
6830         itj1=ntortyp+1
6831       endif
6832       do iii=1,2
6833         dipi(iii,1)=Ub2(iii,i)
6834         dipderi(iii)=Ub2der(iii,i)
6835         dipi(iii,2)=b1(iii,iti1)
6836         dipj(iii,1)=Ub2(iii,j)
6837         dipderj(iii)=Ub2der(iii,j)
6838         dipj(iii,2)=b1(iii,itj1)
6839       enddo
6840       kkk=0
6841       do iii=1,2
6842         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6843         do jjj=1,2
6844           kkk=kkk+1
6845           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6846         enddo
6847       enddo
6848       do kkk=1,5
6849         do lll=1,3
6850           mmm=0
6851           do iii=1,2
6852             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6853               auxvec(1))
6854             do jjj=1,2
6855               mmm=mmm+1
6856               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6857             enddo
6858           enddo
6859         enddo
6860       enddo
6861       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6862       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6863       do iii=1,2
6864         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6865       enddo
6866       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6867       do iii=1,2
6868         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6869       enddo
6870       return
6871       end subroutine dipole
6872 #endif
6873 !-----------------------------------------------------------------------------
6874       subroutine calc_eello(i,j,k,l,jj,kk)
6875 !
6876 ! This subroutine computes matrices and vectors needed to calculate
6877 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6878 !
6879       use comm_kut
6880 !      implicit real*8 (a-h,o-z)
6881 !      include 'DIMENSIONS'
6882 !      include 'COMMON.IOUNITS'
6883 !      include 'COMMON.CHAIN'
6884 !      include 'COMMON.DERIV'
6885 !      include 'COMMON.INTERACT'
6886 !      include 'COMMON.CONTACTS'
6887 !      include 'COMMON.TORSION'
6888 !      include 'COMMON.VAR'
6889 !      include 'COMMON.GEO'
6890 !      include 'COMMON.FFIELD'
6891       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6892       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6893       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6894               itj1
6895 !el      logical :: lprn
6896 !el      common /kutas/ lprn
6897 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6898 !d     & ' jj=',jj,' kk=',kk
6899 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6900 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6901 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6902       do iii=1,2
6903         do jjj=1,2
6904           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6905           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6906         enddo
6907       enddo
6908       call transpose2(aa1(1,1),aa1t(1,1))
6909       call transpose2(aa2(1,1),aa2t(1,1))
6910       do kkk=1,5
6911         do lll=1,3
6912           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6913             aa1tder(1,1,lll,kkk))
6914           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6915             aa2tder(1,1,lll,kkk))
6916         enddo
6917       enddo
6918       if (l.eq.j+1) then
6919 ! parallel orientation of the two CA-CA-CA frames.
6920         if (i.gt.1) then
6921           iti=itortyp(itype(i))
6922         else
6923           iti=ntortyp+1
6924         endif
6925         itk1=itortyp(itype(k+1))
6926         itj=itortyp(itype(j))
6927         if (l.lt.nres-1) then
6928           itl1=itortyp(itype(l+1))
6929         else
6930           itl1=ntortyp+1
6931         endif
6932 ! A1 kernel(j+1) A2T
6933 !d        do iii=1,2
6934 !d          write (iout,'(3f10.5,5x,3f10.5)')
6935 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6936 !d        enddo
6937         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6938          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
6939          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6940 ! Following matrices are needed only for 6-th order cumulants
6941         IF (wcorr6.gt.0.0d0) THEN
6942         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6943          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
6944          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6945         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6946          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
6947          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
6948          ADtEAderx(1,1,1,1,1,1))
6949         lprn=.false.
6950         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6951          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
6952          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
6953          ADtEA1derx(1,1,1,1,1,1))
6954         ENDIF
6955 ! End 6-th order cumulants
6956 !d        lprn=.false.
6957 !d        if (lprn) then
6958 !d        write (2,*) 'In calc_eello6'
6959 !d        do iii=1,2
6960 !d          write (2,*) 'iii=',iii
6961 !d          do kkk=1,5
6962 !d            write (2,*) 'kkk=',kkk
6963 !d            do jjj=1,2
6964 !d              write (2,'(3(2f10.5),5x)')
6965 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6966 !d            enddo
6967 !d          enddo
6968 !d        enddo
6969 !d        endif
6970         call transpose2(EUgder(1,1,k),auxmat(1,1))
6971         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6972         call transpose2(EUg(1,1,k),auxmat(1,1))
6973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6974         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6975         do iii=1,2
6976           do kkk=1,5
6977             do lll=1,3
6978               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
6979                 EAEAderx(1,1,lll,kkk,iii,1))
6980             enddo
6981           enddo
6982         enddo
6983 ! A1T kernel(i+1) A2
6984         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6985          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
6986          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6987 ! Following matrices are needed only for 6-th order cumulants
6988         IF (wcorr6.gt.0.0d0) THEN
6989         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6990          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
6991          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6992         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6993          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
6994          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
6995          ADtEAderx(1,1,1,1,1,2))
6996         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6997          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
6998          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
6999          ADtEA1derx(1,1,1,1,1,2))
7000         ENDIF
7001 ! End 6-th order cumulants
7002         call transpose2(EUgder(1,1,l),auxmat(1,1))
7003         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7004         call transpose2(EUg(1,1,l),auxmat(1,1))
7005         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7006         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7007         do iii=1,2
7008           do kkk=1,5
7009             do lll=1,3
7010               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7011                 EAEAderx(1,1,lll,kkk,iii,2))
7012             enddo
7013           enddo
7014         enddo
7015 ! AEAb1 and AEAb2
7016 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7017 ! They are needed only when the fifth- or the sixth-order cumulants are
7018 ! indluded.
7019         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7020         call transpose2(AEA(1,1,1),auxmat(1,1))
7021         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7022         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7023         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7024         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7025         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7026         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7027         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7028         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7029         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7030         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7031         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7032         call transpose2(AEA(1,1,2),auxmat(1,1))
7033         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7034         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7035         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7036         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7037         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7038         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7039         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7040         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7041         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7042         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7043         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7044 ! Calculate the Cartesian derivatives of the vectors.
7045         do iii=1,2
7046           do kkk=1,5
7047             do lll=1,3
7048               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7049               call matvec2(auxmat(1,1),b1(1,iti),&
7050                 AEAb1derx(1,lll,kkk,iii,1,1))
7051               call matvec2(auxmat(1,1),Ub2(1,i),&
7052                 AEAb2derx(1,lll,kkk,iii,1,1))
7053               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7054                 AEAb1derx(1,lll,kkk,iii,2,1))
7055               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7056                 AEAb2derx(1,lll,kkk,iii,2,1))
7057               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7058               call matvec2(auxmat(1,1),b1(1,itj),&
7059                 AEAb1derx(1,lll,kkk,iii,1,2))
7060               call matvec2(auxmat(1,1),Ub2(1,j),&
7061                 AEAb2derx(1,lll,kkk,iii,1,2))
7062               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7063                 AEAb1derx(1,lll,kkk,iii,2,2))
7064               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7065                 AEAb2derx(1,lll,kkk,iii,2,2))
7066             enddo
7067           enddo
7068         enddo
7069         ENDIF
7070 ! End vectors
7071       else
7072 ! Antiparallel orientation of the two CA-CA-CA frames.
7073         if (i.gt.1) then
7074           iti=itortyp(itype(i))
7075         else
7076           iti=ntortyp+1
7077         endif
7078         itk1=itortyp(itype(k+1))
7079         itl=itortyp(itype(l))
7080         itj=itortyp(itype(j))
7081         if (j.lt.nres-1) then
7082           itj1=itortyp(itype(j+1))
7083         else
7084           itj1=ntortyp+1
7085         endif
7086 ! A2 kernel(j-1)T A1T
7087         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7088          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7089          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7090 ! Following matrices are needed only for 6-th order cumulants
7091         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7092            j.eq.i+4 .and. l.eq.i+3)) THEN
7093         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7094          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7095          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7096         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7097          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7098          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7099          ADtEAderx(1,1,1,1,1,1))
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7101          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7102          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7103          ADtEA1derx(1,1,1,1,1,1))
7104         ENDIF
7105 ! End 6-th order cumulants
7106         call transpose2(EUgder(1,1,k),auxmat(1,1))
7107         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7108         call transpose2(EUg(1,1,k),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7110         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7111         do iii=1,2
7112           do kkk=1,5
7113             do lll=1,3
7114               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7115                 EAEAderx(1,1,lll,kkk,iii,1))
7116             enddo
7117           enddo
7118         enddo
7119 ! A2T kernel(i+1)T A1
7120         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7121          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7122          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7123 ! Following matrices are needed only for 6-th order cumulants
7124         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7125            j.eq.i+4 .and. l.eq.i+3)) THEN
7126         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7127          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7128          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7129         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7130          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7131          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7132          ADtEAderx(1,1,1,1,1,2))
7133         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7134          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7135          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7136          ADtEA1derx(1,1,1,1,1,2))
7137         ENDIF
7138 ! End 6-th order cumulants
7139         call transpose2(EUgder(1,1,j),auxmat(1,1))
7140         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7141         call transpose2(EUg(1,1,j),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7143         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7144         do iii=1,2
7145           do kkk=1,5
7146             do lll=1,3
7147               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7148                 EAEAderx(1,1,lll,kkk,iii,2))
7149             enddo
7150           enddo
7151         enddo
7152 ! AEAb1 and AEAb2
7153 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7154 ! They are needed only when the fifth- or the sixth-order cumulants are
7155 ! indluded.
7156         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7157           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7158         call transpose2(AEA(1,1,1),auxmat(1,1))
7159         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7160         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7161         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7162         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7163         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7164         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7165         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7166         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7167         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7168         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7169         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7170         call transpose2(AEA(1,1,2),auxmat(1,1))
7171         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7172         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7173         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7174         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7175         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7176         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7177         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7178         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7179         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7180         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7181         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7182 ! Calculate the Cartesian derivatives of the vectors.
7183         do iii=1,2
7184           do kkk=1,5
7185             do lll=1,3
7186               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7187               call matvec2(auxmat(1,1),b1(1,iti),&
7188                 AEAb1derx(1,lll,kkk,iii,1,1))
7189               call matvec2(auxmat(1,1),Ub2(1,i),&
7190                 AEAb2derx(1,lll,kkk,iii,1,1))
7191               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7192                 AEAb1derx(1,lll,kkk,iii,2,1))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7194                 AEAb2derx(1,lll,kkk,iii,2,1))
7195               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7196               call matvec2(auxmat(1,1),b1(1,itl),&
7197                 AEAb1derx(1,lll,kkk,iii,1,2))
7198               call matvec2(auxmat(1,1),Ub2(1,l),&
7199                 AEAb2derx(1,lll,kkk,iii,1,2))
7200               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7201                 AEAb1derx(1,lll,kkk,iii,2,2))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7203                 AEAb2derx(1,lll,kkk,iii,2,2))
7204             enddo
7205           enddo
7206         enddo
7207         ENDIF
7208 ! End vectors
7209       endif
7210       return
7211       end subroutine calc_eello
7212 !-----------------------------------------------------------------------------
7213       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7214       use comm_kut
7215       implicit none
7216       integer :: nderg
7217       logical :: transp
7218       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7219       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7220       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7221       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7222       integer :: iii,kkk,lll
7223       integer :: jjj,mmm
7224 !el      logical :: lprn
7225 !el      common /kutas/ lprn
7226       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7227       do iii=1,nderg
7228         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7229           AKAderg(1,1,iii))
7230       enddo
7231 !d      if (lprn) write (2,*) 'In kernel'
7232       do kkk=1,5
7233 !d        if (lprn) write (2,*) 'kkk=',kkk
7234         do lll=1,3
7235           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7236             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7237 !d          if (lprn) then
7238 !d            write (2,*) 'lll=',lll
7239 !d            write (2,*) 'iii=1'
7240 !d            do jjj=1,2
7241 !d              write (2,'(3(2f10.5),5x)')
7242 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7243 !d            enddo
7244 !d          endif
7245           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7246             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7247 !d          if (lprn) then
7248 !d            write (2,*) 'lll=',lll
7249 !d            write (2,*) 'iii=2'
7250 !d            do jjj=1,2
7251 !d              write (2,'(3(2f10.5),5x)')
7252 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7253 !d            enddo
7254 !d          endif
7255         enddo
7256       enddo
7257       return
7258       end subroutine kernel
7259 !-----------------------------------------------------------------------------
7260       real(kind=8) function eello4(i,j,k,l,jj,kk)
7261 !      implicit real*8 (a-h,o-z)
7262 !      include 'DIMENSIONS'
7263 !      include 'COMMON.IOUNITS'
7264 !      include 'COMMON.CHAIN'
7265 !      include 'COMMON.DERIV'
7266 !      include 'COMMON.INTERACT'
7267 !      include 'COMMON.CONTACTS'
7268 !      include 'COMMON.TORSION'
7269 !      include 'COMMON.VAR'
7270 !      include 'COMMON.GEO'
7271       real(kind=8),dimension(2,2) :: pizda
7272       real(kind=8),dimension(3) :: ggg1,ggg2
7273       real(kind=8) ::  eel4,glongij,glongkl
7274       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7275 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7276 !d        eello4=0.0d0
7277 !d        return
7278 !d      endif
7279 !d      print *,'eello4:',i,j,k,l,jj,kk
7280 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7281 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7282 !old      eij=facont_hb(jj,i)
7283 !old      ekl=facont_hb(kk,k)
7284 !old      ekont=eij*ekl
7285       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7286 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7287       gcorr_loc(k-1)=gcorr_loc(k-1) &
7288          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7289       if (l.eq.j+1) then
7290         gcorr_loc(l-1)=gcorr_loc(l-1) &
7291            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7292       else
7293         gcorr_loc(j-1)=gcorr_loc(j-1) &
7294            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7295       endif
7296       do iii=1,2
7297         do kkk=1,5
7298           do lll=1,3
7299             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7300                               -EAEAderx(2,2,lll,kkk,iii,1)
7301 !d            derx(lll,kkk,iii)=0.0d0
7302           enddo
7303         enddo
7304       enddo
7305 !d      gcorr_loc(l-1)=0.0d0
7306 !d      gcorr_loc(j-1)=0.0d0
7307 !d      gcorr_loc(k-1)=0.0d0
7308 !d      eel4=1.0d0
7309 !d      write (iout,*)'Contacts have occurred for peptide groups',
7310 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7311 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7312       if (j.lt.nres-1) then
7313         j1=j+1
7314         j2=j-1
7315       else
7316         j1=j-1
7317         j2=j-2
7318       endif
7319       if (l.lt.nres-1) then
7320         l1=l+1
7321         l2=l-1
7322       else
7323         l1=l-1
7324         l2=l-2
7325       endif
7326       do ll=1,3
7327 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7328 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7329         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7330         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7331 !grad        ghalf=0.5d0*ggg1(ll)
7332         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7333         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7334         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7335         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7336         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7337         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7338 !grad        ghalf=0.5d0*ggg2(ll)
7339         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7340         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7341         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7342         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7343         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7344         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7345       enddo
7346 !grad      do m=i+1,j-1
7347 !grad        do ll=1,3
7348 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7349 !grad        enddo
7350 !grad      enddo
7351 !grad      do m=k+1,l-1
7352 !grad        do ll=1,3
7353 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7354 !grad        enddo
7355 !grad      enddo
7356 !grad      do m=i+2,j2
7357 !grad        do ll=1,3
7358 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7359 !grad        enddo
7360 !grad      enddo
7361 !grad      do m=k+2,l2
7362 !grad        do ll=1,3
7363 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7364 !grad        enddo
7365 !grad      enddo
7366 !d      do iii=1,nres-3
7367 !d        write (2,*) iii,gcorr_loc(iii)
7368 !d      enddo
7369       eello4=ekont*eel4
7370 !d      write (2,*) 'ekont',ekont
7371 !d      write (iout,*) 'eello4',ekont*eel4
7372       return
7373       end function eello4
7374 !-----------------------------------------------------------------------------
7375       real(kind=8) function eello5(i,j,k,l,jj,kk)
7376 !      implicit real*8 (a-h,o-z)
7377 !      include 'DIMENSIONS'
7378 !      include 'COMMON.IOUNITS'
7379 !      include 'COMMON.CHAIN'
7380 !      include 'COMMON.DERIV'
7381 !      include 'COMMON.INTERACT'
7382 !      include 'COMMON.CONTACTS'
7383 !      include 'COMMON.TORSION'
7384 !      include 'COMMON.VAR'
7385 !      include 'COMMON.GEO'
7386       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7387       real(kind=8),dimension(2) :: vv
7388       real(kind=8),dimension(3) :: ggg1,ggg2
7389       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7390       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7391       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7392 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7393 !                                                                              C
7394 !                            Parallel chains                                   C
7395 !                                                                              C
7396 !          o             o                   o             o                   C
7397 !         /l\           / \             \   / \           / \   /              C
7398 !        /   \         /   \             \ /   \         /   \ /               C
7399 !       j| o |l1       | o |              o| o |         | o |o                C
7400 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7401 !      \i/   \         /   \ /             /   \         /   \                 C
7402 !       o    k1             o                                                  C
7403 !         (I)          (II)                (III)          (IV)                 C
7404 !                                                                              C
7405 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7406 !                                                                              C
7407 !                            Antiparallel chains                               C
7408 !                                                                              C
7409 !          o             o                   o             o                   C
7410 !         /j\           / \             \   / \           / \   /              C
7411 !        /   \         /   \             \ /   \         /   \ /               C
7412 !      j1| o |l        | o |              o| o |         | o |o                C
7413 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7414 !      \i/   \         /   \ /             /   \         /   \                 C
7415 !       o     k1            o                                                  C
7416 !         (I)          (II)                (III)          (IV)                 C
7417 !                                                                              C
7418 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7419 !                                                                              C
7420 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7421 !                                                                              C
7422 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7423 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7424 !d        eello5=0.0d0
7425 !d        return
7426 !d      endif
7427 !d      write (iout,*)
7428 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7429 !d     &   ' and',k,l
7430       itk=itortyp(itype(k))
7431       itl=itortyp(itype(l))
7432       itj=itortyp(itype(j))
7433       eello5_1=0.0d0
7434       eello5_2=0.0d0
7435       eello5_3=0.0d0
7436       eello5_4=0.0d0
7437 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7438 !d     &   eel5_3_num,eel5_4_num)
7439       do iii=1,2
7440         do kkk=1,5
7441           do lll=1,3
7442             derx(lll,kkk,iii)=0.0d0
7443           enddo
7444         enddo
7445       enddo
7446 !d      eij=facont_hb(jj,i)
7447 !d      ekl=facont_hb(kk,k)
7448 !d      ekont=eij*ekl
7449 !d      write (iout,*)'Contacts have occurred for peptide groups',
7450 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7451 !d      goto 1111
7452 ! Contribution from the graph I.
7453 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7454 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7455       call transpose2(EUg(1,1,k),auxmat(1,1))
7456       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7457       vv(1)=pizda(1,1)-pizda(2,2)
7458       vv(2)=pizda(1,2)+pizda(2,1)
7459       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7460        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7461 ! Explicit gradient in virtual-dihedral angles.
7462       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7463        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7464        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7465       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7466       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)-pizda(2,2)
7468       vv(2)=pizda(1,2)+pizda(2,1)
7469       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7470        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7471        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7472       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7473       vv(1)=pizda(1,1)-pizda(2,2)
7474       vv(2)=pizda(1,2)+pizda(2,1)
7475       if (l.eq.j+1) then
7476         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7477          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7478          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7479       else
7480         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7481          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7482          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7483       endif
7484 ! Cartesian gradient
7485       do iii=1,2
7486         do kkk=1,5
7487           do lll=1,3
7488             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7489               pizda(1,1))
7490             vv(1)=pizda(1,1)-pizda(2,2)
7491             vv(2)=pizda(1,2)+pizda(2,1)
7492             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7493              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7494              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7495           enddo
7496         enddo
7497       enddo
7498 !      goto 1112
7499 !1111  continue
7500 ! Contribution from graph II
7501       call transpose2(EE(1,1,itk),auxmat(1,1))
7502       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7503       vv(1)=pizda(1,1)+pizda(2,2)
7504       vv(2)=pizda(2,1)-pizda(1,2)
7505       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7506        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7507 ! Explicit gradient in virtual-dihedral angles.
7508       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7509        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7510       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7511       vv(1)=pizda(1,1)+pizda(2,2)
7512       vv(2)=pizda(2,1)-pizda(1,2)
7513       if (l.eq.j+1) then
7514         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7515          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7516          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7517       else
7518         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7519          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7520          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7521       endif
7522 ! Cartesian gradient
7523       do iii=1,2
7524         do kkk=1,5
7525           do lll=1,3
7526             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7527               pizda(1,1))
7528             vv(1)=pizda(1,1)+pizda(2,2)
7529             vv(2)=pizda(2,1)-pizda(1,2)
7530             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7531              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7532              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7533           enddo
7534         enddo
7535       enddo
7536 !d      goto 1112
7537 !d1111  continue
7538       if (l.eq.j+1) then
7539 !d        goto 1110
7540 ! Parallel orientation
7541 ! Contribution from graph III
7542         call transpose2(EUg(1,1,l),auxmat(1,1))
7543         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7544         vv(1)=pizda(1,1)-pizda(2,2)
7545         vv(2)=pizda(1,2)+pizda(2,1)
7546         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7547          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7548 ! Explicit gradient in virtual-dihedral angles.
7549         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7550          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7551          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7552         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7553         vv(1)=pizda(1,1)-pizda(2,2)
7554         vv(2)=pizda(1,2)+pizda(2,1)
7555         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7556          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7557          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7558         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7559         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7560         vv(1)=pizda(1,1)-pizda(2,2)
7561         vv(2)=pizda(1,2)+pizda(2,1)
7562         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7563          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7564          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7565 ! Cartesian gradient
7566         do iii=1,2
7567           do kkk=1,5
7568             do lll=1,3
7569               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7570                 pizda(1,1))
7571               vv(1)=pizda(1,1)-pizda(2,2)
7572               vv(2)=pizda(1,2)+pizda(2,1)
7573               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7574                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7575                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7576             enddo
7577           enddo
7578         enddo
7579 !d        goto 1112
7580 ! Contribution from graph IV
7581 !d1110    continue
7582         call transpose2(EE(1,1,itl),auxmat(1,1))
7583         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7584         vv(1)=pizda(1,1)+pizda(2,2)
7585         vv(2)=pizda(2,1)-pizda(1,2)
7586         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7587          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7588 ! Explicit gradient in virtual-dihedral angles.
7589         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7590          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7591         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7592         vv(1)=pizda(1,1)+pizda(2,2)
7593         vv(2)=pizda(2,1)-pizda(1,2)
7594         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7595          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7596          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7597 ! Cartesian gradient
7598         do iii=1,2
7599           do kkk=1,5
7600             do lll=1,3
7601               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7602                 pizda(1,1))
7603               vv(1)=pizda(1,1)+pizda(2,2)
7604               vv(2)=pizda(2,1)-pizda(1,2)
7605               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7606                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7607                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7608             enddo
7609           enddo
7610         enddo
7611       else
7612 ! Antiparallel orientation
7613 ! Contribution from graph III
7614 !        goto 1110
7615         call transpose2(EUg(1,1,j),auxmat(1,1))
7616         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7617         vv(1)=pizda(1,1)-pizda(2,2)
7618         vv(2)=pizda(1,2)+pizda(2,1)
7619         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7620          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7621 ! Explicit gradient in virtual-dihedral angles.
7622         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7623          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7624          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7625         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7626         vv(1)=pizda(1,1)-pizda(2,2)
7627         vv(2)=pizda(1,2)+pizda(2,1)
7628         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7629          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7630          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7631         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7632         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7633         vv(1)=pizda(1,1)-pizda(2,2)
7634         vv(2)=pizda(1,2)+pizda(2,1)
7635         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7636          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7637          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7638 ! Cartesian gradient
7639         do iii=1,2
7640           do kkk=1,5
7641             do lll=1,3
7642               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7643                 pizda(1,1))
7644               vv(1)=pizda(1,1)-pizda(2,2)
7645               vv(2)=pizda(1,2)+pizda(2,1)
7646               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7647                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7648                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7649             enddo
7650           enddo
7651         enddo
7652 !d        goto 1112
7653 ! Contribution from graph IV
7654 1110    continue
7655         call transpose2(EE(1,1,itj),auxmat(1,1))
7656         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7657         vv(1)=pizda(1,1)+pizda(2,2)
7658         vv(2)=pizda(2,1)-pizda(1,2)
7659         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7660          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7661 ! Explicit gradient in virtual-dihedral angles.
7662         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7663          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7664         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7665         vv(1)=pizda(1,1)+pizda(2,2)
7666         vv(2)=pizda(2,1)-pizda(1,2)
7667         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7668          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7669          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7670 ! Cartesian gradient
7671         do iii=1,2
7672           do kkk=1,5
7673             do lll=1,3
7674               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7675                 pizda(1,1))
7676               vv(1)=pizda(1,1)+pizda(2,2)
7677               vv(2)=pizda(2,1)-pizda(1,2)
7678               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7679                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7680                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7681             enddo
7682           enddo
7683         enddo
7684       endif
7685 1112  continue
7686       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7687 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7688 !d        write (2,*) 'ijkl',i,j,k,l
7689 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7690 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7691 !d      endif
7692 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7693 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7694 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7695 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7696       if (j.lt.nres-1) then
7697         j1=j+1
7698         j2=j-1
7699       else
7700         j1=j-1
7701         j2=j-2
7702       endif
7703       if (l.lt.nres-1) then
7704         l1=l+1
7705         l2=l-1
7706       else
7707         l1=l-1
7708         l2=l-2
7709       endif
7710 !d      eij=1.0d0
7711 !d      ekl=1.0d0
7712 !d      ekont=1.0d0
7713 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7714 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7715 !        summed up outside the subrouine as for the other subroutines
7716 !        handling long-range interactions. The old code is commented out
7717 !        with "cgrad" to keep track of changes.
7718       do ll=1,3
7719 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7720 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7721         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7722         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7723 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7724 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7725 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7726 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7727 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7728 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7729 !     &   gradcorr5ij,
7730 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7731 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7732 !grad        ghalf=0.5d0*ggg1(ll)
7733 !d        ghalf=0.0d0
7734         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7735         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7736         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7737         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7738         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7739         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7740 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7741 !grad        ghalf=0.5d0*ggg2(ll)
7742         ghalf=0.0d0
7743         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7744         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7745         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7746         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7747         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7748         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7749       enddo
7750 !d      goto 1112
7751 !grad      do m=i+1,j-1
7752 !grad        do ll=1,3
7753 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7754 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7755 !grad        enddo
7756 !grad      enddo
7757 !grad      do m=k+1,l-1
7758 !grad        do ll=1,3
7759 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7760 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7761 !grad        enddo
7762 !grad      enddo
7763 !1112  continue
7764 !grad      do m=i+2,j2
7765 !grad        do ll=1,3
7766 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7767 !grad        enddo
7768 !grad      enddo
7769 !grad      do m=k+2,l2
7770 !grad        do ll=1,3
7771 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7772 !grad        enddo
7773 !grad      enddo
7774 !d      do iii=1,nres-3
7775 !d        write (2,*) iii,g_corr5_loc(iii)
7776 !d      enddo
7777       eello5=ekont*eel5
7778 !d      write (2,*) 'ekont',ekont
7779 !d      write (iout,*) 'eello5',ekont*eel5
7780       return
7781       end function eello5
7782 !-----------------------------------------------------------------------------
7783       real(kind=8) function eello6(i,j,k,l,jj,kk)
7784 !      implicit real*8 (a-h,o-z)
7785 !      include 'DIMENSIONS'
7786 !      include 'COMMON.IOUNITS'
7787 !      include 'COMMON.CHAIN'
7788 !      include 'COMMON.DERIV'
7789 !      include 'COMMON.INTERACT'
7790 !      include 'COMMON.CONTACTS'
7791 !      include 'COMMON.TORSION'
7792 !      include 'COMMON.VAR'
7793 !      include 'COMMON.GEO'
7794 !      include 'COMMON.FFIELD'
7795       real(kind=8),dimension(3) :: ggg1,ggg2
7796       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7797                    eello6_6,eel6
7798       real(kind=8) :: gradcorr6ij,gradcorr6kl
7799       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7800 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7801 !d        eello6=0.0d0
7802 !d        return
7803 !d      endif
7804 !d      write (iout,*)
7805 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7806 !d     &   ' and',k,l
7807       eello6_1=0.0d0
7808       eello6_2=0.0d0
7809       eello6_3=0.0d0
7810       eello6_4=0.0d0
7811       eello6_5=0.0d0
7812       eello6_6=0.0d0
7813 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7814 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7815       do iii=1,2
7816         do kkk=1,5
7817           do lll=1,3
7818             derx(lll,kkk,iii)=0.0d0
7819           enddo
7820         enddo
7821       enddo
7822 !d      eij=facont_hb(jj,i)
7823 !d      ekl=facont_hb(kk,k)
7824 !d      ekont=eij*ekl
7825 !d      eij=1.0d0
7826 !d      ekl=1.0d0
7827 !d      ekont=1.0d0
7828       if (l.eq.j+1) then
7829         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7830         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7831         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7832         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7833         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7834         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7835       else
7836         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7837         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7838         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7839         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7840         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7841           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7842         else
7843           eello6_5=0.0d0
7844         endif
7845         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7846       endif
7847 ! If turn contributions are considered, they will be handled separately.
7848       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7849 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7850 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7851 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7852 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7853 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7854 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7855 !d      goto 1112
7856       if (j.lt.nres-1) then
7857         j1=j+1
7858         j2=j-1
7859       else
7860         j1=j-1
7861         j2=j-2
7862       endif
7863       if (l.lt.nres-1) then
7864         l1=l+1
7865         l2=l-1
7866       else
7867         l1=l-1
7868         l2=l-2
7869       endif
7870       do ll=1,3
7871 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7872 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7873 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7874 !grad        ghalf=0.5d0*ggg1(ll)
7875 !d        ghalf=0.0d0
7876         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7877         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7878         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7879         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7880         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7881         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7882         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7883         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7884 !grad        ghalf=0.5d0*ggg2(ll)
7885 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7886 !d        ghalf=0.0d0
7887         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7888         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7889         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7890         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7891         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7892         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7893       enddo
7894 !d      goto 1112
7895 !grad      do m=i+1,j-1
7896 !grad        do ll=1,3
7897 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7898 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7899 !grad        enddo
7900 !grad      enddo
7901 !grad      do m=k+1,l-1
7902 !grad        do ll=1,3
7903 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7904 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7905 !grad        enddo
7906 !grad      enddo
7907 !grad1112  continue
7908 !grad      do m=i+2,j2
7909 !grad        do ll=1,3
7910 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7911 !grad        enddo
7912 !grad      enddo
7913 !grad      do m=k+2,l2
7914 !grad        do ll=1,3
7915 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7916 !grad        enddo
7917 !grad      enddo
7918 !d      do iii=1,nres-3
7919 !d        write (2,*) iii,g_corr6_loc(iii)
7920 !d      enddo
7921       eello6=ekont*eel6
7922 !d      write (2,*) 'ekont',ekont
7923 !d      write (iout,*) 'eello6',ekont*eel6
7924       return
7925       end function eello6
7926 !-----------------------------------------------------------------------------
7927       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7928       use comm_kut
7929 !      implicit real*8 (a-h,o-z)
7930 !      include 'DIMENSIONS'
7931 !      include 'COMMON.IOUNITS'
7932 !      include 'COMMON.CHAIN'
7933 !      include 'COMMON.DERIV'
7934 !      include 'COMMON.INTERACT'
7935 !      include 'COMMON.CONTACTS'
7936 !      include 'COMMON.TORSION'
7937 !      include 'COMMON.VAR'
7938 !      include 'COMMON.GEO'
7939       real(kind=8),dimension(2) :: vv,vv1
7940       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
7941       logical :: swap
7942 !el      logical :: lprn
7943 !el      common /kutas/ lprn
7944       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
7945       real(kind=8) :: s1,s2,s3,s4,s5
7946 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7947 !                                                                              C
7948 !      Parallel       Antiparallel                                             C
7949 !                                                                              C
7950 !          o             o                                                     C
7951 !         /l\           /j\                                                    C
7952 !        /   \         /   \                                                   C
7953 !       /| o |         | o |\                                                  C
7954 !     \ j|/k\|  /   \  |/k\|l /                                                C
7955 !      \ /   \ /     \ /   \ /                                                 C
7956 !       o     o       o     o                                                  C
7957 !       i             i                                                        C
7958 !                                                                              C
7959 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7960       itk=itortyp(itype(k))
7961       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7962       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7963       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7964       call transpose2(EUgC(1,1,k),auxmat(1,1))
7965       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7966       vv1(1)=pizda1(1,1)-pizda1(2,2)
7967       vv1(2)=pizda1(1,2)+pizda1(2,1)
7968       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7969       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7970       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7971       s5=scalar2(vv(1),Dtobr2(1,i))
7972 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7973       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7974       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
7975        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
7976        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
7977        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
7978        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
7979        +scalar2(vv(1),Dtobr2der(1,i)))
7980       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7981       vv1(1)=pizda1(1,1)-pizda1(2,2)
7982       vv1(2)=pizda1(1,2)+pizda1(2,1)
7983       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7984       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7985       if (l.eq.j+1) then
7986         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
7987        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7988        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7989        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7990        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7991       else
7992         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
7993        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7994        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7995        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7996        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7997       endif
7998       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7999       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8000       vv1(1)=pizda1(1,1)-pizda1(2,2)
8001       vv1(2)=pizda1(1,2)+pizda1(2,1)
8002       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8003        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8004        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8005        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8006       do iii=1,2
8007         if (swap) then
8008           ind=3-iii
8009         else
8010           ind=iii
8011         endif
8012         do kkk=1,5
8013           do lll=1,3
8014             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8015             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8016             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8017             call transpose2(EUgC(1,1,k),auxmat(1,1))
8018             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8019               pizda1(1,1))
8020             vv1(1)=pizda1(1,1)-pizda1(2,2)
8021             vv1(2)=pizda1(1,2)+pizda1(2,1)
8022             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8023             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8024              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8025             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8026              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8027             s5=scalar2(vv(1),Dtobr2(1,i))
8028             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8029           enddo
8030         enddo
8031       enddo
8032       return
8033       end function eello6_graph1
8034 !-----------------------------------------------------------------------------
8035       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8036       use comm_kut
8037 !      implicit real*8 (a-h,o-z)
8038 !      include 'DIMENSIONS'
8039 !      include 'COMMON.IOUNITS'
8040 !      include 'COMMON.CHAIN'
8041 !      include 'COMMON.DERIV'
8042 !      include 'COMMON.INTERACT'
8043 !      include 'COMMON.CONTACTS'
8044 !      include 'COMMON.TORSION'
8045 !      include 'COMMON.VAR'
8046 !      include 'COMMON.GEO'
8047       logical :: swap
8048       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8049       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8050 !el      logical :: lprn
8051 !el      common /kutas/ lprn
8052       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8053       real(kind=8) :: s2,s3,s4
8054 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8055 !                                                                              C
8056 !      Parallel       Antiparallel                                             C
8057 !                                                                              C
8058 !          o             o                                                     C
8059 !     \   /l\           /j\   /                                                C
8060 !      \ /   \         /   \ /                                                 C
8061 !       o| o |         | o |o                                                  C
8062 !     \ j|/k\|      \  |/k\|l                                                  C
8063 !      \ /   \       \ /   \                                                   C
8064 !       o             o                                                        C
8065 !       i             i                                                        C
8066 !                                                                              C
8067 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8068 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8069 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8070 !           but not in a cluster cumulant
8071 #ifdef MOMENT
8072       s1=dip(1,jj,i)*dip(1,kk,k)
8073 #endif
8074       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8075       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8076       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8077       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8078       call transpose2(EUg(1,1,k),auxmat(1,1))
8079       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8080       vv(1)=pizda(1,1)-pizda(2,2)
8081       vv(2)=pizda(1,2)+pizda(2,1)
8082       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8083 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8084 #ifdef MOMENT
8085       eello6_graph2=-(s1+s2+s3+s4)
8086 #else
8087       eello6_graph2=-(s2+s3+s4)
8088 #endif
8089 !      eello6_graph2=-s3
8090 ! Derivatives in gamma(i-1)
8091       if (i.gt.1) then
8092 #ifdef MOMENT
8093         s1=dipderg(1,jj,i)*dip(1,kk,k)
8094 #endif
8095         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8096         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8097         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8098         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8099 #ifdef MOMENT
8100         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8101 #else
8102         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8103 #endif
8104 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8105       endif
8106 ! Derivatives in gamma(k-1)
8107 #ifdef MOMENT
8108       s1=dip(1,jj,i)*dipderg(1,kk,k)
8109 #endif
8110       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8111       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8112       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8113       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8114       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8115       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8116       vv(1)=pizda(1,1)-pizda(2,2)
8117       vv(2)=pizda(1,2)+pizda(2,1)
8118       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8119 #ifdef MOMENT
8120       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8121 #else
8122       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8123 #endif
8124 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8125 ! Derivatives in gamma(j-1) or gamma(l-1)
8126       if (j.gt.1) then
8127 #ifdef MOMENT
8128         s1=dipderg(3,jj,i)*dip(1,kk,k)
8129 #endif
8130         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8131         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8132         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8133         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8134         vv(1)=pizda(1,1)-pizda(2,2)
8135         vv(2)=pizda(1,2)+pizda(2,1)
8136         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8137 #ifdef MOMENT
8138         if (swap) then
8139           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8140         else
8141           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8142         endif
8143 #endif
8144         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8145 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8146       endif
8147 ! Derivatives in gamma(l-1) or gamma(j-1)
8148       if (l.gt.1) then
8149 #ifdef MOMENT
8150         s1=dip(1,jj,i)*dipderg(3,kk,k)
8151 #endif
8152         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8153         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8154         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8155         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8156         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8157         vv(1)=pizda(1,1)-pizda(2,2)
8158         vv(2)=pizda(1,2)+pizda(2,1)
8159         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8160 #ifdef MOMENT
8161         if (swap) then
8162           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8163         else
8164           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8165         endif
8166 #endif
8167         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8168 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8169       endif
8170 ! Cartesian derivatives.
8171       if (lprn) then
8172         write (2,*) 'In eello6_graph2'
8173         do iii=1,2
8174           write (2,*) 'iii=',iii
8175           do kkk=1,5
8176             write (2,*) 'kkk=',kkk
8177             do jjj=1,2
8178               write (2,'(3(2f10.5),5x)') &
8179               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8180             enddo
8181           enddo
8182         enddo
8183       endif
8184       do iii=1,2
8185         do kkk=1,5
8186           do lll=1,3
8187 #ifdef MOMENT
8188             if (iii.eq.1) then
8189               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8190             else
8191               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8192             endif
8193 #endif
8194             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8195               auxvec(1))
8196             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8197             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8198               auxvec(1))
8199             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8200             call transpose2(EUg(1,1,k),auxmat(1,1))
8201             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8202               pizda(1,1))
8203             vv(1)=pizda(1,1)-pizda(2,2)
8204             vv(2)=pizda(1,2)+pizda(2,1)
8205             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8206 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8207 #ifdef MOMENT
8208             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8209 #else
8210             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8211 #endif
8212             if (swap) then
8213               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8214             else
8215               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8216             endif
8217           enddo
8218         enddo
8219       enddo
8220       return
8221       end function eello6_graph2
8222 !-----------------------------------------------------------------------------
8223       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8224 !      implicit real*8 (a-h,o-z)
8225 !      include 'DIMENSIONS'
8226 !      include 'COMMON.IOUNITS'
8227 !      include 'COMMON.CHAIN'
8228 !      include 'COMMON.DERIV'
8229 !      include 'COMMON.INTERACT'
8230 !      include 'COMMON.CONTACTS'
8231 !      include 'COMMON.TORSION'
8232 !      include 'COMMON.VAR'
8233 !      include 'COMMON.GEO'
8234       real(kind=8),dimension(2) :: vv,auxvec
8235       real(kind=8),dimension(2,2) :: pizda,auxmat
8236       logical :: swap
8237       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8238       real(kind=8) :: s1,s2,s3,s4
8239 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8240 !                                                                              C
8241 !      Parallel       Antiparallel                                             C
8242 !                                                                              C
8243 !          o             o                                                     C
8244 !         /l\   /   \   /j\                                                    C
8245 !        /   \ /     \ /   \                                                   C
8246 !       /| o |o       o| o |\                                                  C
8247 !       j|/k\|  /      |/k\|l /                                                C
8248 !        /   \ /       /   \ /                                                 C
8249 !       /     o       /     o                                                  C
8250 !       i             i                                                        C
8251 !                                                                              C
8252 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8253 !
8254 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8255 !           energy moment and not to the cluster cumulant.
8256       iti=itortyp(itype(i))
8257       if (j.lt.nres-1) then
8258         itj1=itortyp(itype(j+1))
8259       else
8260         itj1=ntortyp+1
8261       endif
8262       itk=itortyp(itype(k))
8263       itk1=itortyp(itype(k+1))
8264       if (l.lt.nres-1) then
8265         itl1=itortyp(itype(l+1))
8266       else
8267         itl1=ntortyp+1
8268       endif
8269 #ifdef MOMENT
8270       s1=dip(4,jj,i)*dip(4,kk,k)
8271 #endif
8272       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8273       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8274       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8275       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8276       call transpose2(EE(1,1,itk),auxmat(1,1))
8277       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8278       vv(1)=pizda(1,1)+pizda(2,2)
8279       vv(2)=pizda(2,1)-pizda(1,2)
8280       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8281 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8282 !d     & "sum",-(s2+s3+s4)
8283 #ifdef MOMENT
8284       eello6_graph3=-(s1+s2+s3+s4)
8285 #else
8286       eello6_graph3=-(s2+s3+s4)
8287 #endif
8288 !      eello6_graph3=-s4
8289 ! Derivatives in gamma(k-1)
8290       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8291       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8292       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8294 ! Derivatives in gamma(l-1)
8295       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8296       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8297       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8298       vv(1)=pizda(1,1)+pizda(2,2)
8299       vv(2)=pizda(2,1)-pizda(1,2)
8300       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8301       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8302 ! Cartesian derivatives.
8303       do iii=1,2
8304         do kkk=1,5
8305           do lll=1,3
8306 #ifdef MOMENT
8307             if (iii.eq.1) then
8308               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8309             else
8310               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8311             endif
8312 #endif
8313             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8314               auxvec(1))
8315             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8316             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8317               auxvec(1))
8318             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8319             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8320               pizda(1,1))
8321             vv(1)=pizda(1,1)+pizda(2,2)
8322             vv(2)=pizda(2,1)-pizda(1,2)
8323             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8324 #ifdef MOMENT
8325             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8326 #else
8327             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8328 #endif
8329             if (swap) then
8330               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8331             else
8332               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8333             endif
8334 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8335           enddo
8336         enddo
8337       enddo
8338       return
8339       end function eello6_graph3
8340 !-----------------------------------------------------------------------------
8341       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8342 !      implicit real*8 (a-h,o-z)
8343 !      include 'DIMENSIONS'
8344 !      include 'COMMON.IOUNITS'
8345 !      include 'COMMON.CHAIN'
8346 !      include 'COMMON.DERIV'
8347 !      include 'COMMON.INTERACT'
8348 !      include 'COMMON.CONTACTS'
8349 !      include 'COMMON.TORSION'
8350 !      include 'COMMON.VAR'
8351 !      include 'COMMON.GEO'
8352 !      include 'COMMON.FFIELD'
8353       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8354       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8355       logical :: swap
8356       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8357               iii,kkk,lll
8358       real(kind=8) :: s1,s2,s3,s4
8359 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8360 !                                                                              C
8361 !      Parallel       Antiparallel                                             C
8362 !                                                                              C
8363 !          o             o                                                     C
8364 !         /l\   /   \   /j\                                                    C
8365 !        /   \ /     \ /   \                                                   C
8366 !       /| o |o       o| o |\                                                  C
8367 !     \ j|/k\|      \  |/k\|l                                                  C
8368 !      \ /   \       \ /   \                                                   C
8369 !       o     \       o     \                                                  C
8370 !       i             i                                                        C
8371 !                                                                              C
8372 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8373 !
8374 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8375 !           energy moment and not to the cluster cumulant.
8376 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8377       iti=itortyp(itype(i))
8378       itj=itortyp(itype(j))
8379       if (j.lt.nres-1) then
8380         itj1=itortyp(itype(j+1))
8381       else
8382         itj1=ntortyp+1
8383       endif
8384       itk=itortyp(itype(k))
8385       if (k.lt.nres-1) then
8386         itk1=itortyp(itype(k+1))
8387       else
8388         itk1=ntortyp+1
8389       endif
8390       itl=itortyp(itype(l))
8391       if (l.lt.nres-1) then
8392         itl1=itortyp(itype(l+1))
8393       else
8394         itl1=ntortyp+1
8395       endif
8396 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8397 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8398 !d     & ' itl',itl,' itl1',itl1
8399 #ifdef MOMENT
8400       if (imat.eq.1) then
8401         s1=dip(3,jj,i)*dip(3,kk,k)
8402       else
8403         s1=dip(2,jj,j)*dip(2,kk,l)
8404       endif
8405 #endif
8406       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8407       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8408       if (j.eq.l+1) then
8409         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8410         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8411       else
8412         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8413         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8414       endif
8415       call transpose2(EUg(1,1,k),auxmat(1,1))
8416       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8417       vv(1)=pizda(1,1)-pizda(2,2)
8418       vv(2)=pizda(2,1)+pizda(1,2)
8419       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8420 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8421 #ifdef MOMENT
8422       eello6_graph4=-(s1+s2+s3+s4)
8423 #else
8424       eello6_graph4=-(s2+s3+s4)
8425 #endif
8426 ! Derivatives in gamma(i-1)
8427       if (i.gt.1) then
8428 #ifdef MOMENT
8429         if (imat.eq.1) then
8430           s1=dipderg(2,jj,i)*dip(3,kk,k)
8431         else
8432           s1=dipderg(4,jj,j)*dip(2,kk,l)
8433         endif
8434 #endif
8435         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8436         if (j.eq.l+1) then
8437           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8438           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8439         else
8440           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8441           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8442         endif
8443         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8444         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8445 !d          write (2,*) 'turn6 derivatives'
8446 #ifdef MOMENT
8447           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8448 #else
8449           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8450 #endif
8451         else
8452 #ifdef MOMENT
8453           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8454 #else
8455           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8456 #endif
8457         endif
8458       endif
8459 ! Derivatives in gamma(k-1)
8460 #ifdef MOMENT
8461       if (imat.eq.1) then
8462         s1=dip(3,jj,i)*dipderg(2,kk,k)
8463       else
8464         s1=dip(2,jj,j)*dipderg(4,kk,l)
8465       endif
8466 #endif
8467       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8468       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8469       if (j.eq.l+1) then
8470         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8471         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8472       else
8473         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8474         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8475       endif
8476       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8477       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8478       vv(1)=pizda(1,1)-pizda(2,2)
8479       vv(2)=pizda(2,1)+pizda(1,2)
8480       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8481       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8482 #ifdef MOMENT
8483         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8484 #else
8485         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8486 #endif
8487       else
8488 #ifdef MOMENT
8489         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8490 #else
8491         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8492 #endif
8493       endif
8494 ! Derivatives in gamma(j-1) or gamma(l-1)
8495       if (l.eq.j+1 .and. l.gt.1) then
8496         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8497         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8498         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8499         vv(1)=pizda(1,1)-pizda(2,2)
8500         vv(2)=pizda(2,1)+pizda(1,2)
8501         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8502         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8503       else if (j.gt.1) then
8504         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8505         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8506         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8507         vv(1)=pizda(1,1)-pizda(2,2)
8508         vv(2)=pizda(2,1)+pizda(1,2)
8509         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8510         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8511           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8512         else
8513           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8514         endif
8515       endif
8516 ! Cartesian derivatives.
8517       do iii=1,2
8518         do kkk=1,5
8519           do lll=1,3
8520 #ifdef MOMENT
8521             if (iii.eq.1) then
8522               if (imat.eq.1) then
8523                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8524               else
8525                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8526               endif
8527             else
8528               if (imat.eq.1) then
8529                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8530               else
8531                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8532               endif
8533             endif
8534 #endif
8535             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8536               auxvec(1))
8537             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8538             if (j.eq.l+1) then
8539               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8540                 b1(1,itj1),auxvec(1))
8541               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8542             else
8543               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8544                 b1(1,itl1),auxvec(1))
8545               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8546             endif
8547             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8548               pizda(1,1))
8549             vv(1)=pizda(1,1)-pizda(2,2)
8550             vv(2)=pizda(2,1)+pizda(1,2)
8551             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8552             if (swap) then
8553               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8554 #ifdef MOMENT
8555                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8556                    -(s1+s2+s4)
8557 #else
8558                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8559                    -(s2+s4)
8560 #endif
8561                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8562               else
8563 #ifdef MOMENT
8564                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8565 #else
8566                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8567 #endif
8568                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8569               endif
8570             else
8571 #ifdef MOMENT
8572               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8573 #else
8574               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8575 #endif
8576               if (l.eq.j+1) then
8577                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8578               else
8579                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8580               endif
8581             endif
8582           enddo
8583         enddo
8584       enddo
8585       return
8586       end function eello6_graph4
8587 !-----------------------------------------------------------------------------
8588       real(kind=8) function eello_turn6(i,jj,kk)
8589 !      implicit real*8 (a-h,o-z)
8590 !      include 'DIMENSIONS'
8591 !      include 'COMMON.IOUNITS'
8592 !      include 'COMMON.CHAIN'
8593 !      include 'COMMON.DERIV'
8594 !      include 'COMMON.INTERACT'
8595 !      include 'COMMON.CONTACTS'
8596 !      include 'COMMON.TORSION'
8597 !      include 'COMMON.VAR'
8598 !      include 'COMMON.GEO'
8599       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8600       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8601       real(kind=8),dimension(3) :: ggg1,ggg2
8602       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8603       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8604 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8605 !           the respective energy moment and not to the cluster cumulant.
8606 !el local variables
8607       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8608       integer :: j1,j2,l1,l2,ll
8609       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8610       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8611       s1=0.0d0
8612       s8=0.0d0
8613       s13=0.0d0
8614 !
8615       eello_turn6=0.0d0
8616       j=i+4
8617       k=i+1
8618       l=i+3
8619       iti=itortyp(itype(i))
8620       itk=itortyp(itype(k))
8621       itk1=itortyp(itype(k+1))
8622       itl=itortyp(itype(l))
8623       itj=itortyp(itype(j))
8624 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8625 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8626 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8627 !d        eello6=0.0d0
8628 !d        return
8629 !d      endif
8630 !d      write (iout,*)
8631 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8632 !d     &   ' and',k,l
8633 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8634       do iii=1,2
8635         do kkk=1,5
8636           do lll=1,3
8637             derx_turn(lll,kkk,iii)=0.0d0
8638           enddo
8639         enddo
8640       enddo
8641 !d      eij=1.0d0
8642 !d      ekl=1.0d0
8643 !d      ekont=1.0d0
8644       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8645 !d      eello6_5=0.0d0
8646 !d      write (2,*) 'eello6_5',eello6_5
8647 #ifdef MOMENT
8648       call transpose2(AEA(1,1,1),auxmat(1,1))
8649       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8650       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8651       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8652 #endif
8653       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8654       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8655       s2 = scalar2(b1(1,itk),vtemp1(1))
8656 #ifdef MOMENT
8657       call transpose2(AEA(1,1,2),atemp(1,1))
8658       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8659       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8660       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8661 #endif
8662       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8663       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8664       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8665 #ifdef MOMENT
8666       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8667       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8668       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8669       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8670       ss13 = scalar2(b1(1,itk),vtemp4(1))
8671       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8672 #endif
8673 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8674 !      s1=0.0d0
8675 !      s2=0.0d0
8676 !      s8=0.0d0
8677 !      s12=0.0d0
8678 !      s13=0.0d0
8679       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8680 ! Derivatives in gamma(i+2)
8681       s1d =0.0d0
8682       s8d =0.0d0
8683 #ifdef MOMENT
8684       call transpose2(AEA(1,1,1),auxmatd(1,1))
8685       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8686       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8687       call transpose2(AEAderg(1,1,2),atempd(1,1))
8688       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8689       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8690 #endif
8691       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8692       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8693       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8694 !      s1d=0.0d0
8695 !      s2d=0.0d0
8696 !      s8d=0.0d0
8697 !      s12d=0.0d0
8698 !      s13d=0.0d0
8699       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8700 ! Derivatives in gamma(i+3)
8701 #ifdef MOMENT
8702       call transpose2(AEA(1,1,1),auxmatd(1,1))
8703       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8704       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8705       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8706 #endif
8707       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8708       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8709       s2d = scalar2(b1(1,itk),vtemp1d(1))
8710 #ifdef MOMENT
8711       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8712       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8713 #endif
8714       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8715 #ifdef MOMENT
8716       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8717       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8718       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8719 #endif
8720 !      s1d=0.0d0
8721 !      s2d=0.0d0
8722 !      s8d=0.0d0
8723 !      s12d=0.0d0
8724 !      s13d=0.0d0
8725 #ifdef MOMENT
8726       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8727                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8728 #else
8729       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8730                     -0.5d0*ekont*(s2d+s12d)
8731 #endif
8732 ! Derivatives in gamma(i+4)
8733       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8734       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8735       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8736 #ifdef MOMENT
8737       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8738       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8739       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8740 #endif
8741 !      s1d=0.0d0
8742 !      s2d=0.0d0
8743 !      s8d=0.0d0
8744 !      s12d=0.0d0
8745 !      s13d=0.0d0
8746 #ifdef MOMENT
8747       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8748 #else
8749       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8750 #endif
8751 ! Derivatives in gamma(i+5)
8752 #ifdef MOMENT
8753       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8754       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8755       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8756 #endif
8757       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8758       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8759       s2d = scalar2(b1(1,itk),vtemp1d(1))
8760 #ifdef MOMENT
8761       call transpose2(AEA(1,1,2),atempd(1,1))
8762       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8763       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8764 #endif
8765       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8766       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8767 #ifdef MOMENT
8768       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8769       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8770       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8771 #endif
8772 !      s1d=0.0d0
8773 !      s2d=0.0d0
8774 !      s8d=0.0d0
8775 !      s12d=0.0d0
8776 !      s13d=0.0d0
8777 #ifdef MOMENT
8778       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8779                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8780 #else
8781       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8782                     -0.5d0*ekont*(s2d+s12d)
8783 #endif
8784 ! Cartesian derivatives
8785       do iii=1,2
8786         do kkk=1,5
8787           do lll=1,3
8788 #ifdef MOMENT
8789             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8790             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8791             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8792 #endif
8793             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8794             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8795                 vtemp1d(1))
8796             s2d = scalar2(b1(1,itk),vtemp1d(1))
8797 #ifdef MOMENT
8798             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8799             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8800             s8d = -(atempd(1,1)+atempd(2,2))* &
8801                  scalar2(cc(1,1,itl),vtemp2(1))
8802 #endif
8803             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8804                  auxmatd(1,1))
8805             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8806             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8807 !      s1d=0.0d0
8808 !      s2d=0.0d0
8809 !      s8d=0.0d0
8810 !      s12d=0.0d0
8811 !      s13d=0.0d0
8812 #ifdef MOMENT
8813             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8814               - 0.5d0*(s1d+s2d)
8815 #else
8816             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8817               - 0.5d0*s2d
8818 #endif
8819 #ifdef MOMENT
8820             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8821               - 0.5d0*(s8d+s12d)
8822 #else
8823             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8824               - 0.5d0*s12d
8825 #endif
8826           enddo
8827         enddo
8828       enddo
8829 #ifdef MOMENT
8830       do kkk=1,5
8831         do lll=1,3
8832           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8833             achuj_tempd(1,1))
8834           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8835           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8836           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8837           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8838           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8839             vtemp4d(1))
8840           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8841           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8842           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8843         enddo
8844       enddo
8845 #endif
8846 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8847 !d     &  16*eel_turn6_num
8848 !d      goto 1112
8849       if (j.lt.nres-1) then
8850         j1=j+1
8851         j2=j-1
8852       else
8853         j1=j-1
8854         j2=j-2
8855       endif
8856       if (l.lt.nres-1) then
8857         l1=l+1
8858         l2=l-1
8859       else
8860         l1=l-1
8861         l2=l-2
8862       endif
8863       do ll=1,3
8864 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8865 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8866 !grad        ghalf=0.5d0*ggg1(ll)
8867 !d        ghalf=0.0d0
8868         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8869         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8870         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8871           +ekont*derx_turn(ll,2,1)
8872         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8873         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8874           +ekont*derx_turn(ll,4,1)
8875         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8876         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8877         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8878 !grad        ghalf=0.5d0*ggg2(ll)
8879 !d        ghalf=0.0d0
8880         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8881           +ekont*derx_turn(ll,2,2)
8882         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8883         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8884           +ekont*derx_turn(ll,4,2)
8885         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8886         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8887         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8888       enddo
8889 !d      goto 1112
8890 !grad      do m=i+1,j-1
8891 !grad        do ll=1,3
8892 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8893 !grad        enddo
8894 !grad      enddo
8895 !grad      do m=k+1,l-1
8896 !grad        do ll=1,3
8897 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8898 !grad        enddo
8899 !grad      enddo
8900 !grad1112  continue
8901 !grad      do m=i+2,j2
8902 !grad        do ll=1,3
8903 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8904 !grad        enddo
8905 !grad      enddo
8906 !grad      do m=k+2,l2
8907 !grad        do ll=1,3
8908 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8909 !grad        enddo
8910 !grad      enddo
8911 !d      do iii=1,nres-3
8912 !d        write (2,*) iii,g_corr6_loc(iii)
8913 !d      enddo
8914       eello_turn6=ekont*eel_turn6
8915 !d      write (2,*) 'ekont',ekont
8916 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8917       return
8918       end function eello_turn6
8919 !-----------------------------------------------------------------------------
8920       subroutine MATVEC2(A1,V1,V2)
8921 !DIR$ INLINEALWAYS MATVEC2
8922 #ifndef OSF
8923 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8924 #endif
8925 !      implicit real*8 (a-h,o-z)
8926 !      include 'DIMENSIONS'
8927       real(kind=8),dimension(2) :: V1,V2
8928       real(kind=8),dimension(2,2) :: A1
8929       real(kind=8) :: vaux1,vaux2
8930 !      DO 1 I=1,2
8931 !        VI=0.0
8932 !        DO 3 K=1,2
8933 !    3     VI=VI+A1(I,K)*V1(K)
8934 !        Vaux(I)=VI
8935 !    1 CONTINUE
8936
8937       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8938       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8939
8940       v2(1)=vaux1
8941       v2(2)=vaux2
8942       end subroutine MATVEC2
8943 !-----------------------------------------------------------------------------
8944       subroutine MATMAT2(A1,A2,A3)
8945 #ifndef OSF
8946 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8947 #endif
8948 !      implicit real*8 (a-h,o-z)
8949 !      include 'DIMENSIONS'
8950       real(kind=8),dimension(2,2) :: A1,A2,A3
8951       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
8952 !      DIMENSION AI3(2,2)
8953 !        DO  J=1,2
8954 !          A3IJ=0.0
8955 !          DO K=1,2
8956 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8957 !          enddo
8958 !          A3(I,J)=A3IJ
8959 !       enddo
8960 !      enddo
8961
8962       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8963       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8964       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8965       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8966
8967       A3(1,1)=AI3_11
8968       A3(2,1)=AI3_21
8969       A3(1,2)=AI3_12
8970       A3(2,2)=AI3_22
8971       end subroutine MATMAT2
8972 !-----------------------------------------------------------------------------
8973       real(kind=8) function scalar2(u,v)
8974 !DIR$ INLINEALWAYS scalar2
8975       implicit none
8976       real(kind=8),dimension(2) :: u,v
8977       real(kind=8) :: sc
8978       integer :: i
8979       scalar2=u(1)*v(1)+u(2)*v(2)
8980       return
8981       end function scalar2
8982 !-----------------------------------------------------------------------------
8983       subroutine transpose2(a,at)
8984 !DIR$ INLINEALWAYS transpose2
8985 #ifndef OSF
8986 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
8987 #endif
8988       implicit none
8989       real(kind=8),dimension(2,2) :: a,at
8990       at(1,1)=a(1,1)
8991       at(1,2)=a(2,1)
8992       at(2,1)=a(1,2)
8993       at(2,2)=a(2,2)
8994       return
8995       end subroutine transpose2
8996 !-----------------------------------------------------------------------------
8997       subroutine transpose(n,a,at)
8998       implicit none
8999       integer :: n,i,j
9000       real(kind=8),dimension(n,n) :: a,at
9001       do i=1,n
9002         do j=1,n
9003           at(j,i)=a(i,j)
9004         enddo
9005       enddo
9006       return
9007       end subroutine transpose
9008 !-----------------------------------------------------------------------------
9009       subroutine prodmat3(a1,a2,kk,transp,prod)
9010 !DIR$ INLINEALWAYS prodmat3
9011 #ifndef OSF
9012 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9013 #endif
9014       implicit none
9015       integer :: i,j
9016       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9017       logical :: transp
9018 !rc      double precision auxmat(2,2),prod_(2,2)
9019
9020       if (transp) then
9021 !rc        call transpose2(kk(1,1),auxmat(1,1))
9022 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9023 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9024
9025            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9026        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9027            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9028        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9029            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9030        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9031            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9032        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9033
9034       else
9035 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9036 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9037
9038            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9039         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9040            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9041         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9042            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9043         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9044            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9045         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9046
9047       endif
9048 !      call transpose2(a2(1,1),a2t(1,1))
9049
9050 !rc      print *,transp
9051 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9052 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9053
9054       return
9055       end subroutine prodmat3
9056 !-----------------------------------------------------------------------------
9057 ! energy_p_new_barrier.F
9058 !-----------------------------------------------------------------------------
9059       subroutine sum_gradient
9060 !      implicit real*8 (a-h,o-z)
9061       use io_base, only: pdbout
9062 !      include 'DIMENSIONS'
9063 #ifndef ISNAN
9064       external proc_proc
9065 #ifdef WINPGI
9066 !MS$ATTRIBUTES C ::  proc_proc
9067 #endif
9068 #endif
9069 #ifdef MPI
9070       include 'mpif.h'
9071 #endif
9072       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9073                    gloc_scbuf !(3,maxres)
9074
9075       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9076 !#endif
9077 !el local variables
9078       integer :: i,j,k,ierror,ierr
9079       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9080                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9081                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9082                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9083                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9084                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9085                    gsccorr_max,gsccorrx_max,time00
9086
9087 !      include 'COMMON.SETUP'
9088 !      include 'COMMON.IOUNITS'
9089 !      include 'COMMON.FFIELD'
9090 !      include 'COMMON.DERIV'
9091 !      include 'COMMON.INTERACT'
9092 !      include 'COMMON.SBRIDGE'
9093 !      include 'COMMON.CHAIN'
9094 !      include 'COMMON.VAR'
9095 !      include 'COMMON.CONTROL'
9096 !      include 'COMMON.TIME1'
9097 !      include 'COMMON.MAXGRAD'
9098 !      include 'COMMON.SCCOR'
9099 #ifdef TIMING
9100       time01=MPI_Wtime()
9101 #endif
9102 #ifdef DEBUG
9103       write (iout,*) "sum_gradient gvdwc, gvdwx"
9104       do i=1,nres
9105         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9106          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9107       enddo
9108       call flush(iout)
9109 #endif
9110 #ifdef MPI
9111         gradbufc=0.0d0
9112         gradbufx=0.0d0
9113         gradbufc_sum=0.0d0
9114         gloc_scbuf=0.0d0
9115         glocbuf=0.0d0
9116 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9117         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9118           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9119 #endif
9120 !
9121 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9122 !            in virtual-bond-vector coordinates
9123 !
9124 #ifdef DEBUG
9125 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9126 !      do i=1,nres-1
9127 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9128 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9129 !      enddo
9130 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9131 !      do i=1,nres-1
9132 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9133 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9134 !      enddo
9135       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9136       do i=1,nres
9137         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9138          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9139          (gvdwc_scpp(j,i),j=1,3)
9140       enddo
9141       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9142       do i=1,nres
9143         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9144          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9145          (gelc_loc_long(j,i),j=1,3)
9146       enddo
9147       call flush(iout)
9148 #endif
9149 #ifdef SPLITELE
9150       do i=1,nct
9151         do j=1,3
9152           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9153                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9154                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9155                       wel_loc*gel_loc_long(j,i)+ &
9156                       wcorr*gradcorr_long(j,i)+ &
9157                       wcorr5*gradcorr5_long(j,i)+ &
9158                       wcorr6*gradcorr6_long(j,i)+ &
9159                       wturn6*gcorr6_turn_long(j,i)+ &
9160                       wstrain*ghpbc(j,i)
9161         enddo
9162       enddo
9163 #else
9164       do i=1,nct
9165         do j=1,3
9166           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9167                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9168                       welec*gelc_long(j,i)+ &
9169                       wbond*gradb(j,i)+ &
9170                       wel_loc*gel_loc_long(j,i)+ &
9171                       wcorr*gradcorr_long(j,i)+ &
9172                       wcorr5*gradcorr5_long(j,i)+ &
9173                       wcorr6*gradcorr6_long(j,i)+ &
9174                       wturn6*gcorr6_turn_long(j,i)+ &
9175                       wstrain*ghpbc(j,i)
9176         enddo
9177       enddo
9178 #endif
9179 #ifdef MPI
9180       if (nfgtasks.gt.1) then
9181       time00=MPI_Wtime()
9182 #ifdef DEBUG
9183       write (iout,*) "gradbufc before allreduce"
9184       do i=1,nres
9185         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9186       enddo
9187       call flush(iout)
9188 #endif
9189       do i=1,nres
9190         do j=1,3
9191           gradbufc_sum(j,i)=gradbufc(j,i)
9192         enddo
9193       enddo
9194 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9195 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9196 !      time_reduce=time_reduce+MPI_Wtime()-time00
9197 #ifdef DEBUG
9198 !      write (iout,*) "gradbufc_sum after allreduce"
9199 !      do i=1,nres
9200 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9201 !      enddo
9202 !      call flush(iout)
9203 #endif
9204 #ifdef TIMING
9205 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9206 #endif
9207       do i=nnt,nres
9208         do k=1,3
9209           gradbufc(k,i)=0.0d0
9210         enddo
9211       enddo
9212 #ifdef DEBUG
9213       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9214       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9215                         " jgrad_end  ",jgrad_end(i),&
9216                         i=igrad_start,igrad_end)
9217 #endif
9218 !
9219 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9220 ! do not parallelize this part.
9221 !
9222 !      do i=igrad_start,igrad_end
9223 !        do j=jgrad_start(i),jgrad_end(i)
9224 !          do k=1,3
9225 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9226 !          enddo
9227 !        enddo
9228 !      enddo
9229       do j=1,3
9230         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9231       enddo
9232       do i=nres-2,nnt,-1
9233         do j=1,3
9234           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9235         enddo
9236       enddo
9237 #ifdef DEBUG
9238       write (iout,*) "gradbufc after summing"
9239       do i=1,nres
9240         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9241       enddo
9242       call flush(iout)
9243 #endif
9244       else
9245 #endif
9246 !el#define DEBUG
9247 #ifdef DEBUG
9248       write (iout,*) "gradbufc"
9249       do i=1,nres
9250         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9251       enddo
9252       call flush(iout)
9253 #endif
9254 !el#undef DEBUG
9255       do i=1,nres
9256         do j=1,3
9257           gradbufc_sum(j,i)=gradbufc(j,i)
9258           gradbufc(j,i)=0.0d0
9259         enddo
9260       enddo
9261       do j=1,3
9262         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9263       enddo
9264       do i=nres-2,nnt,-1
9265         do j=1,3
9266           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9267         enddo
9268       enddo
9269 !      do i=nnt,nres-1
9270 !        do k=1,3
9271 !          gradbufc(k,i)=0.0d0
9272 !        enddo
9273 !        do j=i+1,nres
9274 !          do k=1,3
9275 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9276 !          enddo
9277 !        enddo
9278 !      enddo
9279 !el#define DEBUG
9280 #ifdef DEBUG
9281       write (iout,*) "gradbufc after summing"
9282       do i=1,nres
9283         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9284       enddo
9285       call flush(iout)
9286 #endif
9287 !el#undef DEBUG
9288 #ifdef MPI
9289       endif
9290 #endif
9291       do k=1,3
9292         gradbufc(k,nres)=0.0d0
9293       enddo
9294 !el----------------
9295 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9296 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9297 !el-----------------
9298       do i=1,nct
9299         do j=1,3
9300 #ifdef SPLITELE
9301           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9302                       wel_loc*gel_loc(j,i)+ &
9303                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9304                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9305                       wel_loc*gel_loc_long(j,i)+ &
9306                       wcorr*gradcorr_long(j,i)+ &
9307                       wcorr5*gradcorr5_long(j,i)+ &
9308                       wcorr6*gradcorr6_long(j,i)+ &
9309                       wturn6*gcorr6_turn_long(j,i))+ &
9310                       wbond*gradb(j,i)+ &
9311                       wcorr*gradcorr(j,i)+ &
9312                       wturn3*gcorr3_turn(j,i)+ &
9313                       wturn4*gcorr4_turn(j,i)+ &
9314                       wcorr5*gradcorr5(j,i)+ &
9315                       wcorr6*gradcorr6(j,i)+ &
9316                       wturn6*gcorr6_turn(j,i)+ &
9317                       wsccor*gsccorc(j,i) &
9318                      +wscloc*gscloc(j,i)
9319 #else
9320           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9321                       wel_loc*gel_loc(j,i)+ &
9322                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9323                       welec*gelc_long(j,i)+ &
9324                       wel_loc*gel_loc_long(j,i)+ &
9325 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9326                       wcorr5*gradcorr5_long(j,i)+ &
9327                       wcorr6*gradcorr6_long(j,i)+ &
9328                       wturn6*gcorr6_turn_long(j,i))+ &
9329                       wbond*gradb(j,i)+ &
9330                       wcorr*gradcorr(j,i)+ &
9331                       wturn3*gcorr3_turn(j,i)+ &
9332                       wturn4*gcorr4_turn(j,i)+ &
9333                       wcorr5*gradcorr5(j,i)+ &
9334                       wcorr6*gradcorr6(j,i)+ &
9335                       wturn6*gcorr6_turn(j,i)+ &
9336                       wsccor*gsccorc(j,i) &
9337                      +wscloc*gscloc(j,i)
9338 #endif
9339           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9340                         wbond*gradbx(j,i)+ &
9341                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9342                         wsccor*gsccorx(j,i) &
9343                        +wscloc*gsclocx(j,i)
9344         enddo
9345       enddo
9346 #ifdef DEBUG
9347       write (iout,*) "gloc before adding corr"
9348       do i=1,4*nres
9349         write (iout,*) i,gloc(i,icg)
9350       enddo
9351 #endif
9352       do i=1,nres-3
9353         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9354          +wcorr5*g_corr5_loc(i) &
9355          +wcorr6*g_corr6_loc(i) &
9356          +wturn4*gel_loc_turn4(i) &
9357          +wturn3*gel_loc_turn3(i) &
9358          +wturn6*gel_loc_turn6(i) &
9359          +wel_loc*gel_loc_loc(i)
9360       enddo
9361 #ifdef DEBUG
9362       write (iout,*) "gloc after adding corr"
9363       do i=1,4*nres
9364         write (iout,*) i,gloc(i,icg)
9365       enddo
9366 #endif
9367 #ifdef MPI
9368       if (nfgtasks.gt.1) then
9369         do j=1,3
9370           do i=1,nres
9371             gradbufc(j,i)=gradc(j,i,icg)
9372             gradbufx(j,i)=gradx(j,i,icg)
9373           enddo
9374         enddo
9375         do i=1,4*nres
9376           glocbuf(i)=gloc(i,icg)
9377         enddo
9378 !#define DEBUG
9379 #ifdef DEBUG
9380       write (iout,*) "gloc_sc before reduce"
9381       do i=1,nres
9382        do j=1,1
9383         write (iout,*) i,j,gloc_sc(j,i,icg)
9384        enddo
9385       enddo
9386 #endif
9387 !#undef DEBUG
9388         do i=1,nres
9389          do j=1,3
9390           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9391          enddo
9392         enddo
9393         time00=MPI_Wtime()
9394         call MPI_Barrier(FG_COMM,IERR)
9395         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9396         time00=MPI_Wtime()
9397         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9398           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9399         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9400           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9401         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9402           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9403         time_reduce=time_reduce+MPI_Wtime()-time00
9404         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9405           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9406         time_reduce=time_reduce+MPI_Wtime()-time00
9407 !#define DEBUG
9408 #ifdef DEBUG
9409       write (iout,*) "gloc_sc after reduce"
9410       do i=1,nres
9411        do j=1,1
9412         write (iout,*) i,j,gloc_sc(j,i,icg)
9413        enddo
9414       enddo
9415 #endif
9416 !#undef DEBUG
9417 #ifdef DEBUG
9418       write (iout,*) "gloc after reduce"
9419       do i=1,4*nres
9420         write (iout,*) i,gloc(i,icg)
9421       enddo
9422 #endif
9423       endif
9424 #endif
9425       if (gnorm_check) then
9426 !
9427 ! Compute the maximum elements of the gradient
9428 !
9429       gvdwc_max=0.0d0
9430       gvdwc_scp_max=0.0d0
9431       gelc_max=0.0d0
9432       gvdwpp_max=0.0d0
9433       gradb_max=0.0d0
9434       ghpbc_max=0.0d0
9435       gradcorr_max=0.0d0
9436       gel_loc_max=0.0d0
9437       gcorr3_turn_max=0.0d0
9438       gcorr4_turn_max=0.0d0
9439       gradcorr5_max=0.0d0
9440       gradcorr6_max=0.0d0
9441       gcorr6_turn_max=0.0d0
9442       gsccorc_max=0.0d0
9443       gscloc_max=0.0d0
9444       gvdwx_max=0.0d0
9445       gradx_scp_max=0.0d0
9446       ghpbx_max=0.0d0
9447       gradxorr_max=0.0d0
9448       gsccorx_max=0.0d0
9449       gsclocx_max=0.0d0
9450       do i=1,nct
9451         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9452         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9453         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9454         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9455          gvdwc_scp_max=gvdwc_scp_norm
9456         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9457         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9458         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9459         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9460         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9461         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9462         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9463         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9464         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9465         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9466         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9467         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9468         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9469           gcorr3_turn(1,i)))
9470         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9471           gcorr3_turn_max=gcorr3_turn_norm
9472         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9473           gcorr4_turn(1,i)))
9474         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9475           gcorr4_turn_max=gcorr4_turn_norm
9476         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9477         if (gradcorr5_norm.gt.gradcorr5_max) &
9478           gradcorr5_max=gradcorr5_norm
9479         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9480         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9481         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9482           gcorr6_turn(1,i)))
9483         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9484           gcorr6_turn_max=gcorr6_turn_norm
9485         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9486         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9487         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9488         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9489         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9490         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9491         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9492         if (gradx_scp_norm.gt.gradx_scp_max) &
9493           gradx_scp_max=gradx_scp_norm
9494         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9495         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9496         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9497         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9498         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9499         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9500         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9501         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9502       enddo
9503       if (gradout) then
9504 #ifdef AIX
9505         open(istat,file=statname,position="append")
9506 #else
9507         open(istat,file=statname,access="append")
9508 #endif
9509         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9510            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9511            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9512            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9513            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9514            gsccorx_max,gsclocx_max
9515         close(istat)
9516         if (gvdwc_max.gt.1.0d4) then
9517           write (iout,*) "gvdwc gvdwx gradb gradbx"
9518           do i=nnt,nct
9519             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9520               gradb(j,i),gradbx(j,i),j=1,3)
9521           enddo
9522           call pdbout(0.0d0,'cipiszcze',iout)
9523           call flush(iout)
9524         endif
9525       endif
9526       endif
9527 !el#define DEBUG
9528 #ifdef DEBUG
9529       write (iout,*) "gradc gradx gloc"
9530       do i=1,nres
9531         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9532          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9533       enddo
9534 #endif
9535 !el#undef DEBUG
9536 #ifdef TIMING
9537       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9538 #endif
9539       return
9540       end subroutine sum_gradient
9541 !-----------------------------------------------------------------------------
9542       subroutine sc_grad
9543 !      implicit real*8 (a-h,o-z)
9544       use calc_data
9545 !      include 'DIMENSIONS'
9546 !      include 'COMMON.CHAIN'
9547 !      include 'COMMON.DERIV'
9548 !      include 'COMMON.CALC'
9549 !      include 'COMMON.IOUNITS'
9550       real(kind=8), dimension(3) :: dcosom1,dcosom2
9551
9552       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9553       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9554       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9555            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9556 ! diagnostics only
9557 !      eom1=0.0d0
9558 !      eom2=0.0d0
9559 !      eom12=evdwij*eps1_om12
9560 ! end diagnostics
9561 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9562 !       " sigder",sigder
9563 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9564 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9565       do k=1,3
9566         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9567         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9568       enddo
9569       do k=1,3
9570         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
9571       enddo
9572 !      write (iout,*) "gg",(gg(k),k=1,3)
9573       do k=1,3
9574         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9575                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9576                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9577         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9578                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9579                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9580 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9581 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9582 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9583 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9584       enddo
9585 !
9586 ! Calculate the components of the gradient in DC and X
9587 !
9588 !grad      do k=i,j-1
9589 !grad        do l=1,3
9590 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9591 !grad        enddo
9592 !grad      enddo
9593       do l=1,3
9594         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9595         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9596       enddo
9597       return
9598       end subroutine sc_grad
9599 #ifdef CRYST_THETA
9600 !-----------------------------------------------------------------------------
9601       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9602
9603       use comm_calcthet
9604 !      implicit real*8 (a-h,o-z)
9605 !      include 'DIMENSIONS'
9606 !      include 'COMMON.LOCAL'
9607 !      include 'COMMON.IOUNITS'
9608 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9609 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9610 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9611       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9612       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9613 !el      integer :: it
9614 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9615 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9616 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9617 !el local variables
9618
9619       delthec=thetai-thet_pred_mean
9620       delthe0=thetai-theta0i
9621 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9622       t3 = thetai-thet_pred_mean
9623       t6 = t3**2
9624       t9 = term1
9625       t12 = t3*sigcsq
9626       t14 = t12+t6*sigsqtc
9627       t16 = 1.0d0
9628       t21 = thetai-theta0i
9629       t23 = t21**2
9630       t26 = term2
9631       t27 = t21*t26
9632       t32 = termexp
9633       t40 = t32**2
9634       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9635        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9636        *(-t12*t9-ak*sig0inv*t27)
9637       return
9638       end subroutine mixder
9639 #endif
9640 !-----------------------------------------------------------------------------
9641 ! cartder.F
9642 !-----------------------------------------------------------------------------
9643       subroutine cartder
9644 !-----------------------------------------------------------------------------
9645 ! This subroutine calculates the derivatives of the consecutive virtual
9646 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9647 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9648 ! in the angles alpha and omega, describing the location of a side chain
9649 ! in its local coordinate system.
9650 !
9651 ! The derivatives are stored in the following arrays:
9652 !
9653 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9654 ! The structure is as follows:
9655 !
9656 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9657 ! 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)
9658 !         . . . . . . . . . . . .  . . . . . .
9659 ! 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)
9660 !                          .
9661 !                          .
9662 !                          .
9663 ! 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)
9664 !
9665 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9666 ! The structure is same as above.
9667 !
9668 ! DCDS - the derivatives of the side chain vectors in the local spherical
9669 ! andgles alph and omega:
9670 !
9671 ! 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)
9672 ! 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)
9673 !                          .
9674 !                          .
9675 !                          .
9676 ! 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)
9677 !
9678 ! Version of March '95, based on an early version of November '91.
9679 !
9680 !**********************************************************************
9681 !      implicit real*8 (a-h,o-z)
9682 !      include 'DIMENSIONS'
9683 !      include 'COMMON.VAR'
9684 !      include 'COMMON.CHAIN'
9685 !      include 'COMMON.DERIV'
9686 !      include 'COMMON.GEO'
9687 !      include 'COMMON.LOCAL'
9688 !      include 'COMMON.INTERACT'
9689       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9690       real(kind=8),dimension(3,3) :: dp,temp
9691 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9692       real(kind=8),dimension(3) :: xx,xx1
9693 !el local variables
9694       integer :: i,k,l,j,m,ind,ind1,jjj
9695       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9696                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9697                  sint2,xp,yp,xxp,yyp,zzp,dj
9698
9699 !      common /przechowalnia/ fromto
9700       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9701 ! get the position of the jth ijth fragment of the chain coordinate system
9702 ! in the fromto array.
9703 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9704 !
9705 !      maxdim=(nres-1)*(nres-2)/2
9706 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9707 ! calculate the derivatives of transformation matrix elements in theta
9708 !
9709
9710 !el      call flush(iout) !el
9711       do i=1,nres-2
9712         rdt(1,1,i)=-rt(1,2,i)
9713         rdt(1,2,i)= rt(1,1,i)
9714         rdt(1,3,i)= 0.0d0
9715         rdt(2,1,i)=-rt(2,2,i)
9716         rdt(2,2,i)= rt(2,1,i)
9717         rdt(2,3,i)= 0.0d0
9718         rdt(3,1,i)=-rt(3,2,i)
9719         rdt(3,2,i)= rt(3,1,i)
9720         rdt(3,3,i)= 0.0d0
9721       enddo
9722 !
9723 ! derivatives in phi
9724 !
9725       do i=2,nres-2
9726         drt(1,1,i)= 0.0d0
9727         drt(1,2,i)= 0.0d0
9728         drt(1,3,i)= 0.0d0
9729         drt(2,1,i)= rt(3,1,i)
9730         drt(2,2,i)= rt(3,2,i)
9731         drt(2,3,i)= rt(3,3,i)
9732         drt(3,1,i)=-rt(2,1,i)
9733         drt(3,2,i)=-rt(2,2,i)
9734         drt(3,3,i)=-rt(2,3,i)
9735       enddo
9736 !
9737 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9738 !
9739       do i=2,nres-2
9740         ind=indmat(i,i+1)
9741         do k=1,3
9742           do l=1,3
9743             temp(k,l)=rt(k,l,i)
9744           enddo
9745         enddo
9746         do k=1,3
9747           do l=1,3
9748             fromto(k,l,ind)=temp(k,l)
9749           enddo
9750         enddo
9751         do j=i+1,nres-2
9752           ind=indmat(i,j+1)
9753           do k=1,3
9754             do l=1,3
9755               dpkl=0.0d0
9756               do m=1,3
9757                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9758               enddo
9759               dp(k,l)=dpkl
9760               fromto(k,l,ind)=dpkl
9761             enddo
9762           enddo
9763           do k=1,3
9764             do l=1,3
9765               temp(k,l)=dp(k,l)
9766             enddo
9767           enddo
9768         enddo
9769       enddo
9770 !
9771 ! Calculate derivatives.
9772 !
9773       ind1=0
9774       do i=1,nres-2
9775         ind1=ind1+1
9776 !
9777 ! Derivatives of DC(i+1) in theta(i+2)
9778 !
9779         do j=1,3
9780           do k=1,2
9781             dpjk=0.0D0
9782             do l=1,3
9783               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9784             enddo
9785             dp(j,k)=dpjk
9786             prordt(j,k,i)=dp(j,k)
9787           enddo
9788           dp(j,3)=0.0D0
9789           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9790         enddo
9791 !
9792 ! Derivatives of SC(i+1) in theta(i+2)
9793 !
9794         xx1(1)=-0.5D0*xloc(2,i+1)
9795         xx1(2)= 0.5D0*xloc(1,i+1)
9796         do j=1,3
9797           xj=0.0D0
9798           do k=1,2
9799             xj=xj+r(j,k,i)*xx1(k)
9800           enddo
9801           xx(j)=xj
9802         enddo
9803         do j=1,3
9804           rj=0.0D0
9805           do k=1,3
9806             rj=rj+prod(j,k,i)*xx(k)
9807           enddo
9808           dxdv(j,ind1)=rj
9809         enddo
9810 !
9811 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9812 ! than the other off-diagonal derivatives.
9813 !
9814         do j=1,3
9815           dxoiij=0.0D0
9816           do k=1,3
9817             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9818           enddo
9819           dxdv(j,ind1+1)=dxoiij
9820         enddo
9821 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9822 !
9823 ! Derivatives of DC(i+1) in phi(i+2)
9824 !
9825         do j=1,3
9826           do k=1,3
9827             dpjk=0.0
9828             do l=2,3
9829               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9830             enddo
9831             dp(j,k)=dpjk
9832             prodrt(j,k,i)=dp(j,k)
9833           enddo
9834           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9835         enddo
9836 !
9837 ! Derivatives of SC(i+1) in phi(i+2)
9838 !
9839         xx(1)= 0.0D0
9840         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9841         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9842         do j=1,3
9843           rj=0.0D0
9844           do k=2,3
9845             rj=rj+prod(j,k,i)*xx(k)
9846           enddo
9847           dxdv(j+3,ind1)=-rj
9848         enddo
9849 !
9850 ! Derivatives of SC(i+1) in phi(i+3).
9851 !
9852         do j=1,3
9853           dxoiij=0.0D0
9854           do k=1,3
9855             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9856           enddo
9857           dxdv(j+3,ind1+1)=dxoiij
9858         enddo
9859 !
9860 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9861 ! theta(nres) and phi(i+3) thru phi(nres).
9862 !
9863         do j=i+1,nres-2
9864           ind1=ind1+1
9865           ind=indmat(i+1,j+1)
9866 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9867           do k=1,3
9868             do l=1,3
9869               tempkl=0.0D0
9870               do m=1,2
9871                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9872               enddo
9873               temp(k,l)=tempkl
9874             enddo
9875           enddo
9876 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9877 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9878 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9879 ! Derivatives of virtual-bond vectors in theta
9880           do k=1,3
9881             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9882           enddo
9883 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9884 ! Derivatives of SC vectors in theta
9885           do k=1,3
9886             dxoijk=0.0D0
9887             do l=1,3
9888               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9889             enddo
9890             dxdv(k,ind1+1)=dxoijk
9891           enddo
9892 !
9893 !--- Calculate the derivatives in phi
9894 !
9895           do k=1,3
9896             do l=1,3
9897               tempkl=0.0D0
9898               do m=1,3
9899                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9900               enddo
9901               temp(k,l)=tempkl
9902             enddo
9903           enddo
9904           do k=1,3
9905             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9906           enddo
9907           do k=1,3
9908             dxoijk=0.0D0
9909             do l=1,3
9910               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9911             enddo
9912             dxdv(k+3,ind1+1)=dxoijk
9913           enddo
9914         enddo
9915       enddo
9916 !
9917 ! Derivatives in alpha and omega:
9918 !
9919       do i=2,nres-1
9920 !       dsci=dsc(itype(i))
9921         dsci=vbld(i+nres)
9922 #ifdef OSF
9923         alphi=alph(i)
9924         omegi=omeg(i)
9925         if(alphi.ne.alphi) alphi=100.0
9926         if(omegi.ne.omegi) omegi=-100.0
9927 #else
9928         alphi=alph(i)
9929         omegi=omeg(i)
9930 #endif
9931 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
9932         cosalphi=dcos(alphi)
9933         sinalphi=dsin(alphi)
9934         cosomegi=dcos(omegi)
9935         sinomegi=dsin(omegi)
9936         temp(1,1)=-dsci*sinalphi
9937         temp(2,1)= dsci*cosalphi*cosomegi
9938         temp(3,1)=-dsci*cosalphi*sinomegi
9939         temp(1,2)=0.0D0
9940         temp(2,2)=-dsci*sinalphi*sinomegi
9941         temp(3,2)=-dsci*sinalphi*cosomegi
9942         theta2=pi-0.5D0*theta(i+1)
9943         cost2=dcos(theta2)
9944         sint2=dsin(theta2)
9945         jjj=0
9946 !d      print *,((temp(l,k),l=1,3),k=1,2)
9947         do j=1,2
9948           xp=temp(1,j)
9949           yp=temp(2,j)
9950           xxp= xp*cost2+yp*sint2
9951           yyp=-xp*sint2+yp*cost2
9952           zzp=temp(3,j)
9953           xx(1)=xxp
9954           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
9955           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
9956           do k=1,3
9957             dj=0.0D0
9958             do l=1,3
9959               dj=dj+prod(k,l,i-1)*xx(l)
9960             enddo
9961             dxds(jjj+k,i)=dj
9962           enddo
9963           jjj=jjj+3
9964         enddo
9965       enddo
9966       return
9967       end subroutine cartder
9968 !-----------------------------------------------------------------------------
9969 ! checkder_p.F
9970 !-----------------------------------------------------------------------------
9971       subroutine check_cartgrad
9972 ! Check the gradient of Cartesian coordinates in internal coordinates.
9973 !      implicit real*8 (a-h,o-z)
9974 !      include 'DIMENSIONS'
9975 !      include 'COMMON.IOUNITS'
9976 !      include 'COMMON.VAR'
9977 !      include 'COMMON.CHAIN'
9978 !      include 'COMMON.GEO'
9979 !      include 'COMMON.LOCAL'
9980 !      include 'COMMON.DERIV'
9981       real(kind=8),dimension(6,nres) :: temp
9982       real(kind=8),dimension(3) :: xx,gg
9983       integer :: i,k,j,ii
9984       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
9985 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9986 !
9987 ! Check the gradient of the virtual-bond and SC vectors in the internal
9988 ! coordinates.
9989 !
9990       aincr=1.0d-7
9991       aincr2=5.0d-8
9992       call cartder
9993       write (iout,'(a)') '**************** dx/dalpha'
9994       write (iout,'(a)')
9995       do i=2,nres-1
9996         alphi=alph(i)
9997         alph(i)=alph(i)+aincr
9998         do k=1,3
9999           temp(k,i)=dc(k,nres+i)
10000         enddo
10001         call chainbuild
10002         do k=1,3
10003           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10004           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10005         enddo
10006         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10007         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10008         write (iout,'(a)')
10009         alph(i)=alphi
10010         call chainbuild
10011       enddo
10012       write (iout,'(a)')
10013       write (iout,'(a)') '**************** dx/domega'
10014       write (iout,'(a)')
10015       do i=2,nres-1
10016         omegi=omeg(i)
10017         omeg(i)=omeg(i)+aincr
10018         do k=1,3
10019           temp(k,i)=dc(k,nres+i)
10020         enddo
10021         call chainbuild
10022         do k=1,3
10023           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10024           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10025                 (aincr*dabs(dxds(k+3,i))+aincr))
10026         enddo
10027         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10028             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10029         write (iout,'(a)')
10030         omeg(i)=omegi
10031         call chainbuild
10032       enddo
10033       write (iout,'(a)')
10034       write (iout,'(a)') '**************** dx/dtheta'
10035       write (iout,'(a)')
10036       do i=3,nres
10037         theti=theta(i)
10038         theta(i)=theta(i)+aincr
10039         do j=i-1,nres-1
10040           do k=1,3
10041             temp(k,j)=dc(k,nres+j)
10042           enddo
10043         enddo
10044         call chainbuild
10045         do j=i-1,nres-1
10046           ii = indmat(i-2,j)
10047 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10048           do k=1,3
10049             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10050             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10051                   (aincr*dabs(dxdv(k,ii))+aincr))
10052           enddo
10053           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10054               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10055           write(iout,'(a)')
10056         enddo
10057         write (iout,'(a)')
10058         theta(i)=theti
10059         call chainbuild
10060       enddo
10061       write (iout,'(a)') '***************** dx/dphi'
10062       write (iout,'(a)')
10063       do i=4,nres
10064         phi(i)=phi(i)+aincr
10065         do j=i-1,nres-1
10066           do k=1,3
10067             temp(k,j)=dc(k,nres+j)
10068           enddo
10069         enddo
10070         call chainbuild
10071         do j=i-1,nres-1
10072           ii = indmat(i-2,j)
10073 !         print *,'ii=',ii
10074           do k=1,3
10075             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10076             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10077                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10078           enddo
10079           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10080               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10081           write(iout,'(a)')
10082         enddo
10083         phi(i)=phi(i)-aincr
10084         call chainbuild
10085       enddo
10086       write (iout,'(a)') '****************** ddc/dtheta'
10087       do i=1,nres-2
10088         thet=theta(i+2)
10089         theta(i+2)=thet+aincr
10090         do j=i,nres
10091           do k=1,3
10092             temp(k,j)=dc(k,j)
10093           enddo
10094         enddo
10095         call chainbuild
10096         do j=i+1,nres-1
10097           ii = indmat(i,j)
10098 !         print *,'ii=',ii
10099           do k=1,3
10100             gg(k)=(dc(k,j)-temp(k,j))/aincr
10101             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10102                  (aincr*dabs(dcdv(k,ii))+aincr))
10103           enddo
10104           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10105                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10106           write (iout,'(a)')
10107         enddo
10108         do j=1,nres
10109           do k=1,3
10110             dc(k,j)=temp(k,j)
10111           enddo
10112         enddo
10113         theta(i+2)=thet
10114       enddo
10115       write (iout,'(a)') '******************* ddc/dphi'
10116       do i=1,nres-3
10117         phii=phi(i+3)
10118         phi(i+3)=phii+aincr
10119         do j=1,nres
10120           do k=1,3
10121             temp(k,j)=dc(k,j)
10122           enddo
10123         enddo
10124         call chainbuild
10125         do j=i+2,nres-1
10126           ii = indmat(i+1,j)
10127 !         print *,'ii=',ii
10128           do k=1,3
10129             gg(k)=(dc(k,j)-temp(k,j))/aincr
10130             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10131                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10132           enddo
10133           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10134                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10135           write (iout,'(a)')
10136         enddo
10137         do j=1,nres
10138           do k=1,3
10139             dc(k,j)=temp(k,j)
10140           enddo
10141         enddo
10142         phi(i+3)=phii
10143       enddo
10144       return
10145       end subroutine check_cartgrad
10146 !-----------------------------------------------------------------------------
10147       subroutine check_ecart
10148 ! Check the gradient of the energy in Cartesian coordinates.
10149 !     implicit real*8 (a-h,o-z)
10150 !     include 'DIMENSIONS'
10151 !     include 'COMMON.CHAIN'
10152 !     include 'COMMON.DERIV'
10153 !     include 'COMMON.IOUNITS'
10154 !     include 'COMMON.VAR'
10155 !     include 'COMMON.CONTACTS'
10156       use comm_srutu
10157 !el      integer :: icall
10158 !el      common /srutu/ icall
10159       real(kind=8),dimension(6) :: ggg
10160       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10161       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10162       real(kind=8),dimension(6,nres) :: grad_s
10163       real(kind=8),dimension(0:n_ene) :: energia,energia1
10164       integer :: uiparm(1)
10165       real(kind=8) :: urparm(1)
10166 !EL      external fdum
10167       integer :: nf,i,j,k
10168       real(kind=8) :: aincr,etot,etot1
10169       icg=1
10170       nf=0
10171       nfl=0
10172       call zerograd
10173       aincr=1.0D-7
10174       print '(a)','CG processor',me,' calling CHECK_CART.'
10175       nf=0
10176       icall=0
10177       call geom_to_var(nvar,x)
10178       call etotal(energia)
10179       etot=energia(0)
10180 !el      call enerprint(energia)
10181       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10182       icall =1
10183       do i=1,nres
10184         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10185       enddo
10186       do i=1,nres
10187         do j=1,3
10188           grad_s(j,i)=gradc(j,i,icg)
10189           grad_s(j+3,i)=gradx(j,i,icg)
10190         enddo
10191       enddo
10192       call flush(iout)
10193       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10194       do i=1,nres
10195         do j=1,3
10196           xx(j)=c(j,i+nres)
10197           ddc(j)=dc(j,i)
10198           ddx(j)=dc(j,i+nres)
10199         enddo
10200         do j=1,3
10201           dc(j,i)=dc(j,i)+aincr
10202           do k=i+1,nres
10203             c(j,k)=c(j,k)+aincr
10204             c(j,k+nres)=c(j,k+nres)+aincr
10205           enddo
10206           call etotal(energia1)
10207           etot1=energia1(0)
10208           ggg(j)=(etot1-etot)/aincr
10209           dc(j,i)=ddc(j)
10210           do k=i+1,nres
10211             c(j,k)=c(j,k)-aincr
10212             c(j,k+nres)=c(j,k+nres)-aincr
10213           enddo
10214         enddo
10215         do j=1,3
10216           c(j,i+nres)=c(j,i+nres)+aincr
10217           dc(j,i+nres)=dc(j,i+nres)+aincr
10218           call etotal(energia1)
10219           etot1=energia1(0)
10220           ggg(j+3)=(etot1-etot)/aincr
10221           c(j,i+nres)=xx(j)
10222           dc(j,i+nres)=ddx(j)
10223         enddo
10224         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10225          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10226       enddo
10227       return
10228       end subroutine check_ecart
10229 !-----------------------------------------------------------------------------
10230       subroutine check_ecartint
10231 ! Check the gradient of the energy in Cartesian coordinates.
10232       use io_base, only: intout
10233 !      implicit real*8 (a-h,o-z)
10234 !      include 'DIMENSIONS'
10235 !      include 'COMMON.CONTROL'
10236 !      include 'COMMON.CHAIN'
10237 !      include 'COMMON.DERIV'
10238 !      include 'COMMON.IOUNITS'
10239 !      include 'COMMON.VAR'
10240 !      include 'COMMON.CONTACTS'
10241 !      include 'COMMON.MD'
10242 !      include 'COMMON.LOCAL'
10243 !      include 'COMMON.SPLITELE'
10244       use comm_srutu
10245 !el      integer :: icall
10246 !el      common /srutu/ icall
10247       real(kind=8),dimension(6) :: ggg,ggg1
10248       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10249       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10250       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10251       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10252       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10253       real(kind=8),dimension(0:n_ene) :: energia,energia1
10254       integer :: uiparm(1)
10255       real(kind=8) :: urparm(1)
10256 !EL      external fdum
10257       integer :: i,j,k,nf
10258       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10259                    etot21,etot22
10260       r_cut=2.0d0
10261       rlambd=0.3d0
10262       icg=1
10263       nf=0
10264       nfl=0
10265       call intout
10266 !      call intcartderiv
10267 !      call checkintcartgrad
10268       call zerograd
10269       aincr=1.0D-5
10270       write(iout,*) 'Calling CHECK_ECARTINT.'
10271       nf=0
10272       icall=0
10273       call geom_to_var(nvar,x)
10274       if (.not.split_ene) then
10275         call etotal(energia)
10276         etot=energia(0)
10277 !el        call enerprint(energia)
10278         call flush(iout)
10279         write (iout,*) "enter cartgrad"
10280         call flush(iout)
10281         call cartgrad
10282         write (iout,*) "exit cartgrad"
10283         call flush(iout)
10284         icall =1
10285         do i=1,nres
10286           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10287         enddo
10288         do j=1,3
10289           grad_s(j,0)=gcart(j,0)
10290         enddo
10291         do i=1,nres
10292           do j=1,3
10293             grad_s(j,i)=gcart(j,i)
10294             grad_s(j+3,i)=gxcart(j,i)
10295           enddo
10296         enddo
10297       else
10298 !- split gradient check
10299         call zerograd
10300         call etotal_long(energia)
10301 !el        call enerprint(energia)
10302         call flush(iout)
10303         write (iout,*) "enter cartgrad"
10304         call flush(iout)
10305         call cartgrad
10306         write (iout,*) "exit cartgrad"
10307         call flush(iout)
10308         icall =1
10309         write (iout,*) "longrange grad"
10310         do i=1,nres
10311           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10312           (gxcart(j,i),j=1,3)
10313         enddo
10314         do j=1,3
10315           grad_s(j,0)=gcart(j,0)
10316         enddo
10317         do i=1,nres
10318           do j=1,3
10319             grad_s(j,i)=gcart(j,i)
10320             grad_s(j+3,i)=gxcart(j,i)
10321           enddo
10322         enddo
10323         call zerograd
10324         call etotal_short(energia)
10325 !el        call enerprint(energia)
10326         call flush(iout)
10327         write (iout,*) "enter cartgrad"
10328         call flush(iout)
10329         call cartgrad
10330         write (iout,*) "exit cartgrad"
10331         call flush(iout)
10332         icall =1
10333         write (iout,*) "shortrange grad"
10334         do i=1,nres
10335           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10336           (gxcart(j,i),j=1,3)
10337         enddo
10338         do j=1,3
10339           grad_s1(j,0)=gcart(j,0)
10340         enddo
10341         do i=1,nres
10342           do j=1,3
10343             grad_s1(j,i)=gcart(j,i)
10344             grad_s1(j+3,i)=gxcart(j,i)
10345           enddo
10346         enddo
10347       endif
10348       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10349       do i=0,nres
10350         do j=1,3
10351           xx(j)=c(j,i+nres)
10352           ddc(j)=dc(j,i)
10353           ddx(j)=dc(j,i+nres)
10354           do k=1,3
10355             dcnorm_safe(k)=dc_norm(k,i)
10356             dxnorm_safe(k)=dc_norm(k,i+nres)
10357           enddo
10358         enddo
10359         do j=1,3
10360           dc(j,i)=ddc(j)+aincr
10361           call chainbuild_cart
10362 #ifdef MPI
10363 ! Broadcast the order to compute internal coordinates to the slaves.
10364 !          if (nfgtasks.gt.1)
10365 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10366 #endif
10367 !          call int_from_cart1(.false.)
10368           if (.not.split_ene) then
10369             call etotal(energia1)
10370             etot1=energia1(0)
10371           else
10372 !- split gradient
10373             call etotal_long(energia1)
10374             etot11=energia1(0)
10375             call etotal_short(energia1)
10376             etot12=energia1(0)
10377 !            write (iout,*) "etot11",etot11," etot12",etot12
10378           endif
10379 !- end split gradient
10380 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10381           dc(j,i)=ddc(j)-aincr
10382           call chainbuild_cart
10383 !          call int_from_cart1(.false.)
10384           if (.not.split_ene) then
10385             call etotal(energia1)
10386             etot2=energia1(0)
10387             ggg(j)=(etot1-etot2)/(2*aincr)
10388           else
10389 !- split gradient
10390             call etotal_long(energia1)
10391             etot21=energia1(0)
10392             ggg(j)=(etot11-etot21)/(2*aincr)
10393             call etotal_short(energia1)
10394             etot22=energia1(0)
10395             ggg1(j)=(etot12-etot22)/(2*aincr)
10396 !- end split gradient
10397 !            write (iout,*) "etot21",etot21," etot22",etot22
10398           endif
10399 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10400           dc(j,i)=ddc(j)
10401           call chainbuild_cart
10402         enddo
10403         do j=1,3
10404           dc(j,i+nres)=ddx(j)+aincr
10405           call chainbuild_cart
10406 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10407 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10408 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10409 !          write (iout,*) "dxnormnorm",dsqrt(
10410 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10411 !          write (iout,*) "dxnormnormsafe",dsqrt(
10412 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10413 !          write (iout,*)
10414           if (.not.split_ene) then
10415             call etotal(energia1)
10416             etot1=energia1(0)
10417           else
10418 !- split gradient
10419             call etotal_long(energia1)
10420             etot11=energia1(0)
10421             call etotal_short(energia1)
10422             etot12=energia1(0)
10423           endif
10424 !- end split gradient
10425 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10426           dc(j,i+nres)=ddx(j)-aincr
10427           call chainbuild_cart
10428 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10429 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10430 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10431 !          write (iout,*)
10432 !          write (iout,*) "dxnormnorm",dsqrt(
10433 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10434 !          write (iout,*) "dxnormnormsafe",dsqrt(
10435 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10436           if (.not.split_ene) then
10437             call etotal(energia1)
10438             etot2=energia1(0)
10439             ggg(j+3)=(etot1-etot2)/(2*aincr)
10440           else
10441 !- split gradient
10442             call etotal_long(energia1)
10443             etot21=energia1(0)
10444             ggg(j+3)=(etot11-etot21)/(2*aincr)
10445             call etotal_short(energia1)
10446             etot22=energia1(0)
10447             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10448 !- end split gradient
10449           endif
10450 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10451           dc(j,i+nres)=ddx(j)
10452           call chainbuild_cart
10453         enddo
10454         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10455          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10456         if (split_ene) then
10457           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10458          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10459          k=1,6)
10460          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10461          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10462          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10463         endif
10464       enddo
10465       return
10466       end subroutine check_ecartint
10467 !-----------------------------------------------------------------------------
10468       subroutine check_eint
10469 ! Check the gradient of energy in internal coordinates.
10470 !      implicit real*8 (a-h,o-z)
10471 !      include 'DIMENSIONS'
10472 !      include 'COMMON.CHAIN'
10473 !      include 'COMMON.DERIV'
10474 !      include 'COMMON.IOUNITS'
10475 !      include 'COMMON.VAR'
10476 !      include 'COMMON.GEO'
10477       use comm_srutu
10478 !el      integer :: icall
10479 !el      common /srutu/ icall
10480       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10481       integer :: uiparm(1)
10482       real(kind=8) :: urparm(1)
10483       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10484       character(len=6) :: key
10485 !EL      external fdum
10486       integer :: i,ii,nf
10487       real(kind=8) :: xi,aincr,etot,etot1,etot2
10488       call zerograd
10489       aincr=1.0D-7
10490       print '(a)','Calling CHECK_INT.'
10491       nf=0
10492       nfl=0
10493       icg=1
10494       call geom_to_var(nvar,x)
10495       call var_to_geom(nvar,x)
10496       call chainbuild
10497       icall=1
10498       print *,'ICG=',ICG
10499       call etotal(energia)
10500       etot = energia(0)
10501 !el      call enerprint(energia)
10502       print *,'ICG=',ICG
10503 #ifdef MPL
10504       if (MyID.ne.BossID) then
10505         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10506         nf=x(nvar+1)
10507         nfl=x(nvar+2)
10508         icg=x(nvar+3)
10509       endif
10510 #endif
10511       nf=1
10512       nfl=3
10513 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10514       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10515 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10516       icall=1
10517       do i=1,nvar
10518         xi=x(i)
10519         x(i)=xi-0.5D0*aincr
10520         call var_to_geom(nvar,x)
10521         call chainbuild
10522         call etotal(energia1)
10523         etot1=energia1(0)
10524         x(i)=xi+0.5D0*aincr
10525         call var_to_geom(nvar,x)
10526         call chainbuild
10527         call etotal(energia2)
10528         etot2=energia2(0)
10529         gg(i)=(etot2-etot1)/aincr
10530         write (iout,*) i,etot1,etot2
10531         x(i)=xi
10532       enddo
10533       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10534           '     RelDiff*100% '
10535       do i=1,nvar
10536         if (i.le.nphi) then
10537           ii=i
10538           key = ' phi'
10539         else if (i.le.nphi+ntheta) then
10540           ii=i-nphi
10541           key=' theta'
10542         else if (i.le.nphi+ntheta+nside) then
10543            ii=i-(nphi+ntheta)
10544            key=' alpha'
10545         else
10546            ii=i-(nphi+ntheta+nside)
10547            key=' omega'
10548         endif
10549         write (iout,'(i3,a,i3,3(1pd16.6))') &
10550        i,key,ii,gg(i),gana(i),&
10551        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10552       enddo
10553       return
10554       end subroutine check_eint
10555 !-----------------------------------------------------------------------------
10556 ! econstr_local.F
10557 !-----------------------------------------------------------------------------
10558       subroutine Econstr_back
10559 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10560 !      implicit real*8 (a-h,o-z)
10561 !      include 'DIMENSIONS'
10562 !      include 'COMMON.CONTROL'
10563 !      include 'COMMON.VAR'
10564 !      include 'COMMON.MD'
10565       use MD_data
10566 !#ifndef LANG0
10567 !      include 'COMMON.LANGEVIN'
10568 !#else
10569 !      include 'COMMON.LANGEVIN.lang0'
10570 !#endif
10571 !      include 'COMMON.CHAIN'
10572 !      include 'COMMON.DERIV'
10573 !      include 'COMMON.GEO'
10574 !      include 'COMMON.LOCAL'
10575 !      include 'COMMON.INTERACT'
10576 !      include 'COMMON.IOUNITS'
10577 !      include 'COMMON.NAMES'
10578 !      include 'COMMON.TIME1'
10579       integer :: i,j,ii,k
10580       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10581
10582       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10583       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10584       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10585
10586       Uconst_back=0.0d0
10587       do i=1,nres
10588         dutheta(i)=0.0d0
10589         dugamma(i)=0.0d0
10590         do j=1,3
10591           duscdiff(j,i)=0.0d0
10592           duscdiffx(j,i)=0.0d0
10593         enddo
10594       enddo
10595       do i=1,nfrag_back
10596         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10597 !
10598 ! Deviations from theta angles
10599 !
10600         utheta_i=0.0d0
10601         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10602           dtheta_i=theta(j)-thetaref(j)
10603           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10604           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10605         enddo
10606         utheta(i)=utheta_i/(ii-1)
10607 !
10608 ! Deviations from gamma angles
10609 !
10610         ugamma_i=0.0d0
10611         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10612           dgamma_i=pinorm(phi(j)-phiref(j))
10613 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10614           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10615           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10616 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10617         enddo
10618         ugamma(i)=ugamma_i/(ii-2)
10619 !
10620 ! Deviations from local SC geometry
10621 !
10622         uscdiff(i)=0.0d0
10623         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10624           dxx=xxtab(j)-xxref(j)
10625           dyy=yytab(j)-yyref(j)
10626           dzz=zztab(j)-zzref(j)
10627           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10628           do k=1,3
10629             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10630              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10631              (ii-1)
10632             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10633              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10634              (ii-1)
10635             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10636            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10637             /(ii-1)
10638           enddo
10639 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10640 !     &      xxref(j),yyref(j),zzref(j)
10641         enddo
10642         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10643 !        write (iout,*) i," uscdiff",uscdiff(i)
10644 !
10645 ! Put together deviations from local geometry
10646 !
10647         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10648           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10649 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10650 !     &   " uconst_back",uconst_back
10651         utheta(i)=dsqrt(utheta(i))
10652         ugamma(i)=dsqrt(ugamma(i))
10653         uscdiff(i)=dsqrt(uscdiff(i))
10654       enddo
10655       return
10656       end subroutine Econstr_back
10657 !-----------------------------------------------------------------------------
10658 ! energy_p_new-sep_barrier.F
10659 !-----------------------------------------------------------------------------
10660       real(kind=8) function sscale(r)
10661 !      include "COMMON.SPLITELE"
10662       real(kind=8) :: r,gamm
10663       if(r.lt.r_cut-rlamb) then
10664         sscale=1.0d0
10665       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10666         gamm=(r-(r_cut-rlamb))/rlamb
10667         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10668       else
10669         sscale=0d0
10670       endif
10671       return
10672       end function sscale
10673 !-----------------------------------------------------------------------------
10674       subroutine elj_long(evdw)
10675 !
10676 ! This subroutine calculates the interaction energy of nonbonded side chains
10677 ! assuming the LJ potential of interaction.
10678 !
10679 !      implicit real*8 (a-h,o-z)
10680 !      include 'DIMENSIONS'
10681 !      include 'COMMON.GEO'
10682 !      include 'COMMON.VAR'
10683 !      include 'COMMON.LOCAL'
10684 !      include 'COMMON.CHAIN'
10685 !      include 'COMMON.DERIV'
10686 !      include 'COMMON.INTERACT'
10687 !      include 'COMMON.TORSION'
10688 !      include 'COMMON.SBRIDGE'
10689 !      include 'COMMON.NAMES'
10690 !      include 'COMMON.IOUNITS'
10691 !      include 'COMMON.CONTACTS'
10692       real(kind=8),parameter :: accur=1.0d-10
10693       real(kind=8),dimension(3) :: gg
10694 !el local variables
10695       integer :: i,iint,j,k,itypi,itypi1,itypj
10696       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10697       real(kind=8) :: e1,e2,evdwij,evdw
10698 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10699       evdw=0.0D0
10700       do i=iatsc_s,iatsc_e
10701         itypi=itype(i)
10702         if (itypi.eq.ntyp1) cycle
10703         itypi1=itype(i+1)
10704         xi=c(1,nres+i)
10705         yi=c(2,nres+i)
10706         zi=c(3,nres+i)
10707 !
10708 ! Calculate SC interaction energy.
10709 !
10710         do iint=1,nint_gr(i)
10711 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10712 !d   &                  'iend=',iend(i,iint)
10713           do j=istart(i,iint),iend(i,iint)
10714             itypj=itype(j)
10715             if (itypj.eq.ntyp1) cycle
10716             xj=c(1,nres+j)-xi
10717             yj=c(2,nres+j)-yi
10718             zj=c(3,nres+j)-zi
10719             rij=xj*xj+yj*yj+zj*zj
10720             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10721             if (sss.lt.1.0d0) then
10722               rrij=1.0D0/rij
10723               eps0ij=eps(itypi,itypj)
10724               fac=rrij**expon2
10725               e1=fac*fac*aa(itypi,itypj)
10726               e2=fac*bb(itypi,itypj)
10727               evdwij=e1+e2
10728               evdw=evdw+(1.0d0-sss)*evdwij
10729 !
10730 ! Calculate the components of the gradient in DC and X
10731 !
10732               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
10733               gg(1)=xj*fac
10734               gg(2)=yj*fac
10735               gg(3)=zj*fac
10736               do k=1,3
10737                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10738                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10739                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10740                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10741               enddo
10742             endif
10743           enddo      ! j
10744         enddo        ! iint
10745       enddo          ! i
10746       do i=1,nct
10747         do j=1,3
10748           gvdwc(j,i)=expon*gvdwc(j,i)
10749           gvdwx(j,i)=expon*gvdwx(j,i)
10750         enddo
10751       enddo
10752 !******************************************************************************
10753 !
10754 !                              N O T E !!!
10755 !
10756 ! To save time, the factor of EXPON has been extracted from ALL components
10757 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10758 ! use!
10759 !
10760 !******************************************************************************
10761       return
10762       end subroutine elj_long
10763 !-----------------------------------------------------------------------------
10764       subroutine elj_short(evdw)
10765 !
10766 ! This subroutine calculates the interaction energy of nonbonded side chains
10767 ! assuming the LJ potential of interaction.
10768 !
10769 !      implicit real*8 (a-h,o-z)
10770 !      include 'DIMENSIONS'
10771 !      include 'COMMON.GEO'
10772 !      include 'COMMON.VAR'
10773 !      include 'COMMON.LOCAL'
10774 !      include 'COMMON.CHAIN'
10775 !      include 'COMMON.DERIV'
10776 !      include 'COMMON.INTERACT'
10777 !      include 'COMMON.TORSION'
10778 !      include 'COMMON.SBRIDGE'
10779 !      include 'COMMON.NAMES'
10780 !      include 'COMMON.IOUNITS'
10781 !      include 'COMMON.CONTACTS'
10782       real(kind=8),parameter :: accur=1.0d-10
10783       real(kind=8),dimension(3) :: gg
10784 !el local variables
10785       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
10786       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10787       real(kind=8) :: e1,e2,evdwij,evdw
10788 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10789       evdw=0.0D0
10790       do i=iatsc_s,iatsc_e
10791         itypi=itype(i)
10792         if (itypi.eq.ntyp1) cycle
10793         itypi1=itype(i+1)
10794         xi=c(1,nres+i)
10795         yi=c(2,nres+i)
10796         zi=c(3,nres+i)
10797 ! Change 12/1/95
10798         num_conti=0
10799 !
10800 ! Calculate SC interaction energy.
10801 !
10802         do iint=1,nint_gr(i)
10803 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10804 !d   &                  'iend=',iend(i,iint)
10805           do j=istart(i,iint),iend(i,iint)
10806             itypj=itype(j)
10807             if (itypj.eq.ntyp1) cycle
10808             xj=c(1,nres+j)-xi
10809             yj=c(2,nres+j)-yi
10810             zj=c(3,nres+j)-zi
10811 ! Change 12/1/95 to calculate four-body interactions
10812             rij=xj*xj+yj*yj+zj*zj
10813             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10814             if (sss.gt.0.0d0) then
10815               rrij=1.0D0/rij
10816               eps0ij=eps(itypi,itypj)
10817               fac=rrij**expon2
10818               e1=fac*fac*aa(itypi,itypj)
10819               e2=fac*bb(itypi,itypj)
10820               evdwij=e1+e2
10821               evdw=evdw+sss*evdwij
10822 !
10823 ! Calculate the components of the gradient in DC and X
10824 !
10825               fac=-rrij*(e1+evdwij)*sss
10826               gg(1)=xj*fac
10827               gg(2)=yj*fac
10828               gg(3)=zj*fac
10829               do k=1,3
10830                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10831                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10832                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10833                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10834               enddo
10835             endif
10836           enddo      ! j
10837         enddo        ! iint
10838       enddo          ! i
10839       do i=1,nct
10840         do j=1,3
10841           gvdwc(j,i)=expon*gvdwc(j,i)
10842           gvdwx(j,i)=expon*gvdwx(j,i)
10843         enddo
10844       enddo
10845 !******************************************************************************
10846 !
10847 !                              N O T E !!!
10848 !
10849 ! To save time, the factor of EXPON has been extracted from ALL components
10850 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10851 ! use!
10852 !
10853 !******************************************************************************
10854       return
10855       end subroutine elj_short
10856 !-----------------------------------------------------------------------------
10857       subroutine eljk_long(evdw)
10858 !
10859 ! This subroutine calculates the interaction energy of nonbonded side chains
10860 ! assuming the LJK potential of interaction.
10861 !
10862 !      implicit real*8 (a-h,o-z)
10863 !      include 'DIMENSIONS'
10864 !      include 'COMMON.GEO'
10865 !      include 'COMMON.VAR'
10866 !      include 'COMMON.LOCAL'
10867 !      include 'COMMON.CHAIN'
10868 !      include 'COMMON.DERIV'
10869 !      include 'COMMON.INTERACT'
10870 !      include 'COMMON.IOUNITS'
10871 !      include 'COMMON.NAMES'
10872       real(kind=8),dimension(3) :: gg
10873       logical :: scheck
10874 !el local variables
10875       integer :: i,iint,j,k,itypi,itypi1,itypj
10876       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10877                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10878 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10879       evdw=0.0D0
10880       do i=iatsc_s,iatsc_e
10881         itypi=itype(i)
10882         if (itypi.eq.ntyp1) cycle
10883         itypi1=itype(i+1)
10884         xi=c(1,nres+i)
10885         yi=c(2,nres+i)
10886         zi=c(3,nres+i)
10887 !
10888 ! Calculate SC interaction energy.
10889 !
10890         do iint=1,nint_gr(i)
10891           do j=istart(i,iint),iend(i,iint)
10892             itypj=itype(j)
10893             if (itypj.eq.ntyp1) cycle
10894             xj=c(1,nres+j)-xi
10895             yj=c(2,nres+j)-yi
10896             zj=c(3,nres+j)-zi
10897             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10898             fac_augm=rrij**expon
10899             e_augm=augm(itypi,itypj)*fac_augm
10900             r_inv_ij=dsqrt(rrij)
10901             rij=1.0D0/r_inv_ij
10902             sss=sscale(rij/sigma(itypi,itypj))
10903             if (sss.lt.1.0d0) then
10904               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10905               fac=r_shift_inv**expon
10906               e1=fac*fac*aa(itypi,itypj)
10907               e2=fac*bb(itypi,itypj)
10908               evdwij=e_augm+e1+e2
10909 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10910 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10911 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10912 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10913 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10914 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10915 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10916               evdw=evdw+(1.0d0-sss)*evdwij
10917 !
10918 ! Calculate the components of the gradient in DC and X
10919 !
10920               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10921               fac=fac*(1.0d0-sss)
10922               gg(1)=xj*fac
10923               gg(2)=yj*fac
10924               gg(3)=zj*fac
10925               do k=1,3
10926                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10927                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10928                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10929                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10930               enddo
10931             endif
10932           enddo      ! j
10933         enddo        ! iint
10934       enddo          ! i
10935       do i=1,nct
10936         do j=1,3
10937           gvdwc(j,i)=expon*gvdwc(j,i)
10938           gvdwx(j,i)=expon*gvdwx(j,i)
10939         enddo
10940       enddo
10941       return
10942       end subroutine eljk_long
10943 !-----------------------------------------------------------------------------
10944       subroutine eljk_short(evdw)
10945 !
10946 ! This subroutine calculates the interaction energy of nonbonded side chains
10947 ! assuming the LJK potential of interaction.
10948 !
10949 !      implicit real*8 (a-h,o-z)
10950 !      include 'DIMENSIONS'
10951 !      include 'COMMON.GEO'
10952 !      include 'COMMON.VAR'
10953 !      include 'COMMON.LOCAL'
10954 !      include 'COMMON.CHAIN'
10955 !      include 'COMMON.DERIV'
10956 !      include 'COMMON.INTERACT'
10957 !      include 'COMMON.IOUNITS'
10958 !      include 'COMMON.NAMES'
10959       real(kind=8),dimension(3) :: gg
10960       logical :: scheck
10961 !el local variables
10962       integer :: i,iint,j,k,itypi,itypi1,itypj
10963       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10964                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10965 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10966       evdw=0.0D0
10967       do i=iatsc_s,iatsc_e
10968         itypi=itype(i)
10969         if (itypi.eq.ntyp1) cycle
10970         itypi1=itype(i+1)
10971         xi=c(1,nres+i)
10972         yi=c(2,nres+i)
10973         zi=c(3,nres+i)
10974 !
10975 ! Calculate SC interaction energy.
10976 !
10977         do iint=1,nint_gr(i)
10978           do j=istart(i,iint),iend(i,iint)
10979             itypj=itype(j)
10980             if (itypj.eq.ntyp1) cycle
10981             xj=c(1,nres+j)-xi
10982             yj=c(2,nres+j)-yi
10983             zj=c(3,nres+j)-zi
10984             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10985             fac_augm=rrij**expon
10986             e_augm=augm(itypi,itypj)*fac_augm
10987             r_inv_ij=dsqrt(rrij)
10988             rij=1.0D0/r_inv_ij
10989             sss=sscale(rij/sigma(itypi,itypj))
10990             if (sss.gt.0.0d0) then
10991               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10992               fac=r_shift_inv**expon
10993               e1=fac*fac*aa(itypi,itypj)
10994               e2=fac*bb(itypi,itypj)
10995               evdwij=e_augm+e1+e2
10996 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10997 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10998 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10999 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11000 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11001 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11002 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11003               evdw=evdw+sss*evdwij
11004 !
11005 ! Calculate the components of the gradient in DC and X
11006 !
11007               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11008               fac=fac*sss
11009               gg(1)=xj*fac
11010               gg(2)=yj*fac
11011               gg(3)=zj*fac
11012               do k=1,3
11013                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11014                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11015                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11016                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11017               enddo
11018             endif
11019           enddo      ! j
11020         enddo        ! iint
11021       enddo          ! i
11022       do i=1,nct
11023         do j=1,3
11024           gvdwc(j,i)=expon*gvdwc(j,i)
11025           gvdwx(j,i)=expon*gvdwx(j,i)
11026         enddo
11027       enddo
11028       return
11029       end subroutine eljk_short
11030 !-----------------------------------------------------------------------------
11031       subroutine ebp_long(evdw)
11032 !
11033 ! This subroutine calculates the interaction energy of nonbonded side chains
11034 ! assuming the Berne-Pechukas potential of interaction.
11035 !
11036       use calc_data
11037 !      implicit real*8 (a-h,o-z)
11038 !      include 'DIMENSIONS'
11039 !      include 'COMMON.GEO'
11040 !      include 'COMMON.VAR'
11041 !      include 'COMMON.LOCAL'
11042 !      include 'COMMON.CHAIN'
11043 !      include 'COMMON.DERIV'
11044 !      include 'COMMON.NAMES'
11045 !      include 'COMMON.INTERACT'
11046 !      include 'COMMON.IOUNITS'
11047 !      include 'COMMON.CALC'
11048       use comm_srutu
11049 !el      integer :: icall
11050 !el      common /srutu/ icall
11051 !     double precision rrsave(maxdim)
11052       logical :: lprn
11053 !el local variables
11054       integer :: iint,itypi,itypi1,itypj
11055       real(kind=8) :: rrij,xi,yi,zi,fac
11056       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11057       evdw=0.0D0
11058 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11059       evdw=0.0D0
11060 !     if (icall.eq.0) then
11061 !       lprn=.true.
11062 !     else
11063         lprn=.false.
11064 !     endif
11065 !el      ind=0
11066       do i=iatsc_s,iatsc_e
11067         itypi=itype(i)
11068         if (itypi.eq.ntyp1) cycle
11069         itypi1=itype(i+1)
11070         xi=c(1,nres+i)
11071         yi=c(2,nres+i)
11072         zi=c(3,nres+i)
11073         dxi=dc_norm(1,nres+i)
11074         dyi=dc_norm(2,nres+i)
11075         dzi=dc_norm(3,nres+i)
11076 !        dsci_inv=dsc_inv(itypi)
11077         dsci_inv=vbld_inv(i+nres)
11078 !
11079 ! Calculate SC interaction energy.
11080 !
11081         do iint=1,nint_gr(i)
11082           do j=istart(i,iint),iend(i,iint)
11083 !el            ind=ind+1
11084             itypj=itype(j)
11085             if (itypj.eq.ntyp1) cycle
11086 !            dscj_inv=dsc_inv(itypj)
11087             dscj_inv=vbld_inv(j+nres)
11088             chi1=chi(itypi,itypj)
11089             chi2=chi(itypj,itypi)
11090             chi12=chi1*chi2
11091             chip1=chip(itypi)
11092             chip2=chip(itypj)
11093             chip12=chip1*chip2
11094             alf1=alp(itypi)
11095             alf2=alp(itypj)
11096             alf12=0.5D0*(alf1+alf2)
11097             xj=c(1,nres+j)-xi
11098             yj=c(2,nres+j)-yi
11099             zj=c(3,nres+j)-zi
11100             dxj=dc_norm(1,nres+j)
11101             dyj=dc_norm(2,nres+j)
11102             dzj=dc_norm(3,nres+j)
11103             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11104             rij=dsqrt(rrij)
11105             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11106
11107             if (sss.lt.1.0d0) then
11108
11109 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11110               call sc_angular
11111 ! Calculate whole angle-dependent part of epsilon and contributions
11112 ! to its derivatives
11113               fac=(rrij*sigsq)**expon2
11114               e1=fac*fac*aa(itypi,itypj)
11115               e2=fac*bb(itypi,itypj)
11116               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11117               eps2der=evdwij*eps3rt
11118               eps3der=evdwij*eps2rt
11119               evdwij=evdwij*eps2rt*eps3rt
11120               evdw=evdw+evdwij*(1.0d0-sss)
11121               if (lprn) then
11122               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11123               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11124 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11125 !d     &          restyp(itypi),i,restyp(itypj),j,
11126 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11127 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11128 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11129 !d     &          evdwij
11130               endif
11131 ! Calculate gradient components.
11132               e1=e1*eps1*eps2rt**2*eps3rt**2
11133               fac=-expon*(e1+evdwij)
11134               sigder=fac/sigsq
11135               fac=rrij*fac
11136 ! Calculate radial part of the gradient
11137               gg(1)=xj*fac
11138               gg(2)=yj*fac
11139               gg(3)=zj*fac
11140 ! Calculate the angular part of the gradient and sum add the contributions
11141 ! to the appropriate components of the Cartesian gradient.
11142               call sc_grad_scale(1.0d0-sss)
11143             endif
11144           enddo      ! j
11145         enddo        ! iint
11146       enddo          ! i
11147 !     stop
11148       return
11149       end subroutine ebp_long
11150 !-----------------------------------------------------------------------------
11151       subroutine ebp_short(evdw)
11152 !
11153 ! This subroutine calculates the interaction energy of nonbonded side chains
11154 ! assuming the Berne-Pechukas potential of interaction.
11155 !
11156       use calc_data
11157 !      implicit real*8 (a-h,o-z)
11158 !      include 'DIMENSIONS'
11159 !      include 'COMMON.GEO'
11160 !      include 'COMMON.VAR'
11161 !      include 'COMMON.LOCAL'
11162 !      include 'COMMON.CHAIN'
11163 !      include 'COMMON.DERIV'
11164 !      include 'COMMON.NAMES'
11165 !      include 'COMMON.INTERACT'
11166 !      include 'COMMON.IOUNITS'
11167 !      include 'COMMON.CALC'
11168       use comm_srutu
11169 !el      integer :: icall
11170 !el      common /srutu/ icall
11171 !     double precision rrsave(maxdim)
11172       logical :: lprn
11173 !el local variables
11174       integer :: iint,itypi,itypi1,itypj
11175       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11176       real(kind=8) :: sss,e1,e2,evdw
11177       evdw=0.0D0
11178 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11179       evdw=0.0D0
11180 !     if (icall.eq.0) then
11181 !       lprn=.true.
11182 !     else
11183         lprn=.false.
11184 !     endif
11185 !el      ind=0
11186       do i=iatsc_s,iatsc_e
11187         itypi=itype(i)
11188         if (itypi.eq.ntyp1) cycle
11189         itypi1=itype(i+1)
11190         xi=c(1,nres+i)
11191         yi=c(2,nres+i)
11192         zi=c(3,nres+i)
11193         dxi=dc_norm(1,nres+i)
11194         dyi=dc_norm(2,nres+i)
11195         dzi=dc_norm(3,nres+i)
11196 !        dsci_inv=dsc_inv(itypi)
11197         dsci_inv=vbld_inv(i+nres)
11198 !
11199 ! Calculate SC interaction energy.
11200 !
11201         do iint=1,nint_gr(i)
11202           do j=istart(i,iint),iend(i,iint)
11203 !el            ind=ind+1
11204             itypj=itype(j)
11205             if (itypj.eq.ntyp1) cycle
11206 !            dscj_inv=dsc_inv(itypj)
11207             dscj_inv=vbld_inv(j+nres)
11208             chi1=chi(itypi,itypj)
11209             chi2=chi(itypj,itypi)
11210             chi12=chi1*chi2
11211             chip1=chip(itypi)
11212             chip2=chip(itypj)
11213             chip12=chip1*chip2
11214             alf1=alp(itypi)
11215             alf2=alp(itypj)
11216             alf12=0.5D0*(alf1+alf2)
11217             xj=c(1,nres+j)-xi
11218             yj=c(2,nres+j)-yi
11219             zj=c(3,nres+j)-zi
11220             dxj=dc_norm(1,nres+j)
11221             dyj=dc_norm(2,nres+j)
11222             dzj=dc_norm(3,nres+j)
11223             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11224             rij=dsqrt(rrij)
11225             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11226
11227             if (sss.gt.0.0d0) then
11228
11229 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11230               call sc_angular
11231 ! Calculate whole angle-dependent part of epsilon and contributions
11232 ! to its derivatives
11233               fac=(rrij*sigsq)**expon2
11234               e1=fac*fac*aa(itypi,itypj)
11235               e2=fac*bb(itypi,itypj)
11236               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11237               eps2der=evdwij*eps3rt
11238               eps3der=evdwij*eps2rt
11239               evdwij=evdwij*eps2rt*eps3rt
11240               evdw=evdw+evdwij*sss
11241               if (lprn) then
11242               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11243               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11244 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11245 !d     &          restyp(itypi),i,restyp(itypj),j,
11246 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11247 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11248 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11249 !d     &          evdwij
11250               endif
11251 ! Calculate gradient components.
11252               e1=e1*eps1*eps2rt**2*eps3rt**2
11253               fac=-expon*(e1+evdwij)
11254               sigder=fac/sigsq
11255               fac=rrij*fac
11256 ! Calculate radial part of the gradient
11257               gg(1)=xj*fac
11258               gg(2)=yj*fac
11259               gg(3)=zj*fac
11260 ! Calculate the angular part of the gradient and sum add the contributions
11261 ! to the appropriate components of the Cartesian gradient.
11262               call sc_grad_scale(sss)
11263             endif
11264           enddo      ! j
11265         enddo        ! iint
11266       enddo          ! i
11267 !     stop
11268       return
11269       end subroutine ebp_short
11270 !-----------------------------------------------------------------------------
11271       subroutine egb_long(evdw)
11272 !
11273 ! This subroutine calculates the interaction energy of nonbonded side chains
11274 ! assuming the Gay-Berne potential of interaction.
11275 !
11276       use calc_data
11277 !      implicit real*8 (a-h,o-z)
11278 !      include 'DIMENSIONS'
11279 !      include 'COMMON.GEO'
11280 !      include 'COMMON.VAR'
11281 !      include 'COMMON.LOCAL'
11282 !      include 'COMMON.CHAIN'
11283 !      include 'COMMON.DERIV'
11284 !      include 'COMMON.NAMES'
11285 !      include 'COMMON.INTERACT'
11286 !      include 'COMMON.IOUNITS'
11287 !      include 'COMMON.CALC'
11288 !      include 'COMMON.CONTROL'
11289       logical :: lprn
11290 !el local variables
11291       integer :: iint,itypi,itypi1,itypj
11292       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11293       real(kind=8) :: sss,e1,e2,evdw
11294       evdw=0.0D0
11295 !cccc      energy_dec=.false.
11296 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11297       evdw=0.0D0
11298       lprn=.false.
11299 !     if (icall.eq.0) lprn=.false.
11300 !el      ind=0
11301       do i=iatsc_s,iatsc_e
11302         itypi=itype(i)
11303         if (itypi.eq.ntyp1) cycle
11304         itypi1=itype(i+1)
11305         xi=c(1,nres+i)
11306         yi=c(2,nres+i)
11307         zi=c(3,nres+i)
11308         dxi=dc_norm(1,nres+i)
11309         dyi=dc_norm(2,nres+i)
11310         dzi=dc_norm(3,nres+i)
11311 !        dsci_inv=dsc_inv(itypi)
11312         dsci_inv=vbld_inv(i+nres)
11313 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11314 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11315 !
11316 ! Calculate SC interaction energy.
11317 !
11318         do iint=1,nint_gr(i)
11319           do j=istart(i,iint),iend(i,iint)
11320 !el            ind=ind+1
11321             itypj=itype(j)
11322             if (itypj.eq.ntyp1) cycle
11323 !            dscj_inv=dsc_inv(itypj)
11324             dscj_inv=vbld_inv(j+nres)
11325 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11326 !     &       1.0d0/vbld(j+nres)
11327 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11328             sig0ij=sigma(itypi,itypj)
11329             chi1=chi(itypi,itypj)
11330             chi2=chi(itypj,itypi)
11331             chi12=chi1*chi2
11332             chip1=chip(itypi)
11333             chip2=chip(itypj)
11334             chip12=chip1*chip2
11335             alf1=alp(itypi)
11336             alf2=alp(itypj)
11337             alf12=0.5D0*(alf1+alf2)
11338             xj=c(1,nres+j)-xi
11339             yj=c(2,nres+j)-yi
11340             zj=c(3,nres+j)-zi
11341             dxj=dc_norm(1,nres+j)
11342             dyj=dc_norm(2,nres+j)
11343             dzj=dc_norm(3,nres+j)
11344             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11345             rij=dsqrt(rrij)
11346             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11347
11348             if (sss.lt.1.0d0) then
11349
11350 ! Calculate angle-dependent terms of energy and contributions to their
11351 ! derivatives.
11352               call sc_angular
11353               sigsq=1.0D0/sigsq
11354               sig=sig0ij*dsqrt(sigsq)
11355               rij_shift=1.0D0/rij-sig+sig0ij
11356 ! for diagnostics; uncomment
11357 !              rij_shift=1.2*sig0ij
11358 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11359               if (rij_shift.le.0.0D0) then
11360                 evdw=1.0D20
11361 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11362 !d     &          restyp(itypi),i,restyp(itypj),j,
11363 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11364                 return
11365               endif
11366               sigder=-sig*sigsq
11367 !---------------------------------------------------------------
11368               rij_shift=1.0D0/rij_shift
11369               fac=rij_shift**expon
11370               e1=fac*fac*aa(itypi,itypj)
11371               e2=fac*bb(itypi,itypj)
11372               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11373               eps2der=evdwij*eps3rt
11374               eps3der=evdwij*eps2rt
11375 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11376 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11377               evdwij=evdwij*eps2rt*eps3rt
11378               evdw=evdw+evdwij*(1.0d0-sss)
11379               if (lprn) then
11380               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11381               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11382               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11383                 restyp(itypi),i,restyp(itypj),j,&
11384                 epsi,sigm,chi1,chi2,chip1,chip2,&
11385                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11386                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11387                 evdwij
11388               endif
11389
11390               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11391                               'evdw',i,j,evdwij
11392 !              if (energy_dec) write (iout,*) &
11393 !                              'evdw',i,j,evdwij,"egb_long"
11394
11395 ! Calculate gradient components.
11396               e1=e1*eps1*eps2rt**2*eps3rt**2
11397               fac=-expon*(e1+evdwij)*rij_shift
11398               sigder=fac*sigder
11399               fac=rij*fac
11400 !              fac=0.0d0
11401 ! Calculate the radial part of the gradient
11402               gg(1)=xj*fac
11403               gg(2)=yj*fac
11404               gg(3)=zj*fac
11405 ! Calculate angular part of the gradient.
11406               call sc_grad_scale(1.0d0-sss)
11407             endif
11408           enddo      ! j
11409         enddo        ! iint
11410       enddo          ! i
11411 !      write (iout,*) "Number of loop steps in EGB:",ind
11412 !ccc      energy_dec=.false.
11413       return
11414       end subroutine egb_long
11415 !-----------------------------------------------------------------------------
11416       subroutine egb_short(evdw)
11417 !
11418 ! This subroutine calculates the interaction energy of nonbonded side chains
11419 ! assuming the Gay-Berne potential of interaction.
11420 !
11421       use calc_data
11422 !      implicit real*8 (a-h,o-z)
11423 !      include 'DIMENSIONS'
11424 !      include 'COMMON.GEO'
11425 !      include 'COMMON.VAR'
11426 !      include 'COMMON.LOCAL'
11427 !      include 'COMMON.CHAIN'
11428 !      include 'COMMON.DERIV'
11429 !      include 'COMMON.NAMES'
11430 !      include 'COMMON.INTERACT'
11431 !      include 'COMMON.IOUNITS'
11432 !      include 'COMMON.CALC'
11433 !      include 'COMMON.CONTROL'
11434       logical :: lprn
11435 !el local variables
11436       integer :: iint,itypi,itypi1,itypj
11437       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11438       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11439       evdw=0.0D0
11440 !cccc      energy_dec=.false.
11441 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11442       evdw=0.0D0
11443       lprn=.false.
11444 !     if (icall.eq.0) lprn=.false.
11445 !el      ind=0
11446       do i=iatsc_s,iatsc_e
11447         itypi=itype(i)
11448         if (itypi.eq.ntyp1) cycle
11449         itypi1=itype(i+1)
11450         xi=c(1,nres+i)
11451         yi=c(2,nres+i)
11452         zi=c(3,nres+i)
11453         dxi=dc_norm(1,nres+i)
11454         dyi=dc_norm(2,nres+i)
11455         dzi=dc_norm(3,nres+i)
11456 !        dsci_inv=dsc_inv(itypi)
11457         dsci_inv=vbld_inv(i+nres)
11458 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11459 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11460 !
11461 ! Calculate SC interaction energy.
11462 !
11463         do iint=1,nint_gr(i)
11464           do j=istart(i,iint),iend(i,iint)
11465 !el            ind=ind+1
11466             itypj=itype(j)
11467             if (itypj.eq.ntyp1) cycle
11468 !            dscj_inv=dsc_inv(itypj)
11469             dscj_inv=vbld_inv(j+nres)
11470 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11471 !     &       1.0d0/vbld(j+nres)
11472 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11473             sig0ij=sigma(itypi,itypj)
11474             chi1=chi(itypi,itypj)
11475             chi2=chi(itypj,itypi)
11476             chi12=chi1*chi2
11477             chip1=chip(itypi)
11478             chip2=chip(itypj)
11479             chip12=chip1*chip2
11480             alf1=alp(itypi)
11481             alf2=alp(itypj)
11482             alf12=0.5D0*(alf1+alf2)
11483             xj=c(1,nres+j)-xi
11484             yj=c(2,nres+j)-yi
11485             zj=c(3,nres+j)-zi
11486             dxj=dc_norm(1,nres+j)
11487             dyj=dc_norm(2,nres+j)
11488             dzj=dc_norm(3,nres+j)
11489             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11490             rij=dsqrt(rrij)
11491             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11492
11493             if (sss.gt.0.0d0) then
11494
11495 ! Calculate angle-dependent terms of energy and contributions to their
11496 ! derivatives.
11497               call sc_angular
11498               sigsq=1.0D0/sigsq
11499               sig=sig0ij*dsqrt(sigsq)
11500               rij_shift=1.0D0/rij-sig+sig0ij
11501 ! for diagnostics; uncomment
11502 !              rij_shift=1.2*sig0ij
11503 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11504               if (rij_shift.le.0.0D0) then
11505                 evdw=1.0D20
11506 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11507 !d     &          restyp(itypi),i,restyp(itypj),j,
11508 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11509                 return
11510               endif
11511               sigder=-sig*sigsq
11512 !---------------------------------------------------------------
11513               rij_shift=1.0D0/rij_shift
11514               fac=rij_shift**expon
11515               e1=fac*fac*aa(itypi,itypj)
11516               e2=fac*bb(itypi,itypj)
11517               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11518               eps2der=evdwij*eps3rt
11519               eps3der=evdwij*eps2rt
11520 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11521 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11522               evdwij=evdwij*eps2rt*eps3rt
11523               evdw=evdw+evdwij*sss
11524               if (lprn) then
11525               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11526               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11527               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11528                 restyp(itypi),i,restyp(itypj),j,&
11529                 epsi,sigm,chi1,chi2,chip1,chip2,&
11530                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11531                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11532                 evdwij
11533               endif
11534
11535               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11536                               'evdw',i,j,evdwij
11537 !              if (energy_dec) write (iout,*) &
11538 !                              'evdw',i,j,evdwij,"egb_short"
11539
11540 ! Calculate gradient components.
11541               e1=e1*eps1*eps2rt**2*eps3rt**2
11542               fac=-expon*(e1+evdwij)*rij_shift
11543               sigder=fac*sigder
11544               fac=rij*fac
11545 !              fac=0.0d0
11546 ! Calculate the radial part of the gradient
11547               gg(1)=xj*fac
11548               gg(2)=yj*fac
11549               gg(3)=zj*fac
11550 ! Calculate angular part of the gradient.
11551               call sc_grad_scale(sss)
11552             endif
11553           enddo      ! j
11554         enddo        ! iint
11555       enddo          ! i
11556 !      write (iout,*) "Number of loop steps in EGB:",ind
11557 !ccc      energy_dec=.false.
11558       return
11559       end subroutine egb_short
11560 !-----------------------------------------------------------------------------
11561       subroutine egbv_long(evdw)
11562 !
11563 ! This subroutine calculates the interaction energy of nonbonded side chains
11564 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11565 !
11566       use calc_data
11567 !      implicit real*8 (a-h,o-z)
11568 !      include 'DIMENSIONS'
11569 !      include 'COMMON.GEO'
11570 !      include 'COMMON.VAR'
11571 !      include 'COMMON.LOCAL'
11572 !      include 'COMMON.CHAIN'
11573 !      include 'COMMON.DERIV'
11574 !      include 'COMMON.NAMES'
11575 !      include 'COMMON.INTERACT'
11576 !      include 'COMMON.IOUNITS'
11577 !      include 'COMMON.CALC'
11578       use comm_srutu
11579 !el      integer :: icall
11580 !el      common /srutu/ icall
11581       logical :: lprn
11582 !el local variables
11583       integer :: iint,itypi,itypi1,itypj
11584       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
11585       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
11586       evdw=0.0D0
11587 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11588       evdw=0.0D0
11589       lprn=.false.
11590 !     if (icall.eq.0) lprn=.true.
11591 !el      ind=0
11592       do i=iatsc_s,iatsc_e
11593         itypi=itype(i)
11594         if (itypi.eq.ntyp1) cycle
11595         itypi1=itype(i+1)
11596         xi=c(1,nres+i)
11597         yi=c(2,nres+i)
11598         zi=c(3,nres+i)
11599         dxi=dc_norm(1,nres+i)
11600         dyi=dc_norm(2,nres+i)
11601         dzi=dc_norm(3,nres+i)
11602 !        dsci_inv=dsc_inv(itypi)
11603         dsci_inv=vbld_inv(i+nres)
11604 !
11605 ! Calculate SC interaction energy.
11606 !
11607         do iint=1,nint_gr(i)
11608           do j=istart(i,iint),iend(i,iint)
11609 !el            ind=ind+1
11610             itypj=itype(j)
11611             if (itypj.eq.ntyp1) cycle
11612 !            dscj_inv=dsc_inv(itypj)
11613             dscj_inv=vbld_inv(j+nres)
11614             sig0ij=sigma(itypi,itypj)
11615             r0ij=r0(itypi,itypj)
11616             chi1=chi(itypi,itypj)
11617             chi2=chi(itypj,itypi)
11618             chi12=chi1*chi2
11619             chip1=chip(itypi)
11620             chip2=chip(itypj)
11621             chip12=chip1*chip2
11622             alf1=alp(itypi)
11623             alf2=alp(itypj)
11624             alf12=0.5D0*(alf1+alf2)
11625             xj=c(1,nres+j)-xi
11626             yj=c(2,nres+j)-yi
11627             zj=c(3,nres+j)-zi
11628             dxj=dc_norm(1,nres+j)
11629             dyj=dc_norm(2,nres+j)
11630             dzj=dc_norm(3,nres+j)
11631             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11632             rij=dsqrt(rrij)
11633
11634             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11635
11636             if (sss.lt.1.0d0) then
11637
11638 ! Calculate angle-dependent terms of energy and contributions to their
11639 ! derivatives.
11640               call sc_angular
11641               sigsq=1.0D0/sigsq
11642               sig=sig0ij*dsqrt(sigsq)
11643               rij_shift=1.0D0/rij-sig+r0ij
11644 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11645               if (rij_shift.le.0.0D0) then
11646                 evdw=1.0D20
11647                 return
11648               endif
11649               sigder=-sig*sigsq
11650 !---------------------------------------------------------------
11651               rij_shift=1.0D0/rij_shift
11652               fac=rij_shift**expon
11653               e1=fac*fac*aa(itypi,itypj)
11654               e2=fac*bb(itypi,itypj)
11655               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11656               eps2der=evdwij*eps3rt
11657               eps3der=evdwij*eps2rt
11658               fac_augm=rrij**expon
11659               e_augm=augm(itypi,itypj)*fac_augm
11660               evdwij=evdwij*eps2rt*eps3rt
11661               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
11662               if (lprn) then
11663               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11664               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11665               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11666                 restyp(itypi),i,restyp(itypj),j,&
11667                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11668                 chi1,chi2,chip1,chip2,&
11669                 eps1,eps2rt**2,eps3rt**2,&
11670                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11671                 evdwij+e_augm
11672               endif
11673 ! Calculate gradient components.
11674               e1=e1*eps1*eps2rt**2*eps3rt**2
11675               fac=-expon*(e1+evdwij)*rij_shift
11676               sigder=fac*sigder
11677               fac=rij*fac-2*expon*rrij*e_augm
11678 ! Calculate the radial part of the gradient
11679               gg(1)=xj*fac
11680               gg(2)=yj*fac
11681               gg(3)=zj*fac
11682 ! Calculate angular part of the gradient.
11683               call sc_grad_scale(1.0d0-sss)
11684             endif
11685           enddo      ! j
11686         enddo        ! iint
11687       enddo          ! i
11688       end subroutine egbv_long
11689 !-----------------------------------------------------------------------------
11690       subroutine egbv_short(evdw)
11691 !
11692 ! This subroutine calculates the interaction energy of nonbonded side chains
11693 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11694 !
11695       use calc_data
11696 !      implicit real*8 (a-h,o-z)
11697 !      include 'DIMENSIONS'
11698 !      include 'COMMON.GEO'
11699 !      include 'COMMON.VAR'
11700 !      include 'COMMON.LOCAL'
11701 !      include 'COMMON.CHAIN'
11702 !      include 'COMMON.DERIV'
11703 !      include 'COMMON.NAMES'
11704 !      include 'COMMON.INTERACT'
11705 !      include 'COMMON.IOUNITS'
11706 !      include 'COMMON.CALC'
11707       use comm_srutu
11708 !el      integer :: icall
11709 !el      common /srutu/ icall
11710       logical :: lprn
11711 !el local variables
11712       integer :: iint,itypi,itypi1,itypj
11713       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
11714       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
11715       evdw=0.0D0
11716 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11717       evdw=0.0D0
11718       lprn=.false.
11719 !     if (icall.eq.0) lprn=.true.
11720 !el      ind=0
11721       do i=iatsc_s,iatsc_e
11722         itypi=itype(i)
11723         if (itypi.eq.ntyp1) cycle
11724         itypi1=itype(i+1)
11725         xi=c(1,nres+i)
11726         yi=c(2,nres+i)
11727         zi=c(3,nres+i)
11728         dxi=dc_norm(1,nres+i)
11729         dyi=dc_norm(2,nres+i)
11730         dzi=dc_norm(3,nres+i)
11731 !        dsci_inv=dsc_inv(itypi)
11732         dsci_inv=vbld_inv(i+nres)
11733 !
11734 ! Calculate SC interaction energy.
11735 !
11736         do iint=1,nint_gr(i)
11737           do j=istart(i,iint),iend(i,iint)
11738 !el            ind=ind+1
11739             itypj=itype(j)
11740             if (itypj.eq.ntyp1) cycle
11741 !            dscj_inv=dsc_inv(itypj)
11742             dscj_inv=vbld_inv(j+nres)
11743             sig0ij=sigma(itypi,itypj)
11744             r0ij=r0(itypi,itypj)
11745             chi1=chi(itypi,itypj)
11746             chi2=chi(itypj,itypi)
11747             chi12=chi1*chi2
11748             chip1=chip(itypi)
11749             chip2=chip(itypj)
11750             chip12=chip1*chip2
11751             alf1=alp(itypi)
11752             alf2=alp(itypj)
11753             alf12=0.5D0*(alf1+alf2)
11754             xj=c(1,nres+j)-xi
11755             yj=c(2,nres+j)-yi
11756             zj=c(3,nres+j)-zi
11757             dxj=dc_norm(1,nres+j)
11758             dyj=dc_norm(2,nres+j)
11759             dzj=dc_norm(3,nres+j)
11760             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11761             rij=dsqrt(rrij)
11762
11763             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11764
11765             if (sss.gt.0.0d0) then
11766
11767 ! Calculate angle-dependent terms of energy and contributions to their
11768 ! derivatives.
11769               call sc_angular
11770               sigsq=1.0D0/sigsq
11771               sig=sig0ij*dsqrt(sigsq)
11772               rij_shift=1.0D0/rij-sig+r0ij
11773 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11774               if (rij_shift.le.0.0D0) then
11775                 evdw=1.0D20
11776                 return
11777               endif
11778               sigder=-sig*sigsq
11779 !---------------------------------------------------------------
11780               rij_shift=1.0D0/rij_shift
11781               fac=rij_shift**expon
11782               e1=fac*fac*aa(itypi,itypj)
11783               e2=fac*bb(itypi,itypj)
11784               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11785               eps2der=evdwij*eps3rt
11786               eps3der=evdwij*eps2rt
11787               fac_augm=rrij**expon
11788               e_augm=augm(itypi,itypj)*fac_augm
11789               evdwij=evdwij*eps2rt*eps3rt
11790               evdw=evdw+(evdwij+e_augm)*sss
11791               if (lprn) then
11792               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11793               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11794               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11795                 restyp(itypi),i,restyp(itypj),j,&
11796                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11797                 chi1,chi2,chip1,chip2,&
11798                 eps1,eps2rt**2,eps3rt**2,&
11799                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11800                 evdwij+e_augm
11801               endif
11802 ! Calculate gradient components.
11803               e1=e1*eps1*eps2rt**2*eps3rt**2
11804               fac=-expon*(e1+evdwij)*rij_shift
11805               sigder=fac*sigder
11806               fac=rij*fac-2*expon*rrij*e_augm
11807 ! Calculate the radial part of the gradient
11808               gg(1)=xj*fac
11809               gg(2)=yj*fac
11810               gg(3)=zj*fac
11811 ! Calculate angular part of the gradient.
11812               call sc_grad_scale(sss)
11813             endif
11814           enddo      ! j
11815         enddo        ! iint
11816       enddo          ! i
11817       end subroutine egbv_short
11818 !-----------------------------------------------------------------------------
11819       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
11820 !
11821 ! This subroutine calculates the average interaction energy and its gradient
11822 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
11823 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
11824 ! The potential depends both on the distance of peptide-group centers and on
11825 ! the orientation of the CA-CA virtual bonds.
11826 !
11827 !      implicit real*8 (a-h,o-z)
11828
11829       use comm_locel
11830 #ifdef MPI
11831       include 'mpif.h'
11832 #endif
11833 !      include 'DIMENSIONS'
11834 !      include 'COMMON.CONTROL'
11835 !      include 'COMMON.SETUP'
11836 !      include 'COMMON.IOUNITS'
11837 !      include 'COMMON.GEO'
11838 !      include 'COMMON.VAR'
11839 !      include 'COMMON.LOCAL'
11840 !      include 'COMMON.CHAIN'
11841 !      include 'COMMON.DERIV'
11842 !      include 'COMMON.INTERACT'
11843 !      include 'COMMON.CONTACTS'
11844 !      include 'COMMON.TORSION'
11845 !      include 'COMMON.VECTORS'
11846 !      include 'COMMON.FFIELD'
11847 !      include 'COMMON.TIME1'
11848       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
11849       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
11850       real(kind=8),dimension(2,2) :: acipa !el,a_temp
11851 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
11852       real(kind=8),dimension(4) :: muij
11853 !el      integer :: num_conti,j1,j2
11854 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
11855 !el                   dz_normi,xmedi,ymedi,zmedi
11856 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
11857 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
11858 !el          num_conti,j1,j2
11859 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
11860 #ifdef MOMENT
11861       real(kind=8) :: scal_el=1.0d0
11862 #else
11863       real(kind=8) :: scal_el=0.5d0
11864 #endif
11865 ! 12/13/98
11866 ! 13-go grudnia roku pamietnego...
11867       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
11868                                              0.0d0,1.0d0,0.0d0,&
11869                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
11870 !el local variables
11871       integer :: i,j,k
11872       real(kind=8) :: fac
11873       real(kind=8) :: dxj,dyj,dzj
11874       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
11875
11876 !      allocate(num_cont_hb(nres)) !(maxres)
11877 !d      write(iout,*) 'In EELEC'
11878 !d      do i=1,nloctyp
11879 !d        write(iout,*) 'Type',i
11880 !d        write(iout,*) 'B1',B1(:,i)
11881 !d        write(iout,*) 'B2',B2(:,i)
11882 !d        write(iout,*) 'CC',CC(:,:,i)
11883 !d        write(iout,*) 'DD',DD(:,:,i)
11884 !d        write(iout,*) 'EE',EE(:,:,i)
11885 !d      enddo
11886 !d      call check_vecgrad
11887 !d      stop
11888       if (icheckgrad.eq.1) then
11889         do i=1,nres-1
11890           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
11891           do k=1,3
11892             dc_norm(k,i)=dc(k,i)*fac
11893           enddo
11894 !          write (iout,*) 'i',i,' fac',fac
11895         enddo
11896       endif
11897       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
11898           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
11899           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
11900 !        call vec_and_deriv
11901 #ifdef TIMING
11902         time01=MPI_Wtime()
11903 #endif
11904         call set_matrices
11905 #ifdef TIMING
11906         time_mat=time_mat+MPI_Wtime()-time01
11907 #endif
11908       endif
11909 !d      do i=1,nres-1
11910 !d        write (iout,*) 'i=',i
11911 !d        do k=1,3
11912 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
11913 !d        enddo
11914 !d        do k=1,3
11915 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
11916 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
11917 !d        enddo
11918 !d      enddo
11919       t_eelecij=0.0d0
11920       ees=0.0D0
11921       evdw1=0.0D0
11922       eel_loc=0.0d0
11923       eello_turn3=0.0d0
11924       eello_turn4=0.0d0
11925 !el      ind=0
11926       do i=1,nres
11927         num_cont_hb(i)=0
11928       enddo
11929 !d      print '(a)','Enter EELEC'
11930 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
11931 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
11932 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
11933       do i=1,nres
11934         gel_loc_loc(i)=0.0d0
11935         gcorr_loc(i)=0.0d0
11936       enddo
11937 !
11938 !
11939 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
11940 !
11941 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
11942 !
11943       do i=iturn3_start,iturn3_end
11944         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
11945         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
11946         dxi=dc(1,i)
11947         dyi=dc(2,i)
11948         dzi=dc(3,i)
11949         dx_normi=dc_norm(1,i)
11950         dy_normi=dc_norm(2,i)
11951         dz_normi=dc_norm(3,i)
11952         xmedi=c(1,i)+0.5d0*dxi
11953         ymedi=c(2,i)+0.5d0*dyi
11954         zmedi=c(3,i)+0.5d0*dzi
11955         num_conti=0
11956         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
11957         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
11958         num_cont_hb(i)=num_conti
11959       enddo
11960       do i=iturn4_start,iturn4_end
11961         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
11962           .or. itype(i+3).eq.ntyp1 &
11963           .or. itype(i+4).eq.ntyp1) cycle
11964         dxi=dc(1,i)
11965         dyi=dc(2,i)
11966         dzi=dc(3,i)
11967         dx_normi=dc_norm(1,i)
11968         dy_normi=dc_norm(2,i)
11969         dz_normi=dc_norm(3,i)
11970         xmedi=c(1,i)+0.5d0*dxi
11971         ymedi=c(2,i)+0.5d0*dyi
11972         zmedi=c(3,i)+0.5d0*dzi
11973         num_conti=num_cont_hb(i)
11974         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
11975         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
11976           call eturn4(i,eello_turn4)
11977         num_cont_hb(i)=num_conti
11978       enddo   ! i
11979 !
11980 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
11981 !
11982       do i=iatel_s,iatel_e
11983         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
11984         dxi=dc(1,i)
11985         dyi=dc(2,i)
11986         dzi=dc(3,i)
11987         dx_normi=dc_norm(1,i)
11988         dy_normi=dc_norm(2,i)
11989         dz_normi=dc_norm(3,i)
11990         xmedi=c(1,i)+0.5d0*dxi
11991         ymedi=c(2,i)+0.5d0*dyi
11992         zmedi=c(3,i)+0.5d0*dzi
11993 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
11994         num_conti=num_cont_hb(i)
11995         do j=ielstart(i),ielend(i)
11996           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
11997           call eelecij_scale(i,j,ees,evdw1,eel_loc)
11998         enddo ! j
11999         num_cont_hb(i)=num_conti
12000       enddo   ! i
12001 !      write (iout,*) "Number of loop steps in EELEC:",ind
12002 !d      do i=1,nres
12003 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12004 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12005 !d      enddo
12006 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12007 !cc      eel_loc=eel_loc+eello_turn3
12008 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12009       return
12010       end subroutine eelec_scale
12011 !-----------------------------------------------------------------------------
12012       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12013 !      implicit real*8 (a-h,o-z)
12014
12015       use comm_locel
12016 !      include 'DIMENSIONS'
12017 #ifdef MPI
12018       include "mpif.h"
12019 #endif
12020 !      include 'COMMON.CONTROL'
12021 !      include 'COMMON.IOUNITS'
12022 !      include 'COMMON.GEO'
12023 !      include 'COMMON.VAR'
12024 !      include 'COMMON.LOCAL'
12025 !      include 'COMMON.CHAIN'
12026 !      include 'COMMON.DERIV'
12027 !      include 'COMMON.INTERACT'
12028 !      include 'COMMON.CONTACTS'
12029 !      include 'COMMON.TORSION'
12030 !      include 'COMMON.VECTORS'
12031 !      include 'COMMON.FFIELD'
12032 !      include 'COMMON.TIME1'
12033       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12034       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12035       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12036 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12037       real(kind=8),dimension(4) :: muij
12038 !el      integer :: num_conti,j1,j2
12039 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12040 !el                   dz_normi,xmedi,ymedi,zmedi
12041 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12042 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12043 !el          num_conti,j1,j2
12044 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12045 #ifdef MOMENT
12046       real(kind=8) :: scal_el=1.0d0
12047 #else
12048       real(kind=8) :: scal_el=0.5d0
12049 #endif
12050 ! 12/13/98
12051 ! 13-go grudnia roku pamietnego...
12052       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12053                                              0.0d0,1.0d0,0.0d0,&
12054                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12055 !el local variables
12056       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12057       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12058       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12059       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12060       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12061       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12062       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12063                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12064                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12065                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12066                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12067                   ecosam,ecosbm,ecosgm,ghalf,time00
12068 !      integer :: maxconts
12069 !      maxconts = nres/4
12070 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12071 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12072 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12073 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12074 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12075 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12076 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12077 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12078 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12079 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12080 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12081 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12082 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12083
12084 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12085 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12086
12087 #ifdef MPI
12088           time00=MPI_Wtime()
12089 #endif
12090 !d      write (iout,*) "eelecij",i,j
12091 !el          ind=ind+1
12092           iteli=itel(i)
12093           itelj=itel(j)
12094           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12095           aaa=app(iteli,itelj)
12096           bbb=bpp(iteli,itelj)
12097           ael6i=ael6(iteli,itelj)
12098           ael3i=ael3(iteli,itelj)
12099           dxj=dc(1,j)
12100           dyj=dc(2,j)
12101           dzj=dc(3,j)
12102           dx_normj=dc_norm(1,j)
12103           dy_normj=dc_norm(2,j)
12104           dz_normj=dc_norm(3,j)
12105           xj=c(1,j)+0.5D0*dxj-xmedi
12106           yj=c(2,j)+0.5D0*dyj-ymedi
12107           zj=c(3,j)+0.5D0*dzj-zmedi
12108           rij=xj*xj+yj*yj+zj*zj
12109           rrmij=1.0D0/rij
12110           rij=dsqrt(rij)
12111           rmij=1.0D0/rij
12112 ! For extracting the short-range part of Evdwpp
12113           sss=sscale(rij/rpp(iteli,itelj))
12114
12115           r3ij=rrmij*rmij
12116           r6ij=r3ij*r3ij
12117           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12118           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12119           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12120           fac=cosa-3.0D0*cosb*cosg
12121           ev1=aaa*r6ij*r6ij
12122 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12123           if (j.eq.i+2) ev1=scal_el*ev1
12124           ev2=bbb*r6ij
12125           fac3=ael6i*r6ij
12126           fac4=ael3i*r3ij
12127           evdwij=ev1+ev2
12128           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12129           el2=fac4*fac
12130           eesij=el1+el2
12131 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12132           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12133           ees=ees+eesij
12134           evdw1=evdw1+evdwij*(1.0d0-sss)
12135 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12136 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12137 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12138 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12139
12140           if (energy_dec) then
12141               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12142               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12143           endif
12144
12145 !
12146 ! Calculate contributions to the Cartesian gradient.
12147 !
12148 #ifdef SPLITELE
12149           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12150           facel=-3*rrmij*(el1+eesij)
12151           fac1=fac
12152           erij(1)=xj*rmij
12153           erij(2)=yj*rmij
12154           erij(3)=zj*rmij
12155 !
12156 ! Radial derivatives. First process both termini of the fragment (i,j)
12157 !
12158           ggg(1)=facel*xj
12159           ggg(2)=facel*yj
12160           ggg(3)=facel*zj
12161 !          do k=1,3
12162 !            ghalf=0.5D0*ggg(k)
12163 !            gelc(k,i)=gelc(k,i)+ghalf
12164 !            gelc(k,j)=gelc(k,j)+ghalf
12165 !          enddo
12166 ! 9/28/08 AL Gradient compotents will be summed only at the end
12167           do k=1,3
12168             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12169             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12170           enddo
12171 !
12172 ! Loop over residues i+1 thru j-1.
12173 !
12174 !grad          do k=i+1,j-1
12175 !grad            do l=1,3
12176 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12177 !grad            enddo
12178 !grad          enddo
12179           ggg(1)=facvdw*xj
12180           ggg(2)=facvdw*yj
12181           ggg(3)=facvdw*zj
12182 !          do k=1,3
12183 !            ghalf=0.5D0*ggg(k)
12184 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12185 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12186 !          enddo
12187 ! 9/28/08 AL Gradient compotents will be summed only at the end
12188           do k=1,3
12189             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12190             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12191           enddo
12192 !
12193 ! Loop over residues i+1 thru j-1.
12194 !
12195 !grad          do k=i+1,j-1
12196 !grad            do l=1,3
12197 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12198 !grad            enddo
12199 !grad          enddo
12200 #else
12201           facvdw=ev1+evdwij*(1.0d0-sss)
12202           facel=el1+eesij
12203           fac1=fac
12204           fac=-3*rrmij*(facvdw+facvdw+facel)
12205           erij(1)=xj*rmij
12206           erij(2)=yj*rmij
12207           erij(3)=zj*rmij
12208 !
12209 ! Radial derivatives. First process both termini of the fragment (i,j)
12210 !
12211           ggg(1)=fac*xj
12212           ggg(2)=fac*yj
12213           ggg(3)=fac*zj
12214 !          do k=1,3
12215 !            ghalf=0.5D0*ggg(k)
12216 !            gelc(k,i)=gelc(k,i)+ghalf
12217 !            gelc(k,j)=gelc(k,j)+ghalf
12218 !          enddo
12219 ! 9/28/08 AL Gradient compotents will be summed only at the end
12220           do k=1,3
12221             gelc_long(k,j)=gelc(k,j)+ggg(k)
12222             gelc_long(k,i)=gelc(k,i)-ggg(k)
12223           enddo
12224 !
12225 ! Loop over residues i+1 thru j-1.
12226 !
12227 !grad          do k=i+1,j-1
12228 !grad            do l=1,3
12229 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12230 !grad            enddo
12231 !grad          enddo
12232 ! 9/28/08 AL Gradient compotents will be summed only at the end
12233           ggg(1)=facvdw*xj
12234           ggg(2)=facvdw*yj
12235           ggg(3)=facvdw*zj
12236           do k=1,3
12237             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12238             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12239           enddo
12240 #endif
12241 !
12242 ! Angular part
12243 !
12244           ecosa=2.0D0*fac3*fac1+fac4
12245           fac4=-3.0D0*fac4
12246           fac3=-6.0D0*fac3
12247           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12248           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12249           do k=1,3
12250             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12251             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12252           enddo
12253 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12254 !d   &          (dcosg(k),k=1,3)
12255           do k=1,3
12256             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12257           enddo
12258 !          do k=1,3
12259 !            ghalf=0.5D0*ggg(k)
12260 !            gelc(k,i)=gelc(k,i)+ghalf
12261 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12262 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12263 !            gelc(k,j)=gelc(k,j)+ghalf
12264 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12265 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12266 !          enddo
12267 !grad          do k=i+1,j-1
12268 !grad            do l=1,3
12269 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12270 !grad            enddo
12271 !grad          enddo
12272           do k=1,3
12273             gelc(k,i)=gelc(k,i) &
12274                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12275                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12276             gelc(k,j)=gelc(k,j) &
12277                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12278                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12279             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12280             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12281           enddo
12282           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12283               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12284               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12285 !
12286 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12287 !   energy of a peptide unit is assumed in the form of a second-order
12288 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12289 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12290 !   are computed for EVERY pair of non-contiguous peptide groups.
12291 !
12292           if (j.lt.nres-1) then
12293             j1=j+1
12294             j2=j-1
12295           else
12296             j1=j-1
12297             j2=j-2
12298           endif
12299           kkk=0
12300           do k=1,2
12301             do l=1,2
12302               kkk=kkk+1
12303               muij(kkk)=mu(k,i)*mu(l,j)
12304             enddo
12305           enddo
12306 !d         write (iout,*) 'EELEC: i',i,' j',j
12307 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12308 !d          write(iout,*) 'muij',muij
12309           ury=scalar(uy(1,i),erij)
12310           urz=scalar(uz(1,i),erij)
12311           vry=scalar(uy(1,j),erij)
12312           vrz=scalar(uz(1,j),erij)
12313           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12314           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12315           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12316           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12317           fac=dsqrt(-ael6i)*r3ij
12318           a22=a22*fac
12319           a23=a23*fac
12320           a32=a32*fac
12321           a33=a33*fac
12322 !d          write (iout,'(4i5,4f10.5)')
12323 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12324 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12325 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12326 !d     &      uy(:,j),uz(:,j)
12327 !d          write (iout,'(4f10.5)')
12328 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12329 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12330 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12331 !d           write (iout,'(9f10.5/)')
12332 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12333 ! Derivatives of the elements of A in virtual-bond vectors
12334           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12335           do k=1,3
12336             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12337             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12338             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12339             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12340             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12341             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12342             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12343             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12344             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12345             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12346             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12347             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12348           enddo
12349 ! Compute radial contributions to the gradient
12350           facr=-3.0d0*rrmij
12351           a22der=a22*facr
12352           a23der=a23*facr
12353           a32der=a32*facr
12354           a33der=a33*facr
12355           agg(1,1)=a22der*xj
12356           agg(2,1)=a22der*yj
12357           agg(3,1)=a22der*zj
12358           agg(1,2)=a23der*xj
12359           agg(2,2)=a23der*yj
12360           agg(3,2)=a23der*zj
12361           agg(1,3)=a32der*xj
12362           agg(2,3)=a32der*yj
12363           agg(3,3)=a32der*zj
12364           agg(1,4)=a33der*xj
12365           agg(2,4)=a33der*yj
12366           agg(3,4)=a33der*zj
12367 ! Add the contributions coming from er
12368           fac3=-3.0d0*fac
12369           do k=1,3
12370             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12371             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12372             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12373             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12374           enddo
12375           do k=1,3
12376 ! Derivatives in DC(i)
12377 !grad            ghalf1=0.5d0*agg(k,1)
12378 !grad            ghalf2=0.5d0*agg(k,2)
12379 !grad            ghalf3=0.5d0*agg(k,3)
12380 !grad            ghalf4=0.5d0*agg(k,4)
12381             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12382             -3.0d0*uryg(k,2)*vry)!+ghalf1
12383             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12384             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12385             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12386             -3.0d0*urzg(k,2)*vry)!+ghalf3
12387             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12388             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12389 ! Derivatives in DC(i+1)
12390             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12391             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12392             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12393             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12394             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12395             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12396             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12397             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12398 ! Derivatives in DC(j)
12399             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12400             -3.0d0*vryg(k,2)*ury)!+ghalf1
12401             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12402             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12403             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12404             -3.0d0*vryg(k,2)*urz)!+ghalf3
12405             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12406             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12407 ! Derivatives in DC(j+1) or DC(nres-1)
12408             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12409             -3.0d0*vryg(k,3)*ury)
12410             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12411             -3.0d0*vrzg(k,3)*ury)
12412             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12413             -3.0d0*vryg(k,3)*urz)
12414             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12415             -3.0d0*vrzg(k,3)*urz)
12416 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12417 !grad              do l=1,4
12418 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12419 !grad              enddo
12420 !grad            endif
12421           enddo
12422           acipa(1,1)=a22
12423           acipa(1,2)=a23
12424           acipa(2,1)=a32
12425           acipa(2,2)=a33
12426           a22=-a22
12427           a23=-a23
12428           do l=1,2
12429             do k=1,3
12430               agg(k,l)=-agg(k,l)
12431               aggi(k,l)=-aggi(k,l)
12432               aggi1(k,l)=-aggi1(k,l)
12433               aggj(k,l)=-aggj(k,l)
12434               aggj1(k,l)=-aggj1(k,l)
12435             enddo
12436           enddo
12437           if (j.lt.nres-1) then
12438             a22=-a22
12439             a32=-a32
12440             do l=1,3,2
12441               do k=1,3
12442                 agg(k,l)=-agg(k,l)
12443                 aggi(k,l)=-aggi(k,l)
12444                 aggi1(k,l)=-aggi1(k,l)
12445                 aggj(k,l)=-aggj(k,l)
12446                 aggj1(k,l)=-aggj1(k,l)
12447               enddo
12448             enddo
12449           else
12450             a22=-a22
12451             a23=-a23
12452             a32=-a32
12453             a33=-a33
12454             do l=1,4
12455               do k=1,3
12456                 agg(k,l)=-agg(k,l)
12457                 aggi(k,l)=-aggi(k,l)
12458                 aggi1(k,l)=-aggi1(k,l)
12459                 aggj(k,l)=-aggj(k,l)
12460                 aggj1(k,l)=-aggj1(k,l)
12461               enddo
12462             enddo
12463           endif
12464           ENDIF ! WCORR
12465           IF (wel_loc.gt.0.0d0) THEN
12466 ! Contribution to the local-electrostatic energy coming from the i-j pair
12467           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12468            +a33*muij(4)
12469 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12470
12471           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12472                   'eelloc',i,j,eel_loc_ij
12473 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12474
12475           eel_loc=eel_loc+eel_loc_ij
12476 ! Partial derivatives in virtual-bond dihedral angles gamma
12477           if (i.gt.1) &
12478           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12479                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12480                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12481           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12482                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12483                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12484 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12485           do l=1,3
12486             ggg(l)=agg(l,1)*muij(1)+ &
12487                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12488             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12489             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12490 !grad            ghalf=0.5d0*ggg(l)
12491 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12492 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12493           enddo
12494 !grad          do k=i+1,j2
12495 !grad            do l=1,3
12496 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12497 !grad            enddo
12498 !grad          enddo
12499 ! Remaining derivatives of eello
12500           do l=1,3
12501             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12502                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12503             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12504                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12505             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12506                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12507             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12508                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12509           enddo
12510           ENDIF
12511 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12512 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12513           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12514              .and. num_conti.le.maxconts) then
12515 !            write (iout,*) i,j," entered corr"
12516 !
12517 ! Calculate the contact function. The ith column of the array JCONT will
12518 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12519 ! greater than I). The arrays FACONT and GACONT will contain the values of
12520 ! the contact function and its derivative.
12521 !           r0ij=1.02D0*rpp(iteli,itelj)
12522 !           r0ij=1.11D0*rpp(iteli,itelj)
12523             r0ij=2.20D0*rpp(iteli,itelj)
12524 !           r0ij=1.55D0*rpp(iteli,itelj)
12525             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12526 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12527             if (fcont.gt.0.0D0) then
12528               num_conti=num_conti+1
12529               if (num_conti.gt.maxconts) then
12530 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12531                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
12532                                ' will skip next contacts for this conf.',num_conti
12533               else
12534                 jcont_hb(num_conti,i)=j
12535 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
12536 !d     &           " jcont_hb",jcont_hb(num_conti,i)
12537                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
12538                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12539 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
12540 !  terms.
12541                 d_cont(num_conti,i)=rij
12542 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
12543 !     --- Electrostatic-interaction matrix ---
12544                 a_chuj(1,1,num_conti,i)=a22
12545                 a_chuj(1,2,num_conti,i)=a23
12546                 a_chuj(2,1,num_conti,i)=a32
12547                 a_chuj(2,2,num_conti,i)=a33
12548 !     --- Gradient of rij
12549                 do kkk=1,3
12550                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
12551                 enddo
12552                 kkll=0
12553                 do k=1,2
12554                   do l=1,2
12555                     kkll=kkll+1
12556                     do m=1,3
12557                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
12558                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
12559                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
12560                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
12561                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
12562                     enddo
12563                   enddo
12564                 enddo
12565                 ENDIF
12566                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
12567 ! Calculate contact energies
12568                 cosa4=4.0D0*cosa
12569                 wij=cosa-3.0D0*cosb*cosg
12570                 cosbg1=cosb+cosg
12571                 cosbg2=cosb-cosg
12572 !               fac3=dsqrt(-ael6i)/r0ij**3
12573                 fac3=dsqrt(-ael6i)*r3ij
12574 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
12575                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
12576                 if (ees0tmp.gt.0) then
12577                   ees0pij=dsqrt(ees0tmp)
12578                 else
12579                   ees0pij=0
12580                 endif
12581 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
12582                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
12583                 if (ees0tmp.gt.0) then
12584                   ees0mij=dsqrt(ees0tmp)
12585                 else
12586                   ees0mij=0
12587                 endif
12588 !               ees0mij=0.0D0
12589                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
12590                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
12591 ! Diagnostics. Comment out or remove after debugging!
12592 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
12593 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
12594 !               ees0m(num_conti,i)=0.0D0
12595 ! End diagnostics.
12596 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
12597 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
12598 ! Angular derivatives of the contact function
12599                 ees0pij1=fac3/ees0pij
12600                 ees0mij1=fac3/ees0mij
12601                 fac3p=-3.0D0*fac3*rrmij
12602                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
12603                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
12604 !               ees0mij1=0.0D0
12605                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
12606                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
12607                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
12608                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
12609                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
12610                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
12611                 ecosap=ecosa1+ecosa2
12612                 ecosbp=ecosb1+ecosb2
12613                 ecosgp=ecosg1+ecosg2
12614                 ecosam=ecosa1-ecosa2
12615                 ecosbm=ecosb1-ecosb2
12616                 ecosgm=ecosg1-ecosg2
12617 ! Diagnostics
12618 !               ecosap=ecosa1
12619 !               ecosbp=ecosb1
12620 !               ecosgp=ecosg1
12621 !               ecosam=0.0D0
12622 !               ecosbm=0.0D0
12623 !               ecosgm=0.0D0
12624 ! End diagnostics
12625                 facont_hb(num_conti,i)=fcont
12626                 fprimcont=fprimcont/rij
12627 !d              facont_hb(num_conti,i)=1.0D0
12628 ! Following line is for diagnostics.
12629 !d              fprimcont=0.0D0
12630                 do k=1,3
12631                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12632                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12633                 enddo
12634                 do k=1,3
12635                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
12636                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
12637                 enddo
12638                 gggp(1)=gggp(1)+ees0pijp*xj
12639                 gggp(2)=gggp(2)+ees0pijp*yj
12640                 gggp(3)=gggp(3)+ees0pijp*zj
12641                 gggm(1)=gggm(1)+ees0mijp*xj
12642                 gggm(2)=gggm(2)+ees0mijp*yj
12643                 gggm(3)=gggm(3)+ees0mijp*zj
12644 ! Derivatives due to the contact function
12645                 gacont_hbr(1,num_conti,i)=fprimcont*xj
12646                 gacont_hbr(2,num_conti,i)=fprimcont*yj
12647                 gacont_hbr(3,num_conti,i)=fprimcont*zj
12648                 do k=1,3
12649 !
12650 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
12651 !          following the change of gradient-summation algorithm.
12652 !
12653 !grad                  ghalfp=0.5D0*gggp(k)
12654 !grad                  ghalfm=0.5D0*gggm(k)
12655                   gacontp_hb1(k,num_conti,i)= & !ghalfp
12656                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12657                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12658                   gacontp_hb2(k,num_conti,i)= & !ghalfp
12659                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12660                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12661                   gacontp_hb3(k,num_conti,i)=gggp(k)
12662                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
12663                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12664                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12665                   gacontm_hb2(k,num_conti,i)= & !ghalfm
12666                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12667                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12668                   gacontm_hb3(k,num_conti,i)=gggm(k)
12669                 enddo
12670               ENDIF ! wcorr
12671               endif  ! num_conti.le.maxconts
12672             endif  ! fcont.gt.0
12673           endif    ! j.gt.i+1
12674           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
12675             do k=1,4
12676               do l=1,3
12677                 ghalf=0.5d0*agg(l,k)
12678                 aggi(l,k)=aggi(l,k)+ghalf
12679                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
12680                 aggj(l,k)=aggj(l,k)+ghalf
12681               enddo
12682             enddo
12683             if (j.eq.nres-1 .and. i.lt.j-2) then
12684               do k=1,4
12685                 do l=1,3
12686                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
12687                 enddo
12688               enddo
12689             endif
12690           endif
12691 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
12692       return
12693       end subroutine eelecij_scale
12694 !-----------------------------------------------------------------------------
12695       subroutine evdwpp_short(evdw1)
12696 !
12697 ! Compute Evdwpp
12698 !
12699 !      implicit real*8 (a-h,o-z)
12700 !      include 'DIMENSIONS'
12701 !      include 'COMMON.CONTROL'
12702 !      include 'COMMON.IOUNITS'
12703 !      include 'COMMON.GEO'
12704 !      include 'COMMON.VAR'
12705 !      include 'COMMON.LOCAL'
12706 !      include 'COMMON.CHAIN'
12707 !      include 'COMMON.DERIV'
12708 !      include 'COMMON.INTERACT'
12709 !      include 'COMMON.CONTACTS'
12710 !      include 'COMMON.TORSION'
12711 !      include 'COMMON.VECTORS'
12712 !      include 'COMMON.FFIELD'
12713       real(kind=8),dimension(3) :: ggg
12714 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12715 #ifdef MOMENT
12716       real(kind=8) :: scal_el=1.0d0
12717 #else
12718       real(kind=8) :: scal_el=0.5d0
12719 #endif
12720 !el local variables
12721       integer :: i,j,k,iteli,itelj,num_conti
12722       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
12723       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
12724                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12725                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
12726
12727       evdw1=0.0D0
12728 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
12729 !     & " iatel_e_vdw",iatel_e_vdw
12730       call flush(iout)
12731       do i=iatel_s_vdw,iatel_e_vdw
12732         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
12733         dxi=dc(1,i)
12734         dyi=dc(2,i)
12735         dzi=dc(3,i)
12736         dx_normi=dc_norm(1,i)
12737         dy_normi=dc_norm(2,i)
12738         dz_normi=dc_norm(3,i)
12739         xmedi=c(1,i)+0.5d0*dxi
12740         ymedi=c(2,i)+0.5d0*dyi
12741         zmedi=c(3,i)+0.5d0*dzi
12742         num_conti=0
12743 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
12744 !     &   ' ielend',ielend_vdw(i)
12745         call flush(iout)
12746         do j=ielstart_vdw(i),ielend_vdw(i)
12747           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12748 !el          ind=ind+1
12749           iteli=itel(i)
12750           itelj=itel(j)
12751           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12752           aaa=app(iteli,itelj)
12753           bbb=bpp(iteli,itelj)
12754           dxj=dc(1,j)
12755           dyj=dc(2,j)
12756           dzj=dc(3,j)
12757           dx_normj=dc_norm(1,j)
12758           dy_normj=dc_norm(2,j)
12759           dz_normj=dc_norm(3,j)
12760           xj=c(1,j)+0.5D0*dxj-xmedi
12761           yj=c(2,j)+0.5D0*dyj-ymedi
12762           zj=c(3,j)+0.5D0*dzj-zmedi
12763           rij=xj*xj+yj*yj+zj*zj
12764           rrmij=1.0D0/rij
12765           rij=dsqrt(rij)
12766           sss=sscale(rij/rpp(iteli,itelj))
12767           if (sss.gt.0.0d0) then
12768             rmij=1.0D0/rij
12769             r3ij=rrmij*rmij
12770             r6ij=r3ij*r3ij
12771             ev1=aaa*r6ij*r6ij
12772 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12773             if (j.eq.i+2) ev1=scal_el*ev1
12774             ev2=bbb*r6ij
12775             evdwij=ev1+ev2
12776             if (energy_dec) then
12777               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12778             endif
12779             evdw1=evdw1+evdwij*sss
12780 !
12781 ! Calculate contributions to the Cartesian gradient.
12782 !
12783             facvdw=-6*rrmij*(ev1+evdwij)*sss
12784             ggg(1)=facvdw*xj
12785             ggg(2)=facvdw*yj
12786             ggg(3)=facvdw*zj
12787             do k=1,3
12788               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12789               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12790             enddo
12791           endif
12792         enddo ! j
12793       enddo   ! i
12794       return
12795       end subroutine evdwpp_short
12796 !-----------------------------------------------------------------------------
12797       subroutine escp_long(evdw2,evdw2_14)
12798 !
12799 ! This subroutine calculates the excluded-volume interaction energy between
12800 ! peptide-group centers and side chains and its gradient in virtual-bond and
12801 ! side-chain vectors.
12802 !
12803 !      implicit real*8 (a-h,o-z)
12804 !      include 'DIMENSIONS'
12805 !      include 'COMMON.GEO'
12806 !      include 'COMMON.VAR'
12807 !      include 'COMMON.LOCAL'
12808 !      include 'COMMON.CHAIN'
12809 !      include 'COMMON.DERIV'
12810 !      include 'COMMON.INTERACT'
12811 !      include 'COMMON.FFIELD'
12812 !      include 'COMMON.IOUNITS'
12813 !      include 'COMMON.CONTROL'
12814       real(kind=8),dimension(3) :: ggg
12815 !el local variables
12816       integer :: i,iint,j,k,iteli,itypj
12817       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12818       real(kind=8) :: evdw2,evdw2_14,evdwij
12819       evdw2=0.0D0
12820       evdw2_14=0.0d0
12821 !d    print '(a)','Enter ESCP'
12822 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12823       do i=iatscp_s,iatscp_e
12824         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12825         iteli=itel(i)
12826         xi=0.5D0*(c(1,i)+c(1,i+1))
12827         yi=0.5D0*(c(2,i)+c(2,i+1))
12828         zi=0.5D0*(c(3,i)+c(3,i+1))
12829
12830         do iint=1,nscp_gr(i)
12831
12832         do j=iscpstart(i,iint),iscpend(i,iint)
12833           itypj=itype(j)
12834           if (itypj.eq.ntyp1) cycle
12835 ! Uncomment following three lines for SC-p interactions
12836 !         xj=c(1,nres+j)-xi
12837 !         yj=c(2,nres+j)-yi
12838 !         zj=c(3,nres+j)-zi
12839 ! Uncomment following three lines for Ca-p interactions
12840           xj=c(1,j)-xi
12841           yj=c(2,j)-yi
12842           zj=c(3,j)-zi
12843           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12844
12845           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12846
12847           if (sss.lt.1.0d0) then
12848
12849             fac=rrij**expon2
12850             e1=fac*fac*aad(itypj,iteli)
12851             e2=fac*bad(itypj,iteli)
12852             if (iabs(j-i) .le. 2) then
12853               e1=scal14*e1
12854               e2=scal14*e2
12855               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
12856             endif
12857             evdwij=e1+e2
12858             evdw2=evdw2+evdwij*(1.0d0-sss)
12859             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12860                 'evdw2',i,j,sss,evdwij
12861 !
12862 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12863 !
12864             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
12865             ggg(1)=xj*fac
12866             ggg(2)=yj*fac
12867             ggg(3)=zj*fac
12868 ! Uncomment following three lines for SC-p interactions
12869 !           do k=1,3
12870 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12871 !           enddo
12872 ! Uncomment following line for SC-p interactions
12873 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12874             do k=1,3
12875               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12876               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12877             enddo
12878           endif
12879         enddo
12880
12881         enddo ! iint
12882       enddo ! i
12883       do i=1,nct
12884         do j=1,3
12885           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12886           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12887           gradx_scp(j,i)=expon*gradx_scp(j,i)
12888         enddo
12889       enddo
12890 !******************************************************************************
12891 !
12892 !                              N O T E !!!
12893 !
12894 ! To save time the factor EXPON has been extracted from ALL components
12895 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12896 ! use!
12897 !
12898 !******************************************************************************
12899       return
12900       end subroutine escp_long
12901 !-----------------------------------------------------------------------------
12902       subroutine escp_short(evdw2,evdw2_14)
12903 !
12904 ! This subroutine calculates the excluded-volume interaction energy between
12905 ! peptide-group centers and side chains and its gradient in virtual-bond and
12906 ! side-chain vectors.
12907 !
12908 !      implicit real*8 (a-h,o-z)
12909 !      include 'DIMENSIONS'
12910 !      include 'COMMON.GEO'
12911 !      include 'COMMON.VAR'
12912 !      include 'COMMON.LOCAL'
12913 !      include 'COMMON.CHAIN'
12914 !      include 'COMMON.DERIV'
12915 !      include 'COMMON.INTERACT'
12916 !      include 'COMMON.FFIELD'
12917 !      include 'COMMON.IOUNITS'
12918 !      include 'COMMON.CONTROL'
12919       real(kind=8),dimension(3) :: ggg
12920 !el local variables
12921       integer :: i,iint,j,k,iteli,itypj
12922       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12923       real(kind=8) :: evdw2,evdw2_14,evdwij
12924       evdw2=0.0D0
12925       evdw2_14=0.0d0
12926 !d    print '(a)','Enter ESCP'
12927 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12928       do i=iatscp_s,iatscp_e
12929         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12930         iteli=itel(i)
12931         xi=0.5D0*(c(1,i)+c(1,i+1))
12932         yi=0.5D0*(c(2,i)+c(2,i+1))
12933         zi=0.5D0*(c(3,i)+c(3,i+1))
12934
12935         do iint=1,nscp_gr(i)
12936
12937         do j=iscpstart(i,iint),iscpend(i,iint)
12938           itypj=itype(j)
12939           if (itypj.eq.ntyp1) cycle
12940 ! Uncomment following three lines for SC-p interactions
12941 !         xj=c(1,nres+j)-xi
12942 !         yj=c(2,nres+j)-yi
12943 !         zj=c(3,nres+j)-zi
12944 ! Uncomment following three lines for Ca-p interactions
12945           xj=c(1,j)-xi
12946           yj=c(2,j)-yi
12947           zj=c(3,j)-zi
12948           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12949
12950           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12951
12952           if (sss.gt.0.0d0) then
12953
12954             fac=rrij**expon2
12955             e1=fac*fac*aad(itypj,iteli)
12956             e2=fac*bad(itypj,iteli)
12957             if (iabs(j-i) .le. 2) then
12958               e1=scal14*e1
12959               e2=scal14*e2
12960               evdw2_14=evdw2_14+(e1+e2)*sss
12961             endif
12962             evdwij=e1+e2
12963             evdw2=evdw2+evdwij*sss
12964             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12965                 'evdw2',i,j,sss,evdwij
12966 !
12967 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12968 !
12969             fac=-(evdwij+e1)*rrij*sss
12970             ggg(1)=xj*fac
12971             ggg(2)=yj*fac
12972             ggg(3)=zj*fac
12973 ! Uncomment following three lines for SC-p interactions
12974 !           do k=1,3
12975 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12976 !           enddo
12977 ! Uncomment following line for SC-p interactions
12978 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12979             do k=1,3
12980               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12981               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12982             enddo
12983           endif
12984         enddo
12985
12986         enddo ! iint
12987       enddo ! i
12988       do i=1,nct
12989         do j=1,3
12990           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12991           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12992           gradx_scp(j,i)=expon*gradx_scp(j,i)
12993         enddo
12994       enddo
12995 !******************************************************************************
12996 !
12997 !                              N O T E !!!
12998 !
12999 ! To save time the factor EXPON has been extracted from ALL components
13000 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13001 ! use!
13002 !
13003 !******************************************************************************
13004       return
13005       end subroutine escp_short
13006 !-----------------------------------------------------------------------------
13007 ! energy_p_new-sep_barrier.F
13008 !-----------------------------------------------------------------------------
13009       subroutine sc_grad_scale(scalfac)
13010 !      implicit real*8 (a-h,o-z)
13011       use calc_data
13012 !      include 'DIMENSIONS'
13013 !      include 'COMMON.CHAIN'
13014 !      include 'COMMON.DERIV'
13015 !      include 'COMMON.CALC'
13016 !      include 'COMMON.IOUNITS'
13017       real(kind=8),dimension(3) :: dcosom1,dcosom2
13018       real(kind=8) :: scalfac
13019 !el local variables
13020 !      integer :: i,j,k,l
13021
13022       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13023       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13024       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13025            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13026 ! diagnostics only
13027 !      eom1=0.0d0
13028 !      eom2=0.0d0
13029 !      eom12=evdwij*eps1_om12
13030 ! end diagnostics
13031 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13032 !     &  " sigder",sigder
13033 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13034 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13035       do k=1,3
13036         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13037         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13038       enddo
13039       do k=1,3
13040         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
13041       enddo
13042 !      write (iout,*) "gg",(gg(k),k=1,3)
13043       do k=1,3
13044         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13045                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13046                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac
13047         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13048                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13049                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac
13050 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13051 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13052 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13053 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13054       enddo
13055 !
13056 ! Calculate the components of the gradient in DC and X
13057 !
13058       do l=1,3
13059         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13060         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13061       enddo
13062       return
13063       end subroutine sc_grad_scale
13064 !-----------------------------------------------------------------------------
13065 ! energy_split-sep.F
13066 !-----------------------------------------------------------------------------
13067       subroutine etotal_long(energia)
13068 !
13069 ! Compute the long-range slow-varying contributions to the energy
13070 !
13071 !      implicit real*8 (a-h,o-z)
13072 !      include 'DIMENSIONS'
13073       use MD_data, only: totT
13074 #ifndef ISNAN
13075       external proc_proc
13076 #ifdef WINPGI
13077 !MS$ATTRIBUTES C ::  proc_proc
13078 #endif
13079 #endif
13080 #ifdef MPI
13081       include "mpif.h"
13082       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13083 #endif
13084 !      include 'COMMON.SETUP'
13085 !      include 'COMMON.IOUNITS'
13086 !      include 'COMMON.FFIELD'
13087 !      include 'COMMON.DERIV'
13088 !      include 'COMMON.INTERACT'
13089 !      include 'COMMON.SBRIDGE'
13090 !      include 'COMMON.CHAIN'
13091 !      include 'COMMON.VAR'
13092 !      include 'COMMON.LOCAL'
13093 !      include 'COMMON.MD'
13094       real(kind=8),dimension(0:n_ene) :: energia
13095 !el local variables
13096       integer :: i,n_corr,n_corr1,ierror,ierr
13097       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13098                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13099                   ecorr,ecorr5,ecorr6,eturn6,time00
13100 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13101 !elwrite(iout,*)"in etotal long"
13102
13103       if (modecalc.eq.12.or.modecalc.eq.14) then
13104 #ifdef MPI
13105 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13106 #else
13107         call int_from_cart1(.false.)
13108 #endif
13109       endif
13110 !elwrite(iout,*)"in etotal long"
13111
13112 #ifdef MPI
13113 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13114 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13115       call flush(iout)
13116       if (nfgtasks.gt.1) then
13117         time00=MPI_Wtime()
13118 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13119         if (fg_rank.eq.0) then
13120           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13121 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13122 !          call flush(iout)
13123 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13124 ! FG slaves as WEIGHTS array.
13125           weights_(1)=wsc
13126           weights_(2)=wscp
13127           weights_(3)=welec
13128           weights_(4)=wcorr
13129           weights_(5)=wcorr5
13130           weights_(6)=wcorr6
13131           weights_(7)=wel_loc
13132           weights_(8)=wturn3
13133           weights_(9)=wturn4
13134           weights_(10)=wturn6
13135           weights_(11)=wang
13136           weights_(12)=wscloc
13137           weights_(13)=wtor
13138           weights_(14)=wtor_d
13139           weights_(15)=wstrain
13140           weights_(16)=wvdwpp
13141           weights_(17)=wbond
13142           weights_(18)=scal14
13143           weights_(21)=wsccor
13144 ! FG Master broadcasts the WEIGHTS_ array
13145           call MPI_Bcast(weights_(1),n_ene,&
13146               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13147         else
13148 ! FG slaves receive the WEIGHTS array
13149           call MPI_Bcast(weights(1),n_ene,&
13150               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13151           wsc=weights(1)
13152           wscp=weights(2)
13153           welec=weights(3)
13154           wcorr=weights(4)
13155           wcorr5=weights(5)
13156           wcorr6=weights(6)
13157           wel_loc=weights(7)
13158           wturn3=weights(8)
13159           wturn4=weights(9)
13160           wturn6=weights(10)
13161           wang=weights(11)
13162           wscloc=weights(12)
13163           wtor=weights(13)
13164           wtor_d=weights(14)
13165           wstrain=weights(15)
13166           wvdwpp=weights(16)
13167           wbond=weights(17)
13168           scal14=weights(18)
13169           wsccor=weights(21)
13170         endif
13171         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13172           king,FG_COMM,IERR)
13173          time_Bcast=time_Bcast+MPI_Wtime()-time00
13174          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13175 !        call chainbuild_cart
13176 !        call int_from_cart1(.false.)
13177       endif
13178 !      write (iout,*) 'Processor',myrank,
13179 !     &  ' calling etotal_short ipot=',ipot
13180 !      call flush(iout)
13181 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13182 #endif
13183 !d    print *,'nnt=',nnt,' nct=',nct
13184 !
13185 !elwrite(iout,*)"in etotal long"
13186 ! Compute the side-chain and electrostatic interaction energy
13187 !
13188       goto (101,102,103,104,105,106) ipot
13189 ! Lennard-Jones potential.
13190   101 call elj_long(evdw)
13191 !d    print '(a)','Exit ELJ'
13192       goto 107
13193 ! Lennard-Jones-Kihara potential (shifted).
13194   102 call eljk_long(evdw)
13195       goto 107
13196 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13197   103 call ebp_long(evdw)
13198       goto 107
13199 ! Gay-Berne potential (shifted LJ, angular dependence).
13200   104 call egb_long(evdw)
13201       goto 107
13202 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13203   105 call egbv_long(evdw)
13204       goto 107
13205 ! Soft-sphere potential
13206   106 call e_softsphere(evdw)
13207 !
13208 ! Calculate electrostatic (H-bonding) energy of the main chain.
13209 !
13210   107 continue
13211       call vec_and_deriv
13212       if (ipot.lt.6) then
13213 #ifdef SPLITELE
13214          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13215              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13216              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13217              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13218 #else
13219          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13220              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13221              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13222              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13223 #endif
13224            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13225          else
13226             ees=0
13227             evdw1=0
13228             eel_loc=0
13229             eello_turn3=0
13230             eello_turn4=0
13231          endif
13232       else
13233 !        write (iout,*) "Soft-spheer ELEC potential"
13234         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13235          eello_turn4)
13236       endif
13237 !
13238 ! Calculate excluded-volume interaction energy between peptide groups
13239 ! and side chains.
13240 !
13241       if (ipot.lt.6) then
13242        if(wscp.gt.0d0) then
13243         call escp_long(evdw2,evdw2_14)
13244        else
13245         evdw2=0
13246         evdw2_14=0
13247        endif
13248       else
13249         call escp_soft_sphere(evdw2,evdw2_14)
13250       endif
13251 !
13252 ! 12/1/95 Multi-body terms
13253 !
13254       n_corr=0
13255       n_corr1=0
13256       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13257           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13258          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13259 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13260 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13261       else
13262          ecorr=0.0d0
13263          ecorr5=0.0d0
13264          ecorr6=0.0d0
13265          eturn6=0.0d0
13266       endif
13267       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13268          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13269       endif
13270 !
13271 ! If performing constraint dynamics, call the constraint energy
13272 !  after the equilibration time
13273       if(usampl.and.totT.gt.eq_time) then
13274          call EconstrQ
13275          call Econstr_back
13276       else
13277          Uconst=0.0d0
13278          Uconst_back=0.0d0
13279       endif
13280 !
13281 ! Sum the energies
13282 !
13283       do i=1,n_ene
13284         energia(i)=0.0d0
13285       enddo
13286       energia(1)=evdw
13287 #ifdef SCP14
13288       energia(2)=evdw2-evdw2_14
13289       energia(18)=evdw2_14
13290 #else
13291       energia(2)=evdw2
13292       energia(18)=0.0d0
13293 #endif
13294 #ifdef SPLITELE
13295       energia(3)=ees
13296       energia(16)=evdw1
13297 #else
13298       energia(3)=ees+evdw1
13299       energia(16)=0.0d0
13300 #endif
13301       energia(4)=ecorr
13302       energia(5)=ecorr5
13303       energia(6)=ecorr6
13304       energia(7)=eel_loc
13305       energia(8)=eello_turn3
13306       energia(9)=eello_turn4
13307       energia(10)=eturn6
13308       energia(20)=Uconst+Uconst_back
13309       call sum_energy(energia,.true.)
13310 !      write (iout,*) "Exit ETOTAL_LONG"
13311       call flush(iout)
13312       return
13313       end subroutine etotal_long
13314 !-----------------------------------------------------------------------------
13315       subroutine etotal_short(energia)
13316 !
13317 ! Compute the short-range fast-varying contributions to the energy
13318 !
13319 !      implicit real*8 (a-h,o-z)
13320 !      include 'DIMENSIONS'
13321 #ifndef ISNAN
13322       external proc_proc
13323 #ifdef WINPGI
13324 !MS$ATTRIBUTES C ::  proc_proc
13325 #endif
13326 #endif
13327 #ifdef MPI
13328       include "mpif.h"
13329       integer :: ierror,ierr
13330       real(kind=8),dimension(n_ene) :: weights_
13331       real(kind=8) :: time00
13332 #endif
13333 !      include 'COMMON.SETUP'
13334 !      include 'COMMON.IOUNITS'
13335 !      include 'COMMON.FFIELD'
13336 !      include 'COMMON.DERIV'
13337 !      include 'COMMON.INTERACT'
13338 !      include 'COMMON.SBRIDGE'
13339 !      include 'COMMON.CHAIN'
13340 !      include 'COMMON.VAR'
13341 !      include 'COMMON.LOCAL'
13342       real(kind=8),dimension(0:n_ene) :: energia
13343 !el local variables
13344       integer :: i,nres6
13345       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13346       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13347       nres6=6*nres
13348
13349 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13350 !      call flush(iout)
13351       if (modecalc.eq.12.or.modecalc.eq.14) then
13352 #ifdef MPI
13353         if (fg_rank.eq.0) call int_from_cart1(.false.)
13354 #else
13355         call int_from_cart1(.false.)
13356 #endif
13357       endif
13358 #ifdef MPI
13359 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13360 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13361 !      call flush(iout)
13362       if (nfgtasks.gt.1) then
13363         time00=MPI_Wtime()
13364 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13365         if (fg_rank.eq.0) then
13366           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13367 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13368 !          call flush(iout)
13369 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13370 ! FG slaves as WEIGHTS array.
13371           weights_(1)=wsc
13372           weights_(2)=wscp
13373           weights_(3)=welec
13374           weights_(4)=wcorr
13375           weights_(5)=wcorr5
13376           weights_(6)=wcorr6
13377           weights_(7)=wel_loc
13378           weights_(8)=wturn3
13379           weights_(9)=wturn4
13380           weights_(10)=wturn6
13381           weights_(11)=wang
13382           weights_(12)=wscloc
13383           weights_(13)=wtor
13384           weights_(14)=wtor_d
13385           weights_(15)=wstrain
13386           weights_(16)=wvdwpp
13387           weights_(17)=wbond
13388           weights_(18)=scal14
13389           weights_(21)=wsccor
13390 ! FG Master broadcasts the WEIGHTS_ array
13391           call MPI_Bcast(weights_(1),n_ene,&
13392               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13393         else
13394 ! FG slaves receive the WEIGHTS array
13395           call MPI_Bcast(weights(1),n_ene,&
13396               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13397           wsc=weights(1)
13398           wscp=weights(2)
13399           welec=weights(3)
13400           wcorr=weights(4)
13401           wcorr5=weights(5)
13402           wcorr6=weights(6)
13403           wel_loc=weights(7)
13404           wturn3=weights(8)
13405           wturn4=weights(9)
13406           wturn6=weights(10)
13407           wang=weights(11)
13408           wscloc=weights(12)
13409           wtor=weights(13)
13410           wtor_d=weights(14)
13411           wstrain=weights(15)
13412           wvdwpp=weights(16)
13413           wbond=weights(17)
13414           scal14=weights(18)
13415           wsccor=weights(21)
13416         endif
13417 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13418         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13419           king,FG_COMM,IERR)
13420 !        write (iout,*) "Processor",myrank," BROADCAST c"
13421         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13422           king,FG_COMM,IERR)
13423 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13424         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13425           king,FG_COMM,IERR)
13426 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13427         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13428           king,FG_COMM,IERR)
13429 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13430         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13431           king,FG_COMM,IERR)
13432 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13433         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13434           king,FG_COMM,IERR)
13435 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13436         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13437           king,FG_COMM,IERR)
13438 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13439         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13440           king,FG_COMM,IERR)
13441 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13442         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13443           king,FG_COMM,IERR)
13444          time_Bcast=time_Bcast+MPI_Wtime()-time00
13445 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13446       endif
13447 !      write (iout,*) 'Processor',myrank,
13448 !     &  ' calling etotal_short ipot=',ipot
13449 !      call flush(iout)
13450 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13451 #endif
13452 !      call int_from_cart1(.false.)
13453 !
13454 ! Compute the side-chain and electrostatic interaction energy
13455 !
13456       goto (101,102,103,104,105,106) ipot
13457 ! Lennard-Jones potential.
13458   101 call elj_short(evdw)
13459 !d    print '(a)','Exit ELJ'
13460       goto 107
13461 ! Lennard-Jones-Kihara potential (shifted).
13462   102 call eljk_short(evdw)
13463       goto 107
13464 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13465   103 call ebp_short(evdw)
13466       goto 107
13467 ! Gay-Berne potential (shifted LJ, angular dependence).
13468   104 call egb_short(evdw)
13469       goto 107
13470 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13471   105 call egbv_short(evdw)
13472       goto 107
13473 ! Soft-sphere potential - already dealt with in the long-range part
13474   106 evdw=0.0d0
13475 !  106 call e_softsphere_short(evdw)
13476 !
13477 ! Calculate electrostatic (H-bonding) energy of the main chain.
13478 !
13479   107 continue
13480 !
13481 ! Calculate the short-range part of Evdwpp
13482 !
13483       call evdwpp_short(evdw1)
13484 !
13485 ! Calculate the short-range part of ESCp
13486 !
13487       if (ipot.lt.6) then
13488         call escp_short(evdw2,evdw2_14)
13489       endif
13490 !
13491 ! Calculate the bond-stretching energy
13492 !
13493       call ebond(estr)
13494 !
13495 ! Calculate the disulfide-bridge and other energy and the contributions
13496 ! from other distance constraints.
13497       call edis(ehpb)
13498 !
13499 ! Calculate the virtual-bond-angle energy.
13500 !
13501       call ebend(ebe)
13502 !
13503 ! Calculate the SC local energy.
13504 !
13505       call vec_and_deriv
13506       call esc(escloc)
13507 !
13508 ! Calculate the virtual-bond torsional energy.
13509 !
13510       call etor(etors,edihcnstr)
13511 !
13512 ! 6/23/01 Calculate double-torsional energy
13513 !
13514       call etor_d(etors_d)
13515 !
13516 ! 21/5/07 Calculate local sicdechain correlation energy
13517 !
13518       if (wsccor.gt.0.0d0) then
13519         call eback_sc_corr(esccor)
13520       else
13521         esccor=0.0d0
13522       endif
13523 !
13524 ! Put energy components into an array
13525 !
13526       do i=1,n_ene
13527         energia(i)=0.0d0
13528       enddo
13529       energia(1)=evdw
13530 #ifdef SCP14
13531       energia(2)=evdw2-evdw2_14
13532       energia(18)=evdw2_14
13533 #else
13534       energia(2)=evdw2
13535       energia(18)=0.0d0
13536 #endif
13537 #ifdef SPLITELE
13538       energia(16)=evdw1
13539 #else
13540       energia(3)=evdw1
13541 #endif
13542       energia(11)=ebe
13543       energia(12)=escloc
13544       energia(13)=etors
13545       energia(14)=etors_d
13546       energia(15)=ehpb
13547       energia(17)=estr
13548       energia(19)=edihcnstr
13549       energia(21)=esccor
13550 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
13551       call flush(iout)
13552       call sum_energy(energia,.true.)
13553 !      write (iout,*) "Exit ETOTAL_SHORT"
13554       call flush(iout)
13555       return
13556       end subroutine etotal_short
13557 !-----------------------------------------------------------------------------
13558 ! gnmr1.f
13559 !-----------------------------------------------------------------------------
13560       real(kind=8) function gnmr1(y,ymin,ymax)
13561 !      implicit none
13562       real(kind=8) :: y,ymin,ymax
13563       real(kind=8) :: wykl=4.0d0
13564       if (y.lt.ymin) then
13565         gnmr1=(ymin-y)**wykl/wykl
13566       else if (y.gt.ymax) then
13567         gnmr1=(y-ymax)**wykl/wykl
13568       else
13569         gnmr1=0.0d0
13570       endif
13571       return
13572       end function gnmr1
13573 !-----------------------------------------------------------------------------
13574       real(kind=8) function gnmr1prim(y,ymin,ymax)
13575 !      implicit none
13576       real(kind=8) :: y,ymin,ymax
13577       real(kind=8) :: wykl=4.0d0
13578       if (y.lt.ymin) then
13579         gnmr1prim=-(ymin-y)**(wykl-1)
13580       else if (y.gt.ymax) then
13581         gnmr1prim=(y-ymax)**(wykl-1)
13582       else
13583         gnmr1prim=0.0d0
13584       endif
13585       return
13586       end function gnmr1prim
13587 !-----------------------------------------------------------------------------
13588       real(kind=8) function harmonic(y,ymax)
13589 !      implicit none
13590       real(kind=8) :: y,ymax
13591       real(kind=8) :: wykl=2.0d0
13592       harmonic=(y-ymax)**wykl
13593       return
13594       end function harmonic
13595 !-----------------------------------------------------------------------------
13596       real(kind=8) function harmonicprim(y,ymax)
13597       real(kind=8) :: y,ymin,ymax
13598       real(kind=8) :: wykl=2.0d0
13599       harmonicprim=(y-ymax)*wykl
13600       return
13601       end function harmonicprim
13602 !-----------------------------------------------------------------------------
13603 ! gradient_p.F
13604 !-----------------------------------------------------------------------------
13605       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
13606
13607       use io_base, only:intout,briefout
13608 !      implicit real*8 (a-h,o-z)
13609 !      include 'DIMENSIONS'
13610 !      include 'COMMON.CHAIN'
13611 !      include 'COMMON.DERIV'
13612 !      include 'COMMON.VAR'
13613 !      include 'COMMON.INTERACT'
13614 !      include 'COMMON.FFIELD'
13615 !      include 'COMMON.MD'
13616 !      include 'COMMON.IOUNITS'
13617       real(kind=8),external :: ufparm
13618       integer :: uiparm(1)
13619       real(kind=8) :: urparm(1)
13620       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13621       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
13622       integer :: n,nf,ind,ind1,i,k,j
13623 !
13624 ! This subroutine calculates total internal coordinate gradient.
13625 ! Depending on the number of function evaluations, either whole energy
13626 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
13627 ! internal coordinates are reevaluated or only the cartesian-in-internal
13628 ! coordinate derivatives are evaluated. The subroutine was designed to work
13629 ! with SUMSL.
13630 !
13631 !
13632       icg=mod(nf,2)+1
13633
13634 !d      print *,'grad',nf,icg
13635       if (nf-nfl+1) 20,30,40
13636    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
13637 !    write (iout,*) 'grad 20'
13638       if (nf.eq.0) return
13639       goto 40
13640    30 call var_to_geom(n,x)
13641       call chainbuild
13642 !    write (iout,*) 'grad 30'
13643 !
13644 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
13645 !
13646    40 call cartder
13647 !     write (iout,*) 'grad 40'
13648 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
13649 !
13650 ! Convert the Cartesian gradient into internal-coordinate gradient.
13651 !
13652       ind=0
13653       ind1=0
13654       do i=1,nres-2
13655         gthetai=0.0D0
13656         gphii=0.0D0
13657         do j=i+1,nres-1
13658           ind=ind+1
13659 !         ind=indmat(i,j)
13660 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
13661           do k=1,3
13662             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
13663           enddo
13664           do k=1,3
13665             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
13666           enddo
13667         enddo
13668         do j=i+1,nres-1
13669           ind1=ind1+1
13670 !         ind1=indmat(i,j)
13671 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
13672           do k=1,3
13673             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
13674             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
13675           enddo
13676         enddo
13677         if (i.gt.1) g(i-1)=gphii
13678         if (n.gt.nphi) g(nphi+i)=gthetai
13679       enddo
13680       if (n.le.nphi+ntheta) goto 10
13681       do i=2,nres-1
13682         if (itype(i).ne.10) then
13683           galphai=0.0D0
13684           gomegai=0.0D0
13685           do k=1,3
13686             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
13687           enddo
13688           do k=1,3
13689             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
13690           enddo
13691           g(ialph(i,1))=galphai
13692           g(ialph(i,1)+nside)=gomegai
13693         endif
13694       enddo
13695 !
13696 ! Add the components corresponding to local energy terms.
13697 !
13698    10 continue
13699       do i=1,nvar
13700 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
13701         g(i)=g(i)+gloc(i,icg)
13702       enddo
13703 ! Uncomment following three lines for diagnostics.
13704 !d    call intout
13705 !elwrite(iout,*) "in gradient after calling intout"
13706 !d    call briefout(0,0.0d0)
13707 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
13708       return
13709       end subroutine gradient
13710 !-----------------------------------------------------------------------------
13711       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
13712
13713       use comm_chu
13714 !      implicit real*8 (a-h,o-z)
13715 !      include 'DIMENSIONS'
13716 !      include 'COMMON.DERIV'
13717 !      include 'COMMON.IOUNITS'
13718 !      include 'COMMON.GEO'
13719       integer :: n,nf
13720 !el      integer :: jjj
13721 !el      common /chuju/ jjj
13722       real(kind=8) :: energia(0:n_ene)
13723       integer :: uiparm(1)
13724       real(kind=8) :: urparm(1)
13725       real(kind=8) :: f
13726       real(kind=8),external :: ufparm
13727       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
13728 !     if (jjj.gt.0) then
13729 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13730 !     endif
13731       nfl=nf
13732       icg=mod(nf,2)+1
13733 !d      print *,'func',nf,nfl,icg
13734       call var_to_geom(n,x)
13735       call zerograd
13736       call chainbuild
13737 !d    write (iout,*) 'ETOTAL called from FUNC'
13738       call etotal(energia)
13739       call sum_gradient
13740       f=energia(0)
13741 !     if (jjj.gt.0) then
13742 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13743 !       write (iout,*) 'f=',etot
13744 !       jjj=0
13745 !     endif
13746       return
13747       end subroutine func
13748 !-----------------------------------------------------------------------------
13749       subroutine cartgrad
13750 !      implicit real*8 (a-h,o-z)
13751 !      include 'DIMENSIONS'
13752       use energy_data
13753       use MD_data, only: totT
13754 #ifdef MPI
13755       include 'mpif.h'
13756 #endif
13757 !      include 'COMMON.CHAIN'
13758 !      include 'COMMON.DERIV'
13759 !      include 'COMMON.VAR'
13760 !      include 'COMMON.INTERACT'
13761 !      include 'COMMON.FFIELD'
13762 !      include 'COMMON.MD'
13763 !      include 'COMMON.IOUNITS'
13764 !      include 'COMMON.TIME1'
13765 !
13766       integer :: i,j
13767
13768 ! This subrouting calculates total Cartesian coordinate gradient.
13769 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
13770 !
13771 !el#define DEBUG
13772 #ifdef TIMING
13773       time00=MPI_Wtime()
13774 #endif
13775       icg=1
13776       call sum_gradient
13777 #ifdef TIMING
13778 #endif
13779 !el      write (iout,*) "After sum_gradient"
13780 #ifdef DEBUG
13781 !el      write (iout,*) "After sum_gradient"
13782       do i=1,nres-1
13783         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
13784         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
13785       enddo
13786 #endif
13787 ! If performing constraint dynamics, add the gradients of the constraint energy
13788       if(usampl.and.totT.gt.eq_time) then
13789          do i=1,nct
13790            do j=1,3
13791              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
13792              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
13793            enddo
13794          enddo
13795          do i=1,nres-3
13796            gloc(i,icg)=gloc(i,icg)+dugamma(i)
13797          enddo
13798          do i=1,nres-2
13799            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
13800          enddo
13801       endif
13802 !elwrite (iout,*) "After sum_gradient"
13803 #ifdef TIMING
13804       time01=MPI_Wtime()
13805 #endif
13806       call intcartderiv
13807 !elwrite (iout,*) "After sum_gradient"
13808 #ifdef TIMING
13809       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
13810 #endif
13811 !     call checkintcartgrad
13812 !     write(iout,*) 'calling int_to_cart'
13813 #ifdef DEBUG
13814       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
13815 #endif
13816       do i=1,nct
13817         do j=1,3
13818           gcart(j,i)=gradc(j,i,icg)
13819           gxcart(j,i)=gradx(j,i,icg)
13820         enddo
13821 #ifdef DEBUG
13822         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
13823           (gxcart(j,i),j=1,3),gloc(i,icg)
13824 #endif
13825       enddo
13826 #ifdef TIMING
13827       time01=MPI_Wtime()
13828 #endif
13829       call int_to_cart
13830 #ifdef TIMING
13831       time_inttocart=time_inttocart+MPI_Wtime()-time01
13832 #endif
13833 #ifdef DEBUG
13834       write (iout,*) "gcart and gxcart after int_to_cart"
13835       do i=0,nres-1
13836         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13837             (gxcart(j,i),j=1,3)
13838       enddo
13839 #endif
13840 #ifdef TIMING
13841       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
13842 #endif
13843 !el#undef DEBUG
13844       return
13845       end subroutine cartgrad
13846 !-----------------------------------------------------------------------------
13847       subroutine zerograd
13848 !      implicit real*8 (a-h,o-z)
13849 !      include 'DIMENSIONS'
13850 !      include 'COMMON.DERIV'
13851 !      include 'COMMON.CHAIN'
13852 !      include 'COMMON.VAR'
13853 !      include 'COMMON.MD'
13854 !      include 'COMMON.SCCOR'
13855 !
13856 !el local variables
13857       integer :: i,j,intertyp
13858 ! Initialize Cartesian-coordinate gradient
13859 !
13860 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
13861 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
13862
13863 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
13864 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
13865 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
13866 !      allocate(gradcorr_long(3,nres))
13867 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
13868 !      allocate(gcorr6_turn_long(3,nres))
13869 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
13870
13871 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
13872
13873 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
13874 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
13875
13876 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
13877 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
13878
13879 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
13880 !      allocate(gscloc(3,nres)) !(3,maxres)
13881 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
13882
13883
13884
13885 !      common /deriv_scloc/
13886 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
13887 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
13888 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
13889 !      common /mpgrad/
13890 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
13891
13892
13893
13894 !          gradc(j,i,icg)=0.0d0
13895 !          gradx(j,i,icg)=0.0d0
13896
13897 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
13898 !elwrite(iout,*) "icg",icg
13899       do i=1,nres
13900         do j=1,3
13901           gvdwx(j,i)=0.0D0
13902           gradx_scp(j,i)=0.0D0
13903           gvdwc(j,i)=0.0D0
13904           gvdwc_scp(j,i)=0.0D0
13905           gvdwc_scpp(j,i)=0.0d0
13906           gelc(j,i)=0.0D0
13907           gelc_long(j,i)=0.0D0
13908           gradb(j,i)=0.0d0
13909           gradbx(j,i)=0.0d0
13910           gvdwpp(j,i)=0.0d0
13911           gel_loc(j,i)=0.0d0
13912           gel_loc_long(j,i)=0.0d0
13913           ghpbc(j,i)=0.0D0
13914           ghpbx(j,i)=0.0D0
13915           gcorr3_turn(j,i)=0.0d0
13916           gcorr4_turn(j,i)=0.0d0
13917           gradcorr(j,i)=0.0d0
13918           gradcorr_long(j,i)=0.0d0
13919           gradcorr5_long(j,i)=0.0d0
13920           gradcorr6_long(j,i)=0.0d0
13921           gcorr6_turn_long(j,i)=0.0d0
13922           gradcorr5(j,i)=0.0d0
13923           gradcorr6(j,i)=0.0d0
13924           gcorr6_turn(j,i)=0.0d0
13925           gsccorc(j,i)=0.0d0
13926           gsccorx(j,i)=0.0d0
13927           gradc(j,i,icg)=0.0d0
13928           gradx(j,i,icg)=0.0d0
13929           gscloc(j,i)=0.0d0
13930           gsclocx(j,i)=0.0d0
13931           do intertyp=1,3
13932            gloc_sc(intertyp,i,icg)=0.0d0
13933           enddo
13934         enddo
13935       enddo
13936 !
13937 ! Initialize the gradient of local energy terms.
13938 !
13939 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
13940 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13941 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13942 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
13943 !      allocate(gel_loc_turn3(nres))
13944 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
13945 !      allocate(gsccor_loc(nres))       !(maxres)
13946
13947       do i=1,4*nres
13948         gloc(i,icg)=0.0D0
13949       enddo
13950       do i=1,nres
13951         gel_loc_loc(i)=0.0d0
13952         gcorr_loc(i)=0.0d0
13953         g_corr5_loc(i)=0.0d0
13954         g_corr6_loc(i)=0.0d0
13955         gel_loc_turn3(i)=0.0d0
13956         gel_loc_turn4(i)=0.0d0
13957         gel_loc_turn6(i)=0.0d0
13958         gsccor_loc(i)=0.0d0
13959       enddo
13960 ! initialize gcart and gxcart
13961 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
13962       do i=0,nres
13963         do j=1,3
13964           gcart(j,i)=0.0d0
13965           gxcart(j,i)=0.0d0
13966         enddo
13967       enddo
13968       return
13969       end subroutine zerograd
13970 !-----------------------------------------------------------------------------
13971       real(kind=8) function fdum()
13972       fdum=0.0D0
13973       return
13974       end function fdum
13975 !-----------------------------------------------------------------------------
13976 ! intcartderiv.F
13977 !-----------------------------------------------------------------------------
13978       subroutine intcartderiv
13979 !      implicit real*8 (a-h,o-z)
13980 !      include 'DIMENSIONS'
13981 #ifdef MPI
13982       include 'mpif.h'
13983 #endif
13984 !      include 'COMMON.SETUP'
13985 !      include 'COMMON.CHAIN'
13986 !      include 'COMMON.VAR'
13987 !      include 'COMMON.GEO'
13988 !      include 'COMMON.INTERACT'
13989 !      include 'COMMON.DERIV'
13990 !      include 'COMMON.IOUNITS'
13991 !      include 'COMMON.LOCAL'
13992 !      include 'COMMON.SCCOR'
13993       real(kind=8) :: pi4,pi34
13994       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
13995       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
13996                     dcosomega,dsinomega !(3,3,maxres)
13997       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
13998
13999       integer :: i,j,k
14000       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14001                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14002                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14003                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14004       integer :: nres2
14005       nres2=2*nres
14006
14007 !el from module energy-------------
14008 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14009 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14010 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14011
14012 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14013 !el      allocate(dsintau(3,3,3,0:nres2))
14014 !el      allocate(dtauangle(3,3,3,0:nres2))
14015 !el      allocate(domicron(3,2,2,0:nres2))
14016 !el      allocate(dcosomicron(3,2,2,0:nres2))
14017
14018
14019
14020 #if defined(MPI) && defined(PARINTDER)
14021       if (nfgtasks.gt.1 .and. me.eq.king) &
14022         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14023 #endif
14024       pi4 = 0.5d0*pipol
14025       pi34 = 3*pi4
14026
14027 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14028 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14029
14030 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14031       do i=1,nres
14032         do j=1,3
14033           dtheta(j,1,i)=0.0d0
14034           dtheta(j,2,i)=0.0d0
14035           dphi(j,1,i)=0.0d0
14036           dphi(j,2,i)=0.0d0
14037           dphi(j,3,i)=0.0d0
14038         enddo
14039       enddo
14040 ! Derivatives of theta's
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         cost=dcos(theta(i))
14048         sint=sqrt(1-cost*cost)
14049         do j=1,3
14050           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14051           vbld(i-1)
14052           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14053           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14054           vbld(i)
14055           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14056         enddo
14057       enddo
14058 #if defined(MPI) && defined(PARINTDER)
14059 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14060       do i=max0(ithet_start-1,3),ithet_end
14061 #else
14062       do i=3,nres
14063 #endif
14064       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14065         cost1=dcos(omicron(1,i))
14066         sint1=sqrt(1-cost1*cost1)
14067         cost2=dcos(omicron(2,i))
14068         sint2=sqrt(1-cost2*cost2)
14069        do j=1,3
14070 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14071           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14072           cost1*dc_norm(j,i-2))/ &
14073           vbld(i-1)
14074           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14075           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14076           +cost1*(dc_norm(j,i-1+nres)))/ &
14077           vbld(i-1+nres)
14078           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14079 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14080 !C Looks messy but better than if in loop
14081           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14082           +cost2*dc_norm(j,i-1))/ &
14083           vbld(i)
14084           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14085           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14086            +cost2*(-dc_norm(j,i-1+nres)))/ &
14087           vbld(i-1+nres)
14088 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14089           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14090         enddo
14091        endif
14092       enddo
14093 !elwrite(iout,*) "after vbld write"
14094 ! Derivatives of phi:
14095 ! If phi is 0 or 180 degrees, then the formulas
14096 ! have to be derived by power series expansion of the
14097 ! conventional formulas around 0 and 180.
14098 #ifdef PARINTDER
14099       do i=iphi1_start,iphi1_end
14100 #else
14101       do i=4,nres
14102 #endif
14103 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14104 ! the conventional case
14105         sint=dsin(theta(i))
14106         sint1=dsin(theta(i-1))
14107         sing=dsin(phi(i))
14108         cost=dcos(theta(i))
14109         cost1=dcos(theta(i-1))
14110         cosg=dcos(phi(i))
14111         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14112         fac0=1.0d0/(sint1*sint)
14113         fac1=cost*fac0
14114         fac2=cost1*fac0
14115         fac3=cosg*cost1/(sint1*sint1)
14116         fac4=cosg*cost/(sint*sint)
14117 !    Obtaining the gamma derivatives from sine derivative
14118        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14119            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14120            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14121          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14122          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14123          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14124          do j=1,3
14125             ctgt=cost/sint
14126             ctgt1=cost1/sint1
14127             cosg_inv=1.0d0/cosg
14128             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14129             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14130               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14131             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14132             dsinphi(j,2,i)= &
14133               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14134               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14135             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14136             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14137               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14138 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14139             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14140             endif
14141 ! Bug fixed 3/24/05 (AL)
14142          enddo
14143 !   Obtaining the gamma derivatives from cosine derivative
14144         else
14145            do j=1,3
14146            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14147            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14148            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14149            dc_norm(j,i-3))/vbld(i-2)
14150            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14151            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14152            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14153            dcostheta(j,1,i)
14154            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14155            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14156            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14157            dc_norm(j,i-1))/vbld(i)
14158            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14159            endif
14160          enddo
14161         endif
14162       enddo
14163 !alculate derivative of Tauangle
14164 #ifdef PARINTDER
14165       do i=itau_start,itau_end
14166 #else
14167       do i=3,nres
14168 !elwrite(iout,*) " vecpr",i,nres
14169 #endif
14170        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14171 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14172 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14173 !c dtauangle(j,intertyp,dervityp,residue number)
14174 !c INTERTYP=1 SC...Ca...Ca..Ca
14175 ! the conventional case
14176         sint=dsin(theta(i))
14177         sint1=dsin(omicron(2,i-1))
14178         sing=dsin(tauangle(1,i))
14179         cost=dcos(theta(i))
14180         cost1=dcos(omicron(2,i-1))
14181         cosg=dcos(tauangle(1,i))
14182 !elwrite(iout,*) " vecpr5",i,nres
14183         do j=1,3
14184 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14185 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14186         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14187 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14188         enddo
14189         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14190         fac0=1.0d0/(sint1*sint)
14191         fac1=cost*fac0
14192         fac2=cost1*fac0
14193         fac3=cosg*cost1/(sint1*sint1)
14194         fac4=cosg*cost/(sint*sint)
14195 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14196 !    Obtaining the gamma derivatives from sine derivative
14197        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14198            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14199            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14200          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14201          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14202          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14203         do j=1,3
14204             ctgt=cost/sint
14205             ctgt1=cost1/sint1
14206             cosg_inv=1.0d0/cosg
14207             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14208        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14209        *vbld_inv(i-2+nres)
14210             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14211             dsintau(j,1,2,i)= &
14212               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14213               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14214 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14215             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14216 ! Bug fixed 3/24/05 (AL)
14217             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14218               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14219 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14220             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14221          enddo
14222 !   Obtaining the gamma derivatives from cosine derivative
14223         else
14224            do j=1,3
14225            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14226            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14227            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14228            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14229            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14230            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14231            dcostheta(j,1,i)
14232            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14233            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14234            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14235            dc_norm(j,i-1))/vbld(i)
14236            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14237 !         write (iout,*) "else",i
14238          enddo
14239         endif
14240 !        do k=1,3
14241 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14242 !        enddo
14243       enddo
14244 !C Second case Ca...Ca...Ca...SC
14245 #ifdef PARINTDER
14246       do i=itau_start,itau_end
14247 #else
14248       do i=4,nres
14249 #endif
14250        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14251           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14252 ! the conventional case
14253         sint=dsin(omicron(1,i))
14254         sint1=dsin(theta(i-1))
14255         sing=dsin(tauangle(2,i))
14256         cost=dcos(omicron(1,i))
14257         cost1=dcos(theta(i-1))
14258         cosg=dcos(tauangle(2,i))
14259 !        do j=1,3
14260 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14261 !        enddo
14262         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14263         fac0=1.0d0/(sint1*sint)
14264         fac1=cost*fac0
14265         fac2=cost1*fac0
14266         fac3=cosg*cost1/(sint1*sint1)
14267         fac4=cosg*cost/(sint*sint)
14268 !    Obtaining the gamma derivatives from sine derivative
14269        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14270            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14271            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14272          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14273          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14274          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14275         do j=1,3
14276             ctgt=cost/sint
14277             ctgt1=cost1/sint1
14278             cosg_inv=1.0d0/cosg
14279             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14280               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14281 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14282 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14283             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14284             dsintau(j,2,2,i)= &
14285               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14286               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14287 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14288 !     & sing*ctgt*domicron(j,1,2,i),
14289 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14290             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14291 ! Bug fixed 3/24/05 (AL)
14292             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14293              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14294 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14295             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14296          enddo
14297 !   Obtaining the gamma derivatives from cosine derivative
14298         else
14299            do j=1,3
14300            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14301            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14302            dc_norm(j,i-3))/vbld(i-2)
14303            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14304            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14305            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14306            dcosomicron(j,1,1,i)
14307            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14308            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14309            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14310            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14311            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14312 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14313          enddo
14314         endif
14315       enddo
14316
14317 !CC third case SC...Ca...Ca...SC
14318 #ifdef PARINTDER
14319
14320       do i=itau_start,itau_end
14321 #else
14322       do i=3,nres
14323 #endif
14324 ! the conventional case
14325       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14326       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14327         sint=dsin(omicron(1,i))
14328         sint1=dsin(omicron(2,i-1))
14329         sing=dsin(tauangle(3,i))
14330         cost=dcos(omicron(1,i))
14331         cost1=dcos(omicron(2,i-1))
14332         cosg=dcos(tauangle(3,i))
14333         do j=1,3
14334         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14335 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14336         enddo
14337         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14338         fac0=1.0d0/(sint1*sint)
14339         fac1=cost*fac0
14340         fac2=cost1*fac0
14341         fac3=cosg*cost1/(sint1*sint1)
14342         fac4=cosg*cost/(sint*sint)
14343 !    Obtaining the gamma derivatives from sine derivative
14344        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14345            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14346            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14347          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14348          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14349          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14350         do j=1,3
14351             ctgt=cost/sint
14352             ctgt1=cost1/sint1
14353             cosg_inv=1.0d0/cosg
14354             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14355               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14356               *vbld_inv(i-2+nres)
14357             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14358             dsintau(j,3,2,i)= &
14359               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14360               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14361             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14362 ! Bug fixed 3/24/05 (AL)
14363             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14364               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14365               *vbld_inv(i-1+nres)
14366 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14367             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14368          enddo
14369 !   Obtaining the gamma derivatives from cosine derivative
14370         else
14371            do j=1,3
14372            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14373            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14374            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14375            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14376            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14377            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14378            dcosomicron(j,1,1,i)
14379            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14380            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14381            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14382            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14383            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14384 !          write(iout,*) "else",i
14385          enddo
14386         endif
14387       enddo
14388
14389 #ifdef CRYST_SC
14390 !   Derivatives of side-chain angles alpha and omega
14391 #if defined(MPI) && defined(PARINTDER)
14392         do i=ibond_start,ibond_end
14393 #else
14394         do i=2,nres-1
14395 #endif
14396           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14397              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14398              fac6=fac5/vbld(i)
14399              fac7=fac5*fac5
14400              fac8=fac5/vbld(i+1)
14401              fac9=fac5/vbld(i+nres)
14402              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14403              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14404              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14405              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14406              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14407              sina=sqrt(1-cosa*cosa)
14408              sino=dsin(omeg(i))
14409 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14410              do j=1,3
14411                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14412                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14413                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14414                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14415                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14416                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14417                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14418                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14419                 vbld(i+nres))
14420                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14421             enddo
14422 ! obtaining the derivatives of omega from sines
14423             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14424                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14425                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14426                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14427                dsin(theta(i+1)))
14428                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14429                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14430                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14431                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14432                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14433                coso_inv=1.0d0/dcos(omeg(i))
14434                do j=1,3
14435                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14436                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14437                  (sino*dc_norm(j,i-1))/vbld(i)
14438                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14439                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14440                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14441                  -sino*dc_norm(j,i)/vbld(i+1)
14442                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14443                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14444                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14445                  vbld(i+nres)
14446                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14447               enddo
14448            else
14449 !   obtaining the derivatives of omega from cosines
14450              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14451              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14452              fac12=fac10*sina
14453              fac13=fac12*fac12
14454              fac14=sina*sina
14455              do j=1,3
14456                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14457                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14458                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14459                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14460                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14461                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14462                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14463                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14464                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14465                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14466                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14467                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14468                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14469                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14470                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14471             enddo
14472           endif
14473          else
14474            do j=1,3
14475              do k=1,3
14476                dalpha(k,j,i)=0.0d0
14477                domega(k,j,i)=0.0d0
14478              enddo
14479            enddo
14480          endif
14481        enddo
14482 #endif
14483 #if defined(MPI) && defined(PARINTDER)
14484       if (nfgtasks.gt.1) then
14485 #ifdef DEBUG
14486 !d      write (iout,*) "Gather dtheta"
14487 !d      call flush(iout)
14488       write (iout,*) "dtheta before gather"
14489       do i=1,nres
14490         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14491       enddo
14492 #endif
14493       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14494         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14495         king,FG_COMM,IERROR)
14496 #ifdef DEBUG
14497 !d      write (iout,*) "Gather dphi"
14498 !d      call flush(iout)
14499       write (iout,*) "dphi before gather"
14500       do i=1,nres
14501         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
14502       enddo
14503 #endif
14504       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
14505         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
14506         king,FG_COMM,IERROR)
14507 !d      write (iout,*) "Gather dalpha"
14508 !d      call flush(iout)
14509 #ifdef CRYST_SC
14510       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
14511         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14512         king,FG_COMM,IERROR)
14513 !d      write (iout,*) "Gather domega"
14514 !d      call flush(iout)
14515       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
14516         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14517         king,FG_COMM,IERROR)
14518 #endif
14519       endif
14520 #endif
14521 #ifdef DEBUG
14522       write (iout,*) "dtheta after gather"
14523       do i=1,nres
14524         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
14525       enddo
14526       write (iout,*) "dphi after gather"
14527       do i=1,nres
14528         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
14529       enddo
14530       write (iout,*) "dalpha after gather"
14531       do i=1,nres
14532         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
14533       enddo
14534       write (iout,*) "domega after gather"
14535       do i=1,nres
14536         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
14537       enddo
14538 #endif
14539       return
14540       end subroutine intcartderiv
14541 !-----------------------------------------------------------------------------
14542       subroutine checkintcartgrad
14543 !      implicit real*8 (a-h,o-z)
14544 !      include 'DIMENSIONS'
14545 #ifdef MPI
14546       include 'mpif.h'
14547 #endif
14548 !      include 'COMMON.CHAIN'
14549 !      include 'COMMON.VAR'
14550 !      include 'COMMON.GEO'
14551 !      include 'COMMON.INTERACT'
14552 !      include 'COMMON.DERIV'
14553 !      include 'COMMON.IOUNITS'
14554 !      include 'COMMON.SETUP'
14555       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
14556       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
14557       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
14558       real(kind=8),dimension(3) :: dc_norm_s
14559       real(kind=8) :: aincr=1.0d-5
14560       integer :: i,j
14561       real(kind=8) :: dcji
14562       do i=1,nres
14563         phi_s(i)=phi(i)
14564         theta_s(i)=theta(i)
14565         alph_s(i)=alph(i)
14566         omeg_s(i)=omeg(i)
14567       enddo
14568 ! Check theta gradient
14569       write (iout,*) &
14570        "Analytical (upper) and numerical (lower) gradient of theta"
14571       write (iout,*)
14572       do i=3,nres
14573         do j=1,3
14574           dcji=dc(j,i-2)
14575           dc(j,i-2)=dcji+aincr
14576           call chainbuild_cart
14577           call int_from_cart1(.false.)
14578           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
14579           dc(j,i-2)=dcji
14580           dcji=dc(j,i-1)
14581           dc(j,i-1)=dc(j,i-1)+aincr
14582           call chainbuild_cart
14583           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
14584           dc(j,i-1)=dcji
14585         enddo
14586 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
14587 !el          (dtheta(j,2,i),j=1,3)
14588 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
14589 !el          (dthetanum(j,2,i),j=1,3)
14590 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
14591 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
14592 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
14593 !el        write (iout,*)
14594       enddo
14595 ! Check gamma gradient
14596       write (iout,*) &
14597        "Analytical (upper) and numerical (lower) gradient of gamma"
14598       do i=4,nres
14599         do j=1,3
14600           dcji=dc(j,i-3)
14601           dc(j,i-3)=dcji+aincr
14602           call chainbuild_cart
14603           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
14604           dc(j,i-3)=dcji
14605           dcji=dc(j,i-2)
14606           dc(j,i-2)=dcji+aincr
14607           call chainbuild_cart
14608           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
14609           dc(j,i-2)=dcji
14610           dcji=dc(j,i-1)
14611           dc(j,i-1)=dc(j,i-1)+aincr
14612           call chainbuild_cart
14613           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
14614           dc(j,i-1)=dcji
14615         enddo
14616 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
14617 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
14618 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
14619 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
14620 !el        write (iout,'(5x,3(3f10.5,5x))') &
14621 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
14622 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
14623 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
14624 !el        write (iout,*)
14625       enddo
14626 ! Check alpha gradient
14627       write (iout,*) &
14628        "Analytical (upper) and numerical (lower) gradient of alpha"
14629       do i=2,nres-1
14630        if(itype(i).ne.10) then
14631             do j=1,3
14632               dcji=dc(j,i-1)
14633               dc(j,i-1)=dcji+aincr
14634               call chainbuild_cart
14635               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
14636               /aincr
14637               dc(j,i-1)=dcji
14638               dcji=dc(j,i)
14639               dc(j,i)=dcji+aincr
14640               call chainbuild_cart
14641               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
14642               /aincr
14643               dc(j,i)=dcji
14644               dcji=dc(j,i+nres)
14645               dc(j,i+nres)=dc(j,i+nres)+aincr
14646               call chainbuild_cart
14647               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
14648               /aincr
14649              dc(j,i+nres)=dcji
14650             enddo
14651           endif
14652 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
14653 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
14654 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
14655 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
14656 !el        write (iout,'(5x,3(3f10.5,5x))') &
14657 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
14658 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
14659 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
14660 !el        write (iout,*)
14661       enddo
14662 !     Check omega gradient
14663       write (iout,*) &
14664        "Analytical (upper) and numerical (lower) gradient of omega"
14665       do i=2,nres-1
14666        if(itype(i).ne.10) then
14667             do j=1,3
14668               dcji=dc(j,i-1)
14669               dc(j,i-1)=dcji+aincr
14670               call chainbuild_cart
14671               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
14672               /aincr
14673               dc(j,i-1)=dcji
14674               dcji=dc(j,i)
14675               dc(j,i)=dcji+aincr
14676               call chainbuild_cart
14677               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
14678               /aincr
14679               dc(j,i)=dcji
14680               dcji=dc(j,i+nres)
14681               dc(j,i+nres)=dc(j,i+nres)+aincr
14682               call chainbuild_cart
14683               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
14684               /aincr
14685              dc(j,i+nres)=dcji
14686             enddo
14687           endif
14688 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
14689 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
14690 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
14691 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
14692 !el        write (iout,'(5x,3(3f10.5,5x))') &
14693 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
14694 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
14695 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
14696 !el        write (iout,*)
14697       enddo
14698       return
14699       end subroutine checkintcartgrad
14700 !-----------------------------------------------------------------------------
14701 ! q_measure.F
14702 !-----------------------------------------------------------------------------
14703       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
14704 !      implicit real*8 (a-h,o-z)
14705 !      include 'DIMENSIONS'
14706 !      include 'COMMON.IOUNITS'
14707 !      include 'COMMON.CHAIN'
14708 !      include 'COMMON.INTERACT'
14709 !      include 'COMMON.VAR'
14710       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
14711       integer :: kkk,nsep=3
14712       real(kind=8) :: qm        !dist,
14713       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
14714       logical :: lprn=.false.
14715       logical :: flag
14716 !      real(kind=8) :: sigm,x
14717
14718 !el      sigm(x)=0.25d0*x     ! local function
14719       qqmax=1.0d10
14720       do kkk=1,nperm
14721       qq = 0.0d0
14722       nl=0
14723        if(flag) then
14724         do il=seg1+nsep,seg2
14725           do jl=seg1,il-nsep
14726             nl=nl+1
14727             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
14728                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
14729                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14730             dij=dist(il,jl)
14731             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14732             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14733               nl=nl+1
14734               d0ijCM=dsqrt( &
14735                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14736                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14737                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14738               dijCM=dist(il+nres,jl+nres)
14739               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14740             endif
14741             qq = qq+qqij+qqijCM
14742           enddo
14743         enddo
14744         qq = qq/nl
14745       else
14746       do il=seg1,seg2
14747         if((seg3-il).lt.3) then
14748              secseg=il+3
14749         else
14750              secseg=seg3
14751         endif
14752           do jl=secseg,seg4
14753             nl=nl+1
14754             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14755                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14756                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14757             dij=dist(il,jl)
14758             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14759             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14760               nl=nl+1
14761               d0ijCM=dsqrt( &
14762                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14763                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14764                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14765               dijCM=dist(il+nres,jl+nres)
14766               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14767             endif
14768             qq = qq+qqij+qqijCM
14769           enddo
14770         enddo
14771       qq = qq/nl
14772       endif
14773       if (qqmax.le.qq) qqmax=qq
14774       enddo
14775       qwolynes=1.0d0-qqmax
14776       return
14777       end function qwolynes
14778 !-----------------------------------------------------------------------------
14779       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
14780 !      implicit real*8 (a-h,o-z)
14781 !      include 'DIMENSIONS'
14782 !      include 'COMMON.IOUNITS'
14783 !      include 'COMMON.CHAIN'
14784 !      include 'COMMON.INTERACT'
14785 !      include 'COMMON.VAR'
14786 !      include 'COMMON.MD'
14787       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
14788       integer :: nsep=3, kkk
14789 !el      real(kind=8) :: dist
14790       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
14791       logical :: lprn=.false.
14792       logical :: flag
14793       real(kind=8) :: sim,dd0,fac,ddqij
14794 !el      sigm(x)=0.25d0*x            ! local function
14795       do kkk=1,nperm
14796       do i=0,nres
14797         do j=1,3
14798           dqwol(j,i)=0.0d0
14799           dxqwol(j,i)=0.0d0
14800         enddo
14801       enddo
14802       nl=0
14803        if(flag) then
14804         do il=seg1+nsep,seg2
14805           do jl=seg1,il-nsep
14806             nl=nl+1
14807             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14808                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14809                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14810             dij=dist(il,jl)
14811             sim = 1.0d0/sigm(d0ij)
14812             sim = sim*sim
14813             dd0 = dij-d0ij
14814             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14815             do k=1,3
14816               ddqij = (c(k,il)-c(k,jl))*fac
14817               dqwol(k,il)=dqwol(k,il)+ddqij
14818               dqwol(k,jl)=dqwol(k,jl)-ddqij
14819             enddo
14820
14821             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14822               nl=nl+1
14823               d0ijCM=dsqrt( &
14824                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14825                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14826                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14827               dijCM=dist(il+nres,jl+nres)
14828               sim = 1.0d0/sigm(d0ijCM)
14829               sim = sim*sim
14830               dd0=dijCM-d0ijCM
14831               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14832               do k=1,3
14833                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14834                 dxqwol(k,il)=dxqwol(k,il)+ddqij
14835                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14836               enddo
14837             endif
14838           enddo
14839         enddo
14840        else
14841         do il=seg1,seg2
14842         if((seg3-il).lt.3) then
14843              secseg=il+3
14844         else
14845              secseg=seg3
14846         endif
14847           do jl=secseg,seg4
14848             nl=nl+1
14849             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14850                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14851                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14852             dij=dist(il,jl)
14853             sim = 1.0d0/sigm(d0ij)
14854             sim = sim*sim
14855             dd0 = dij-d0ij
14856             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14857             do k=1,3
14858               ddqij = (c(k,il)-c(k,jl))*fac
14859               dqwol(k,il)=dqwol(k,il)+ddqij
14860               dqwol(k,jl)=dqwol(k,jl)-ddqij
14861             enddo
14862             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14863               nl=nl+1
14864               d0ijCM=dsqrt( &
14865                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14866                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14867                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14868               dijCM=dist(il+nres,jl+nres)
14869               sim = 1.0d0/sigm(d0ijCM)
14870               sim=sim*sim
14871               dd0 = dijCM-d0ijCM
14872               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14873               do k=1,3
14874                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14875                dxqwol(k,il)=dxqwol(k,il)+ddqij
14876                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14877               enddo
14878             endif
14879           enddo
14880         enddo
14881       endif
14882       enddo
14883        do i=0,nres
14884          do j=1,3
14885            dqwol(j,i)=dqwol(j,i)/nl
14886            dxqwol(j,i)=dxqwol(j,i)/nl
14887          enddo
14888        enddo
14889       return
14890       end subroutine qwolynes_prim
14891 !-----------------------------------------------------------------------------
14892       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
14893 !      implicit real*8 (a-h,o-z)
14894 !      include 'DIMENSIONS'
14895 !      include 'COMMON.IOUNITS'
14896 !      include 'COMMON.CHAIN'
14897 !      include 'COMMON.INTERACT'
14898 !      include 'COMMON.VAR'
14899       integer :: seg1,seg2,seg3,seg4
14900       logical :: flag
14901       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
14902       real(kind=8),dimension(3,0:2*nres) :: cdummy
14903       real(kind=8) :: q1,q2
14904       real(kind=8) :: delta=1.0d-10
14905       integer :: i,j
14906
14907       do i=0,nres
14908         do j=1,3
14909           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14910           cdummy(j,i)=c(j,i)
14911           c(j,i)=c(j,i)+delta
14912           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14913           qwolan(j,i)=(q2-q1)/delta
14914           c(j,i)=cdummy(j,i)
14915         enddo
14916       enddo
14917       do i=0,nres
14918         do j=1,3
14919           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14920           cdummy(j,i+nres)=c(j,i+nres)
14921           c(j,i+nres)=c(j,i+nres)+delta
14922           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14923           qwolxan(j,i)=(q2-q1)/delta
14924           c(j,i+nres)=cdummy(j,i+nres)
14925         enddo
14926       enddo
14927 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
14928 !      do i=0,nct
14929 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
14930 !      enddo
14931 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
14932 !      do i=0,nct
14933 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
14934 !      enddo
14935       return
14936       end subroutine qwol_num
14937 !-----------------------------------------------------------------------------
14938       subroutine EconstrQ
14939 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14940 !      implicit real*8 (a-h,o-z)
14941 !      include 'DIMENSIONS'
14942 !      include 'COMMON.CONTROL'
14943 !      include 'COMMON.VAR'
14944 !      include 'COMMON.MD'
14945       use MD_data
14946 !#ifndef LANG0
14947 !      include 'COMMON.LANGEVIN'
14948 !#else
14949 !      include 'COMMON.LANGEVIN.lang0'
14950 !#endif
14951 !      include 'COMMON.CHAIN'
14952 !      include 'COMMON.DERIV'
14953 !      include 'COMMON.GEO'
14954 !      include 'COMMON.LOCAL'
14955 !      include 'COMMON.INTERACT'
14956 !      include 'COMMON.IOUNITS'
14957 !      include 'COMMON.NAMES'
14958 !      include 'COMMON.TIME1'
14959       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
14960       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
14961                    duconst,duxconst
14962       integer :: kstart,kend,lstart,lend,idummy
14963       real(kind=8) :: delta=1.0d-7
14964       integer :: i,j,k,ii
14965       do i=0,nres
14966          do j=1,3
14967             duconst(j,i)=0.0d0
14968             dudconst(j,i)=0.0d0
14969             duxconst(j,i)=0.0d0
14970             dudxconst(j,i)=0.0d0
14971          enddo
14972       enddo
14973       Uconst=0.0d0
14974       do i=1,nfrag
14975          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14976            idummy,idummy)
14977          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
14978 ! Calculating the derivatives of Constraint energy with respect to Q
14979          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
14980            qinfrag(i,iset))
14981 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
14982 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
14983 !         hmnum=(hm2-hm1)/delta
14984 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
14985 !     &   qinfrag(i,iset))
14986 !         write(iout,*) "harmonicnum frag", hmnum
14987 ! Calculating the derivatives of Q with respect to cartesian coordinates
14988          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14989           idummy,idummy)
14990 !         write(iout,*) "dqwol "
14991 !         do ii=1,nres
14992 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
14993 !         enddo
14994 !         write(iout,*) "dxqwol "
14995 !         do ii=1,nres
14996 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
14997 !         enddo
14998 ! Calculating numerical gradients of dU/dQi and dQi/dxi
14999 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15000 !     &  ,idummy,idummy)
15001 !  The gradients of Uconst in Cs
15002          do ii=0,nres
15003             do j=1,3
15004                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15005                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15006             enddo
15007          enddo
15008       enddo
15009       do i=1,npair
15010          kstart=ifrag(1,ipair(1,i,iset),iset)
15011          kend=ifrag(2,ipair(1,i,iset),iset)
15012          lstart=ifrag(1,ipair(2,i,iset),iset)
15013          lend=ifrag(2,ipair(2,i,iset),iset)
15014          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15015          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15016 !  Calculating dU/dQ
15017          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15018 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15019 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15020 !         hmnum=(hm2-hm1)/delta
15021 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15022 !     &   qinpair(i,iset))
15023 !         write(iout,*) "harmonicnum pair ", hmnum
15024 ! Calculating dQ/dXi
15025          call qwolynes_prim(kstart,kend,.false.,&
15026           lstart,lend)
15027 !         write(iout,*) "dqwol "
15028 !         do ii=1,nres
15029 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15030 !         enddo
15031 !         write(iout,*) "dxqwol "
15032 !         do ii=1,nres
15033 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15034 !        enddo
15035 ! Calculating numerical gradients
15036 !        call qwol_num(kstart,kend,.false.
15037 !     &  ,lstart,lend)
15038 ! The gradients of Uconst in Cs
15039          do ii=0,nres
15040             do j=1,3
15041                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15042                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15043             enddo
15044          enddo
15045       enddo
15046 !      write(iout,*) "Uconst inside subroutine ", Uconst
15047 ! Transforming the gradients from Cs to dCs for the backbone
15048       do i=0,nres
15049          do j=i+1,nres
15050            do k=1,3
15051              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15052            enddo
15053          enddo
15054       enddo
15055 !  Transforming the gradients from Cs to dCs for the side chains
15056       do i=1,nres
15057          do j=1,3
15058            dudxconst(j,i)=duxconst(j,i)
15059          enddo
15060       enddo
15061 !      write(iout,*) "dU/ddc backbone "
15062 !       do ii=0,nres
15063 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15064 !      enddo
15065 !      write(iout,*) "dU/ddX side chain "
15066 !      do ii=1,nres
15067 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15068 !      enddo
15069 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15070 !      call dEconstrQ_num
15071       return
15072       end subroutine EconstrQ
15073 !-----------------------------------------------------------------------------
15074       subroutine dEconstrQ_num
15075 ! Calculating numerical dUconst/ddc and dUconst/ddx
15076 !      implicit real*8 (a-h,o-z)
15077 !      include 'DIMENSIONS'
15078 !      include 'COMMON.CONTROL'
15079 !      include 'COMMON.VAR'
15080 !      include 'COMMON.MD'
15081       use MD_data
15082 !#ifndef LANG0
15083 !      include 'COMMON.LANGEVIN'
15084 !#else
15085 !      include 'COMMON.LANGEVIN.lang0'
15086 !#endif
15087 !      include 'COMMON.CHAIN'
15088 !      include 'COMMON.DERIV'
15089 !      include 'COMMON.GEO'
15090 !      include 'COMMON.LOCAL'
15091 !      include 'COMMON.INTERACT'
15092 !      include 'COMMON.IOUNITS'
15093 !      include 'COMMON.NAMES'
15094 !      include 'COMMON.TIME1'
15095       real(kind=8) :: uzap1,uzap2
15096       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15097       integer :: kstart,kend,lstart,lend,idummy
15098       real(kind=8) :: delta=1.0d-7
15099 !el local variables
15100       integer :: i,ii,j
15101 !     real(kind=8) ::
15102 !     For the backbone
15103       do i=0,nres-1
15104          do j=1,3
15105             dUcartan(j,i)=0.0d0
15106             cdummy(j,i)=dc(j,i)
15107             dc(j,i)=dc(j,i)+delta
15108             call chainbuild_cart
15109             uzap2=0.0d0
15110             do ii=1,nfrag
15111              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15112                 idummy,idummy)
15113                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15114                 qinfrag(ii,iset))
15115             enddo
15116             do ii=1,npair
15117                kstart=ifrag(1,ipair(1,ii,iset),iset)
15118                kend=ifrag(2,ipair(1,ii,iset),iset)
15119                lstart=ifrag(1,ipair(2,ii,iset),iset)
15120                lend=ifrag(2,ipair(2,ii,iset),iset)
15121                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15122                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15123                  qinpair(ii,iset))
15124             enddo
15125             dc(j,i)=cdummy(j,i)
15126             call chainbuild_cart
15127             uzap1=0.0d0
15128              do ii=1,nfrag
15129              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15130                 idummy,idummy)
15131                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15132                 qinfrag(ii,iset))
15133             enddo
15134             do ii=1,npair
15135                kstart=ifrag(1,ipair(1,ii,iset),iset)
15136                kend=ifrag(2,ipair(1,ii,iset),iset)
15137                lstart=ifrag(1,ipair(2,ii,iset),iset)
15138                lend=ifrag(2,ipair(2,ii,iset),iset)
15139                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15140                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15141                 qinpair(ii,iset))
15142             enddo
15143             ducartan(j,i)=(uzap2-uzap1)/(delta)
15144          enddo
15145       enddo
15146 ! Calculating numerical gradients for dU/ddx
15147       do i=0,nres-1
15148          duxcartan(j,i)=0.0d0
15149          do j=1,3
15150             cdummy(j,i)=dc(j,i+nres)
15151             dc(j,i+nres)=dc(j,i+nres)+delta
15152             call chainbuild_cart
15153             uzap2=0.0d0
15154             do ii=1,nfrag
15155              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15156                 idummy,idummy)
15157                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15158                 qinfrag(ii,iset))
15159             enddo
15160             do ii=1,npair
15161                kstart=ifrag(1,ipair(1,ii,iset),iset)
15162                kend=ifrag(2,ipair(1,ii,iset),iset)
15163                lstart=ifrag(1,ipair(2,ii,iset),iset)
15164                lend=ifrag(2,ipair(2,ii,iset),iset)
15165                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15166                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15167                 qinpair(ii,iset))
15168             enddo
15169             dc(j,i+nres)=cdummy(j,i)
15170             call chainbuild_cart
15171             uzap1=0.0d0
15172              do ii=1,nfrag
15173                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15174                 ifrag(2,ii,iset),.true.,idummy,idummy)
15175                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15176                 qinfrag(ii,iset))
15177             enddo
15178             do ii=1,npair
15179                kstart=ifrag(1,ipair(1,ii,iset),iset)
15180                kend=ifrag(2,ipair(1,ii,iset),iset)
15181                lstart=ifrag(1,ipair(2,ii,iset),iset)
15182                lend=ifrag(2,ipair(2,ii,iset),iset)
15183                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15184                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15185                 qinpair(ii,iset))
15186             enddo
15187             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15188          enddo
15189       enddo
15190       write(iout,*) "Numerical dUconst/ddc backbone "
15191       do ii=0,nres
15192         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15193       enddo
15194 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15195 !      do ii=1,nres
15196 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15197 !      enddo
15198       return
15199       end subroutine dEconstrQ_num
15200 !-----------------------------------------------------------------------------
15201 ! ssMD.F
15202 !-----------------------------------------------------------------------------
15203       subroutine check_energies
15204
15205 !      use random, only: ran_number
15206
15207 !      implicit none
15208 !     Includes
15209 !      include 'DIMENSIONS'
15210 !      include 'COMMON.CHAIN'
15211 !      include 'COMMON.VAR'
15212 !      include 'COMMON.IOUNITS'
15213 !      include 'COMMON.SBRIDGE'
15214 !      include 'COMMON.LOCAL'
15215 !      include 'COMMON.GEO'
15216
15217 !     External functions
15218 !EL      double precision ran_number
15219 !EL      external ran_number
15220
15221 !     Local variables
15222       integer :: i,j,k,l,lmax,p,pmax
15223       real(kind=8) :: rmin,rmax
15224       real(kind=8) :: eij
15225
15226       real(kind=8) :: d
15227       real(kind=8) :: wi,rij,tj,pj
15228 !      return
15229
15230       i=5
15231       j=14
15232
15233       d=dsc(1)
15234       rmin=2.0D0
15235       rmax=12.0D0
15236
15237       lmax=10000
15238       pmax=1
15239
15240       do k=1,3
15241         c(k,i)=0.0D0
15242         c(k,j)=0.0D0
15243         c(k,nres+i)=0.0D0
15244         c(k,nres+j)=0.0D0
15245       enddo
15246
15247       do l=1,lmax
15248
15249 !t        wi=ran_number(0.0D0,pi)
15250 !        wi=ran_number(0.0D0,pi/6.0D0)
15251 !        wi=0.0D0
15252 !t        tj=ran_number(0.0D0,pi)
15253 !t        pj=ran_number(0.0D0,pi)
15254 !        pj=ran_number(0.0D0,pi/6.0D0)
15255 !        pj=0.0D0
15256
15257         do p=1,pmax
15258 !t           rij=ran_number(rmin,rmax)
15259
15260            c(1,j)=d*sin(pj)*cos(tj)
15261            c(2,j)=d*sin(pj)*sin(tj)
15262            c(3,j)=d*cos(pj)
15263
15264            c(3,nres+i)=-rij
15265
15266            c(1,i)=d*sin(wi)
15267            c(3,i)=-rij-d*cos(wi)
15268
15269            do k=1,3
15270               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15271               dc_norm(k,nres+i)=dc(k,nres+i)/d
15272               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15273               dc_norm(k,nres+j)=dc(k,nres+j)/d
15274            enddo
15275
15276            call dyn_ssbond_ene(i,j,eij)
15277         enddo
15278       enddo
15279       call exit(1)
15280       return
15281       end subroutine check_energies
15282 !-----------------------------------------------------------------------------
15283       subroutine dyn_ssbond_ene(resi,resj,eij)
15284 !      implicit none
15285 !      Includes
15286       use calc_data
15287       use comm_sschecks
15288 !      include 'DIMENSIONS'
15289 !      include 'COMMON.SBRIDGE'
15290 !      include 'COMMON.CHAIN'
15291 !      include 'COMMON.DERIV'
15292 !      include 'COMMON.LOCAL'
15293 !      include 'COMMON.INTERACT'
15294 !      include 'COMMON.VAR'
15295 !      include 'COMMON.IOUNITS'
15296 !      include 'COMMON.CALC'
15297 #ifndef CLUST
15298 #ifndef WHAM
15299        use MD_data
15300 !      include 'COMMON.MD'
15301 !      use MD, only: totT,t_bath
15302 #endif
15303 #endif
15304 !     External functions
15305 !EL      double precision h_base
15306 !EL      external h_base
15307
15308 !     Input arguments
15309       integer :: resi,resj
15310
15311 !     Output arguments
15312       real(kind=8) :: eij
15313
15314 !     Local variables
15315       logical :: havebond
15316       integer itypi,itypj
15317       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15318       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15319       real(kind=8),dimension(3) :: dcosom1,dcosom2
15320       real(kind=8) :: ed
15321       real(kind=8) :: pom1,pom2
15322       real(kind=8) :: ljA,ljB,ljXs
15323       real(kind=8),dimension(1:3) :: d_ljB
15324       real(kind=8) :: ssA,ssB,ssC,ssXs
15325       real(kind=8) :: ssxm,ljxm,ssm,ljm
15326       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15327       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15328       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15329 !-------FIRST METHOD
15330       real(kind=8) :: xm
15331       real(kind=8),dimension(1:3) :: d_xm
15332 !-------END FIRST METHOD
15333 !-------SECOND METHOD
15334 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15335 !-------END SECOND METHOD
15336
15337 !-------TESTING CODE
15338 !el      logical :: checkstop,transgrad
15339 !el      common /sschecks/ checkstop,transgrad
15340
15341       integer :: icheck,nicheck,jcheck,njcheck
15342       real(kind=8),dimension(-1:1) :: echeck
15343       real(kind=8) :: deps,ssx0,ljx0
15344 !-------END TESTING CODE
15345
15346       eij=0.0d0
15347       i=resi
15348       j=resj
15349
15350 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15351 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15352
15353       itypi=itype(i)
15354       dxi=dc_norm(1,nres+i)
15355       dyi=dc_norm(2,nres+i)
15356       dzi=dc_norm(3,nres+i)
15357       dsci_inv=vbld_inv(i+nres)
15358
15359       itypj=itype(j)
15360       xj=c(1,nres+j)-c(1,nres+i)
15361       yj=c(2,nres+j)-c(2,nres+i)
15362       zj=c(3,nres+j)-c(3,nres+i)
15363       dxj=dc_norm(1,nres+j)
15364       dyj=dc_norm(2,nres+j)
15365       dzj=dc_norm(3,nres+j)
15366       dscj_inv=vbld_inv(j+nres)
15367
15368       chi1=chi(itypi,itypj)
15369       chi2=chi(itypj,itypi)
15370       chi12=chi1*chi2
15371       chip1=chip(itypi)
15372       chip2=chip(itypj)
15373       chip12=chip1*chip2
15374       alf1=alp(itypi)
15375       alf2=alp(itypj)
15376       alf12=0.5D0*(alf1+alf2)
15377
15378       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15379       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15380 !     The following are set in sc_angular
15381 !      erij(1)=xj*rij
15382 !      erij(2)=yj*rij
15383 !      erij(3)=zj*rij
15384 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15385 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15386 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15387       call sc_angular
15388       rij=1.0D0/rij  ! Reset this so it makes sense
15389
15390       sig0ij=sigma(itypi,itypj)
15391       sig=sig0ij*dsqrt(1.0D0/sigsq)
15392
15393       ljXs=sig-sig0ij
15394       ljA=eps1*eps2rt**2*eps3rt**2
15395       ljB=ljA*bb(itypi,itypj)
15396       ljA=ljA*aa(itypi,itypj)
15397       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15398
15399       ssXs=d0cm
15400       deltat1=1.0d0-om1
15401       deltat2=1.0d0+om2
15402       deltat12=om2-om1+2.0d0
15403       cosphi=om12-om1*om2
15404       ssA=akcm
15405       ssB=akct*deltat12
15406       ssC=ss_depth &
15407            +akth*(deltat1*deltat1+deltat2*deltat2) &
15408            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15409       ssxm=ssXs-0.5D0*ssB/ssA
15410
15411 !-------TESTING CODE
15412 !$$$c     Some extra output
15413 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15414 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15415 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15416 !$$$      if (ssx0.gt.0.0d0) then
15417 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15418 !$$$      else
15419 !$$$        ssx0=ssxm
15420 !$$$      endif
15421 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15422 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15423 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15424 !$$$      return
15425 !-------END TESTING CODE
15426
15427 !-------TESTING CODE
15428 !     Stop and plot energy and derivative as a function of distance
15429       if (checkstop) then
15430         ssm=ssC-0.25D0*ssB*ssB/ssA
15431         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15432         if (ssm.lt.ljm .and. &
15433              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15434           nicheck=1000
15435           njcheck=1
15436           deps=0.5d-7
15437         else
15438           checkstop=.false.
15439         endif
15440       endif
15441       if (.not.checkstop) then
15442         nicheck=0
15443         njcheck=-1
15444       endif
15445
15446       do icheck=0,nicheck
15447       do jcheck=-1,njcheck
15448       if (checkstop) rij=(ssxm-1.0d0)+ &
15449              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15450 !-------END TESTING CODE
15451
15452       if (rij.gt.ljxm) then
15453         havebond=.false.
15454         ljd=rij-ljXs
15455         fac=(1.0D0/ljd)**expon
15456         e1=fac*fac*aa(itypi,itypj)
15457         e2=fac*bb(itypi,itypj)
15458         eij=eps1*eps2rt*eps3rt*(e1+e2)
15459         eps2der=eij*eps3rt
15460         eps3der=eij*eps2rt
15461         eij=eij*eps2rt*eps3rt
15462
15463         sigder=-sig/sigsq
15464         e1=e1*eps1*eps2rt**2*eps3rt**2
15465         ed=-expon*(e1+eij)/ljd
15466         sigder=ed*sigder
15467         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15468         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15469         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15470              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15471       else if (rij.lt.ssxm) then
15472         havebond=.true.
15473         ssd=rij-ssXs
15474         eij=ssA*ssd*ssd+ssB*ssd+ssC
15475
15476         ed=2*akcm*ssd+akct*deltat12
15477         pom1=akct*ssd
15478         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15479         eom1=-2*akth*deltat1-pom1-om2*pom2
15480         eom2= 2*akth*deltat2+pom1-om1*pom2
15481         eom12=pom2
15482       else
15483         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15484
15485         d_ssxm(1)=0.5D0*akct/ssA
15486         d_ssxm(2)=-d_ssxm(1)
15487         d_ssxm(3)=0.0D0
15488
15489         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15490         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15491         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15492         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15493
15494 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15495         xm=0.5d0*(ssxm+ljxm)
15496         do k=1,3
15497           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15498         enddo
15499         if (rij.lt.xm) then
15500           havebond=.true.
15501           ssm=ssC-0.25D0*ssB*ssB/ssA
15502           d_ssm(1)=0.5D0*akct*ssB/ssA
15503           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15504           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15505           d_ssm(3)=omega
15506           f1=(rij-xm)/(ssxm-xm)
15507           f2=(rij-ssxm)/(xm-ssxm)
15508           h1=h_base(f1,hd1)
15509           h2=h_base(f2,hd2)
15510           eij=ssm*h1+Ht*h2
15511           delta_inv=1.0d0/(xm-ssxm)
15512           deltasq_inv=delta_inv*delta_inv
15513           fac=ssm*hd1-Ht*hd2
15514           fac1=deltasq_inv*fac*(xm-rij)
15515           fac2=deltasq_inv*fac*(rij-ssxm)
15516           ed=delta_inv*(Ht*hd2-ssm*hd1)
15517           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
15518           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
15519           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
15520         else
15521           havebond=.false.
15522           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15523           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
15524           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
15525           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
15526                alf12/eps3rt)
15527           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
15528           f1=(rij-ljxm)/(xm-ljxm)
15529           f2=(rij-xm)/(ljxm-xm)
15530           h1=h_base(f1,hd1)
15531           h2=h_base(f2,hd2)
15532           eij=Ht*h1+ljm*h2
15533           delta_inv=1.0d0/(ljxm-xm)
15534           deltasq_inv=delta_inv*delta_inv
15535           fac=Ht*hd1-ljm*hd2
15536           fac1=deltasq_inv*fac*(ljxm-rij)
15537           fac2=deltasq_inv*fac*(rij-xm)
15538           ed=delta_inv*(ljm*hd2-Ht*hd1)
15539           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
15540           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
15541           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
15542         endif
15543 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15544
15545 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15546 !$$$        ssd=rij-ssXs
15547 !$$$        ljd=rij-ljXs
15548 !$$$        fac1=rij-ljxm
15549 !$$$        fac2=rij-ssxm
15550 !$$$
15551 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
15552 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
15553 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
15554 !$$$
15555 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
15556 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
15557 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15558 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15559 !$$$        d_ssm(3)=omega
15560 !$$$
15561 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
15562 !$$$        do k=1,3
15563 !$$$          d_ljm(k)=ljm*d_ljB(k)
15564 !$$$        enddo
15565 !$$$        ljm=ljm*ljB
15566 !$$$
15567 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
15568 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
15569 !$$$        d_ss(2)=akct*ssd
15570 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
15571 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
15572 !$$$        d_ss(3)=omega
15573 !$$$
15574 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
15575 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
15576 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
15577 !$$$        do k=1,3
15578 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
15579 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
15580 !$$$        enddo
15581 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
15582 !$$$
15583 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
15584 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
15585 !$$$        h1=h_base(f1,hd1)
15586 !$$$        h2=h_base(f2,hd2)
15587 !$$$        eij=ss*h1+ljf*h2
15588 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
15589 !$$$        deltasq_inv=delta_inv*delta_inv
15590 !$$$        fac=ljf*hd2-ss*hd1
15591 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
15592 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
15593 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
15594 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
15595 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
15596 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
15597 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
15598 !$$$
15599 !$$$        havebond=.false.
15600 !$$$        if (ed.gt.0.0d0) havebond=.true.
15601 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15602
15603       endif
15604
15605       if (havebond) then
15606 !#ifndef CLUST
15607 !#ifndef WHAM
15608 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
15609 !          write(iout,'(a15,f12.2,f8.1,2i5)')
15610 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
15611 !        endif
15612 !#endif
15613 !#endif
15614         dyn_ssbond_ij(i,j)=eij
15615       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
15616         dyn_ssbond_ij(i,j)=1.0d300
15617 !#ifndef CLUST
15618 !#ifndef WHAM
15619 !        write(iout,'(a15,f12.2,f8.1,2i5)')
15620 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
15621 !#endif
15622 !#endif
15623       endif
15624
15625 !-------TESTING CODE
15626 !el      if (checkstop) then
15627         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
15628              "CHECKSTOP",rij,eij,ed
15629         echeck(jcheck)=eij
15630 !el      endif
15631       enddo
15632       if (checkstop) then
15633         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
15634       endif
15635       enddo
15636       if (checkstop) then
15637         transgrad=.true.
15638         checkstop=.false.
15639       endif
15640 !-------END TESTING CODE
15641
15642       do k=1,3
15643         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
15644         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
15645       enddo
15646       do k=1,3
15647         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
15648       enddo
15649       do k=1,3
15650         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15651              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15652              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15653         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15654              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15655              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15656       enddo
15657 !grad      do k=i,j-1
15658 !grad        do l=1,3
15659 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
15660 !grad        enddo
15661 !grad      enddo
15662
15663       do l=1,3
15664         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15665         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15666       enddo
15667
15668       return
15669       end subroutine dyn_ssbond_ene
15670 !-----------------------------------------------------------------------------
15671       real(kind=8) function h_base(x,deriv)
15672 !     A smooth function going 0->1 in range [0,1]
15673 !     It should NOT be called outside range [0,1], it will not work there.
15674       implicit none
15675
15676 !     Input arguments
15677       real(kind=8) :: x
15678
15679 !     Output arguments
15680       real(kind=8) :: deriv
15681
15682 !     Local variables
15683       real(kind=8) :: xsq
15684
15685
15686 !     Two parabolas put together.  First derivative zero at extrema
15687 !$$$      if (x.lt.0.5D0) then
15688 !$$$        h_base=2.0D0*x*x
15689 !$$$        deriv=4.0D0*x
15690 !$$$      else
15691 !$$$        deriv=1.0D0-x
15692 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
15693 !$$$        deriv=4.0D0*deriv
15694 !$$$      endif
15695
15696 !     Third degree polynomial.  First derivative zero at extrema
15697       h_base=x*x*(3.0d0-2.0d0*x)
15698       deriv=6.0d0*x*(1.0d0-x)
15699
15700 !     Fifth degree polynomial.  First and second derivatives zero at extrema
15701 !$$$      xsq=x*x
15702 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
15703 !$$$      deriv=x-1.0d0
15704 !$$$      deriv=deriv*deriv
15705 !$$$      deriv=30.0d0*xsq*deriv
15706
15707       return
15708       end function h_base
15709 !-----------------------------------------------------------------------------
15710       subroutine dyn_set_nss
15711 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
15712 !      implicit none
15713       use MD_data, only: totT,t_bath
15714 !     Includes
15715 !      include 'DIMENSIONS'
15716 #ifdef MPI
15717       include "mpif.h"
15718 #endif
15719 !      include 'COMMON.SBRIDGE'
15720 !      include 'COMMON.CHAIN'
15721 !      include 'COMMON.IOUNITS'
15722 !      include 'COMMON.SETUP'
15723 !      include 'COMMON.MD'
15724 !     Local variables
15725       real(kind=8) :: emin
15726       integer :: i,j,imin,ierr
15727       integer :: diff,allnss,newnss
15728       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15729                 newihpb,newjhpb
15730       logical :: found
15731       integer,dimension(0:nfgtasks) :: i_newnss
15732       integer,dimension(0:nfgtasks) :: displ
15733       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15734       integer :: g_newnss
15735
15736       allnss=0
15737       do i=1,nres-1
15738         do j=i+1,nres
15739           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
15740             allnss=allnss+1
15741             allflag(allnss)=0
15742             allihpb(allnss)=i
15743             alljhpb(allnss)=j
15744           endif
15745         enddo
15746       enddo
15747
15748 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15749
15750  1    emin=1.0d300
15751       do i=1,allnss
15752         if (allflag(i).eq.0 .and. &
15753              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
15754           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
15755           imin=i
15756         endif
15757       enddo
15758       if (emin.lt.1.0d300) then
15759         allflag(imin)=1
15760         do i=1,allnss
15761           if (allflag(i).eq.0 .and. &
15762                (allihpb(i).eq.allihpb(imin) .or. &
15763                alljhpb(i).eq.allihpb(imin) .or. &
15764                allihpb(i).eq.alljhpb(imin) .or. &
15765                alljhpb(i).eq.alljhpb(imin))) then
15766             allflag(i)=-1
15767           endif
15768         enddo
15769         goto 1
15770       endif
15771
15772 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15773
15774       newnss=0
15775       do i=1,allnss
15776         if (allflag(i).eq.1) then
15777           newnss=newnss+1
15778           newihpb(newnss)=allihpb(i)
15779           newjhpb(newnss)=alljhpb(i)
15780         endif
15781       enddo
15782
15783 #ifdef MPI
15784       if (nfgtasks.gt.1)then
15785
15786         call MPI_Reduce(newnss,g_newnss,1,&
15787           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
15788         call MPI_Gather(newnss,1,MPI_INTEGER,&
15789                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
15790         displ(0)=0
15791         do i=1,nfgtasks-1,1
15792           displ(i)=i_newnss(i-1)+displ(i-1)
15793         enddo
15794         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
15795                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
15796                          king,FG_COMM,IERR)
15797         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
15798                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
15799                          king,FG_COMM,IERR)
15800         if(fg_rank.eq.0) then
15801 !         print *,'g_newnss',g_newnss
15802 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
15803 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
15804          newnss=g_newnss
15805          do i=1,newnss
15806           newihpb(i)=g_newihpb(i)
15807           newjhpb(i)=g_newjhpb(i)
15808          enddo
15809         endif
15810       endif
15811 #endif
15812
15813       diff=newnss-nss
15814
15815 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
15816
15817       do i=1,nss
15818         found=.false.
15819         do j=1,newnss
15820           if (idssb(i).eq.newihpb(j) .and. &
15821                jdssb(i).eq.newjhpb(j)) found=.true.
15822         enddo
15823 #ifndef CLUST
15824 #ifndef WHAM
15825         if (.not.found.and.fg_rank.eq.0) &
15826             write(iout,'(a15,f12.2,f8.1,2i5)') &
15827              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
15828 #endif
15829 #endif
15830       enddo
15831
15832       do i=1,newnss
15833         found=.false.
15834         do j=1,nss
15835           if (newihpb(i).eq.idssb(j) .and. &
15836                newjhpb(i).eq.jdssb(j)) found=.true.
15837         enddo
15838 #ifndef CLUST
15839 #ifndef WHAM
15840         if (.not.found.and.fg_rank.eq.0) &
15841             write(iout,'(a15,f12.2,f8.1,2i5)') &
15842              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
15843 #endif
15844 #endif
15845       enddo
15846
15847       nss=newnss
15848       do i=1,nss
15849         idssb(i)=newihpb(i)
15850         jdssb(i)=newjhpb(i)
15851       enddo
15852
15853       return
15854       end subroutine dyn_set_nss
15855 !-----------------------------------------------------------------------------
15856 #ifdef WHAM
15857       subroutine read_ssHist
15858 !      implicit none
15859 !      Includes
15860 !      include 'DIMENSIONS'
15861 !      include "DIMENSIONS.FREE"
15862 !      include 'COMMON.FREE'
15863 !     Local variables
15864       integer :: i,j
15865       character(len=80) :: controlcard
15866
15867       do i=1,dyn_nssHist
15868         call card_concat(controlcard,.true.)
15869         read(controlcard,*) &
15870              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
15871       enddo
15872
15873       return
15874       end subroutine read_ssHist
15875 #endif
15876 !-----------------------------------------------------------------------------
15877       integer function indmat(i,j)
15878 !el
15879 ! get the position of the jth ijth fragment of the chain coordinate system
15880 ! in the fromto array.
15881         integer :: i,j
15882
15883         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
15884       return
15885       end function indmat
15886 !-----------------------------------------------------------------------------
15887       real(kind=8) function sigm(x)
15888 !el
15889        real(kind=8) :: x
15890         sigm=0.25d0*x
15891       return
15892       end function sigm
15893 !-----------------------------------------------------------------------------
15894 !-----------------------------------------------------------------------------
15895       subroutine alloc_ener_arrays
15896 !EL Allocation of arrays used by module energy
15897
15898 !el local variables
15899       integer :: i,j
15900
15901       if(nres.lt.100) then
15902         maxconts=nres
15903       elseif(nres.lt.200) then
15904         maxconts=0.8*nres       ! Max. number of contacts per residue
15905       else
15906         maxconts=0.6*nres ! (maxconts=maxres/4)
15907       endif
15908       maxcont=12*nres   ! Max. number of SC contacts
15909       maxvar=6*nres     ! Max. number of variables
15910 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15911       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15912 !----------------------
15913 ! arrays in subroutine init_int_table
15914 !el#ifdef MPI
15915 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
15916 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
15917 !el#endif
15918       allocate(nint_gr(nres))
15919       allocate(nscp_gr(nres))
15920       allocate(ielstart(nres))
15921       allocate(ielend(nres))
15922 !(maxres)
15923       allocate(istart(nres,maxint_gr))
15924       allocate(iend(nres,maxint_gr))
15925 !(maxres,maxint_gr)
15926       allocate(iscpstart(nres,maxint_gr))
15927       allocate(iscpend(nres,maxint_gr))
15928 !(maxres,maxint_gr)
15929       allocate(ielstart_vdw(nres))
15930       allocate(ielend_vdw(nres))
15931 !(maxres)
15932
15933       allocate(lentyp(0:nfgtasks-1))
15934 !(0:maxprocs-1)
15935 !----------------------
15936 ! commom.contacts
15937 !      common /contacts/
15938       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
15939       allocate(icont(2,maxcont))
15940 !(2,maxcont)
15941 !      common /contacts1/
15942       allocate(num_cont(0:nres+4))
15943 !(maxres)
15944       allocate(jcont(maxconts,nres))
15945 !(maxconts,maxres)
15946       allocate(facont(maxconts,nres))
15947 !(maxconts,maxres)
15948       allocate(gacont(3,maxconts,nres))
15949 !(3,maxconts,maxres)
15950 !      common /contacts_hb/
15951       allocate(gacontp_hb1(3,maxconts,nres))
15952       allocate(gacontp_hb2(3,maxconts,nres))
15953       allocate(gacontp_hb3(3,maxconts,nres))
15954       allocate(gacontm_hb1(3,maxconts,nres))
15955       allocate(gacontm_hb2(3,maxconts,nres))
15956       allocate(gacontm_hb3(3,maxconts,nres))
15957       allocate(gacont_hbr(3,maxconts,nres))
15958       allocate(grij_hb_cont(3,maxconts,nres))
15959 !(3,maxconts,maxres)
15960       allocate(facont_hb(maxconts,nres))
15961       allocate(ees0p(maxconts,nres))
15962       allocate(ees0m(maxconts,nres))
15963       allocate(d_cont(maxconts,nres))
15964 !(maxconts,maxres)
15965       allocate(num_cont_hb(nres))
15966 !(maxres)
15967       allocate(jcont_hb(maxconts,nres))
15968 !(maxconts,maxres)
15969 !      common /rotat/
15970       allocate(Ug(2,2,nres))
15971       allocate(Ugder(2,2,nres))
15972       allocate(Ug2(2,2,nres))
15973       allocate(Ug2der(2,2,nres))
15974 !(2,2,maxres)
15975       allocate(obrot(2,nres))
15976       allocate(obrot2(2,nres))
15977       allocate(obrot_der(2,nres))
15978       allocate(obrot2_der(2,nres))
15979 !(2,maxres)
15980 !      common /precomp1/
15981       allocate(mu(2,nres))
15982       allocate(muder(2,nres))
15983       allocate(Ub2(2,nres))
15984         do i=1,nres
15985           Ub2(1,i)=0.0d0
15986           Ub2(2,i)=0.0d0
15987         enddo
15988       allocate(Ub2der(2,nres))
15989       allocate(Ctobr(2,nres))
15990       allocate(Ctobrder(2,nres))
15991       allocate(Dtobr2(2,nres))
15992       allocate(Dtobr2der(2,nres))
15993 !(2,maxres)
15994       allocate(EUg(2,2,nres))
15995       allocate(EUgder(2,2,nres))
15996       allocate(CUg(2,2,nres))
15997       allocate(CUgder(2,2,nres))
15998       allocate(DUg(2,2,nres))
15999       allocate(Dugder(2,2,nres))
16000       allocate(DtUg2(2,2,nres))
16001       allocate(DtUg2der(2,2,nres))
16002 !(2,2,maxres)
16003 !      common /precomp2/
16004       allocate(Ug2Db1t(2,nres))
16005       allocate(Ug2Db1tder(2,nres))
16006       allocate(CUgb2(2,nres))
16007       allocate(CUgb2der(2,nres))
16008 !(2,maxres)
16009       allocate(EUgC(2,2,nres))
16010       allocate(EUgCder(2,2,nres))
16011       allocate(EUgD(2,2,nres))
16012       allocate(EUgDder(2,2,nres))
16013       allocate(DtUg2EUg(2,2,nres))
16014       allocate(Ug2DtEUg(2,2,nres))
16015 !(2,2,maxres)
16016       allocate(Ug2DtEUgder(2,2,2,nres))
16017       allocate(DtUg2EUgder(2,2,2,nres))
16018 !(2,2,2,maxres)
16019 !      common /rotat_old/
16020       allocate(costab(nres))
16021       allocate(sintab(nres))
16022       allocate(costab2(nres))
16023       allocate(sintab2(nres))
16024 !(maxres)
16025 !      common /dipmat/
16026       allocate(a_chuj(2,2,maxconts,nres))
16027 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16028       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16029 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16030 !      common /contdistrib/
16031       allocate(ncont_sent(nres))
16032       allocate(ncont_recv(nres))
16033
16034       allocate(iat_sent(nres))
16035 !(maxres)
16036       allocate(iint_sent(4,nres,nres))
16037       allocate(iint_sent_local(4,nres,nres))
16038 !(4,maxres,maxres)
16039       allocate(iturn3_sent(4,0:nres+4))
16040       allocate(iturn4_sent(4,0:nres+4))
16041       allocate(iturn3_sent_local(4,nres))
16042       allocate(iturn4_sent_local(4,nres))
16043 !(4,maxres)
16044       allocate(itask_cont_from(0:nfgtasks-1))
16045       allocate(itask_cont_to(0:nfgtasks-1))
16046 !(0:max_fg_procs-1)
16047
16048
16049
16050 !----------------------
16051 ! commom.deriv;
16052 !      common /derivat/
16053       allocate(dcdv(6,maxdim))
16054       allocate(dxdv(6,maxdim))
16055 !(6,maxdim)
16056       allocate(dxds(6,nres))
16057 !(6,maxres)
16058       allocate(gradx(3,nres,0:2))
16059       allocate(gradc(3,nres,0:2))
16060 !(3,maxres,2)
16061       allocate(gvdwx(3,nres))
16062       allocate(gvdwc(3,nres))
16063       allocate(gelc(3,nres))
16064       allocate(gelc_long(3,nres))
16065       allocate(gvdwpp(3,nres))
16066       allocate(gvdwc_scpp(3,nres))
16067       allocate(gradx_scp(3,nres))
16068       allocate(gvdwc_scp(3,nres))
16069       allocate(ghpbx(3,nres))
16070       allocate(ghpbc(3,nres))
16071       allocate(gradcorr(3,nres))
16072       allocate(gradcorr_long(3,nres))
16073       allocate(gradcorr5_long(3,nres))
16074       allocate(gradcorr6_long(3,nres))
16075       allocate(gcorr6_turn_long(3,nres))
16076       allocate(gradxorr(3,nres))
16077       allocate(gradcorr5(3,nres))
16078       allocate(gradcorr6(3,nres))
16079 !(3,maxres)
16080       allocate(gloc(0:maxvar,0:2))
16081       allocate(gloc_x(0:maxvar,2))
16082 !(maxvar,2)
16083       allocate(gel_loc(3,nres))
16084       allocate(gel_loc_long(3,nres))
16085       allocate(gcorr3_turn(3,nres))
16086       allocate(gcorr4_turn(3,nres))
16087       allocate(gcorr6_turn(3,nres))
16088       allocate(gradb(3,nres))
16089       allocate(gradbx(3,nres))
16090 !(3,maxres)
16091       allocate(gel_loc_loc(maxvar))
16092       allocate(gel_loc_turn3(maxvar))
16093       allocate(gel_loc_turn4(maxvar))
16094       allocate(gel_loc_turn6(maxvar))
16095       allocate(gcorr_loc(maxvar))
16096       allocate(g_corr5_loc(maxvar))
16097       allocate(g_corr6_loc(maxvar))
16098 !(maxvar)
16099       allocate(gsccorc(3,nres))
16100       allocate(gsccorx(3,nres))
16101 !(3,maxres)
16102       allocate(gsccor_loc(nres))
16103 !(maxres)
16104       allocate(dtheta(3,2,nres))
16105 !(3,2,maxres)
16106       allocate(gscloc(3,nres))
16107       allocate(gsclocx(3,nres))
16108 !(3,maxres)
16109       allocate(dphi(3,3,nres))
16110       allocate(dalpha(3,3,nres))
16111       allocate(domega(3,3,nres))
16112 !(3,3,maxres)
16113 !      common /deriv_scloc/
16114       allocate(dXX_C1tab(3,nres))
16115       allocate(dYY_C1tab(3,nres))
16116       allocate(dZZ_C1tab(3,nres))
16117       allocate(dXX_Ctab(3,nres))
16118       allocate(dYY_Ctab(3,nres))
16119       allocate(dZZ_Ctab(3,nres))
16120       allocate(dXX_XYZtab(3,nres))
16121       allocate(dYY_XYZtab(3,nres))
16122       allocate(dZZ_XYZtab(3,nres))
16123 !(3,maxres)
16124 !      common /mpgrad/
16125       allocate(jgrad_start(nres))
16126       allocate(jgrad_end(nres))
16127 !(maxres)
16128 !----------------------
16129
16130 !      common /indices/
16131       allocate(ibond_displ(0:nfgtasks-1))
16132       allocate(ibond_count(0:nfgtasks-1))
16133       allocate(ithet_displ(0:nfgtasks-1))
16134       allocate(ithet_count(0:nfgtasks-1))
16135       allocate(iphi_displ(0:nfgtasks-1))
16136       allocate(iphi_count(0:nfgtasks-1))
16137       allocate(iphi1_displ(0:nfgtasks-1))
16138       allocate(iphi1_count(0:nfgtasks-1))
16139       allocate(ivec_displ(0:nfgtasks-1))
16140       allocate(ivec_count(0:nfgtasks-1))
16141       allocate(iset_displ(0:nfgtasks-1))
16142       allocate(iset_count(0:nfgtasks-1))
16143       allocate(iint_count(0:nfgtasks-1))
16144       allocate(iint_displ(0:nfgtasks-1))
16145 !(0:max_fg_procs-1)
16146 !----------------------
16147 ! common.MD
16148 !      common /mdgrad/
16149       allocate(gcart(3,0:nres))
16150       allocate(gxcart(3,0:nres))
16151 !(3,0:MAXRES)
16152       allocate(gradcag(3,nres))
16153       allocate(gradxag(3,nres))
16154 !(3,MAXRES)
16155 !      common /back_constr/
16156 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16157       allocate(dutheta(nres))
16158       allocate(dugamma(nres))
16159 !(maxres)
16160       allocate(duscdiff(3,nres))
16161       allocate(duscdiffx(3,nres))
16162 !(3,maxres)
16163 !el i io:read_fragments
16164 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16165 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16166 !      common /qmeas/
16167 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16168 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16169       allocate(mset(0:nprocs))  !(maxprocs/20)
16170       do i=0,nprocs
16171         mset(i)=0
16172       enddo
16173 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16174 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16175       allocate(dUdconst(3,0:nres))
16176       allocate(dUdxconst(3,0:nres))
16177       allocate(dqwol(3,0:nres))
16178       allocate(dxqwol(3,0:nres))
16179 !(3,0:MAXRES)
16180 !----------------------
16181 ! common.sbridge
16182 !      common /sbridge/ in io_common: read_bridge
16183 !el    allocate((:),allocatable :: iss  !(maxss)
16184 !      common /links/  in io_common: read_bridge
16185 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16186 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16187 !      common /dyn_ssbond/
16188 ! and side-chain vectors in theta or phi.
16189       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16190 !(maxres,maxres)
16191       do i=1,nres
16192         do j=i+1,nres
16193           dyn_ssbond_ij(i,j)=1.0d300
16194         enddo
16195       enddo
16196
16197       if (nss.gt.0) then
16198         allocate(idssb(nss),jdssb(nss))
16199 !(maxdim)
16200       endif
16201       allocate(dyn_ss_mask(nres))
16202 !(maxres)
16203       do i=1,nres
16204         dyn_ss_mask(i)=.false.
16205       enddo
16206 !----------------------
16207 ! common.sccor
16208 ! Parameters of the SCCOR term
16209 !      common/sccor/
16210 !el in io_conf: parmread
16211 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16212 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16213 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16214 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16215 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16216 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16217 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16218 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16219 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16220 !----------------
16221       allocate(gloc_sc(3,0:2*nres,0:10))
16222 !(3,0:maxres2,10)maxres2=2*maxres
16223       allocate(dcostau(3,3,3,2*nres))
16224       allocate(dsintau(3,3,3,2*nres))
16225       allocate(dtauangle(3,3,3,2*nres))
16226       allocate(dcosomicron(3,3,3,2*nres))
16227       allocate(domicron(3,3,3,2*nres))
16228 !(3,3,3,maxres2)maxres2=2*maxres
16229 !----------------------
16230 ! common.var
16231 !      common /restr/
16232       allocate(varall(maxvar))
16233 !(maxvar)(maxvar=6*maxres)
16234       allocate(mask_theta(nres))
16235       allocate(mask_phi(nres))
16236       allocate(mask_side(nres))
16237 !(maxres)
16238 !----------------------
16239 ! common.vectors
16240 !      common /vectors/
16241       allocate(uy(3,nres))
16242       allocate(uz(3,nres))
16243 !(3,maxres)
16244       allocate(uygrad(3,3,2,nres))
16245       allocate(uzgrad(3,3,2,nres))
16246 !(3,3,2,maxres)
16247
16248       return
16249       end subroutine alloc_ener_arrays
16250 !-----------------------------------------------------------------------------
16251 !-----------------------------------------------------------------------------
16252       end module energy