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-3).eq.ntyp1 &
5541              .or. itype(i).eq.ntyp1) cycle
5542         etors_ii=0.0D0
5543          if (iabs(itype(i)).eq.20) then
5544          iblock=2
5545          else
5546          iblock=1
5547          endif
5548         itori=itortyp(itype(i-2))
5549         itori1=itortyp(itype(i-1))
5550         phii=phi(i)
5551         gloci=0.0D0
5552 ! Regular cosine and sine terms
5553         do j=1,nterm(itori,itori1,iblock)
5554           v1ij=v1(j,itori,itori1,iblock)
5555           v2ij=v2(j,itori,itori1,iblock)
5556           cosphi=dcos(j*phii)
5557           sinphi=dsin(j*phii)
5558           etors=etors+v1ij*cosphi+v2ij*sinphi
5559           if (energy_dec) etors_ii=etors_ii+ &
5560                      v1ij*cosphi+v2ij*sinphi
5561           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5562         enddo
5563 ! Lorentz terms
5564 !                         v1
5565 !  E = SUM ----------------------------------- - v1
5566 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5567 !
5568         cosphi=dcos(0.5d0*phii)
5569         sinphi=dsin(0.5d0*phii)
5570         do j=1,nlor(itori,itori1,iblock)
5571           vl1ij=vlor1(j,itori,itori1)
5572           vl2ij=vlor2(j,itori,itori1)
5573           vl3ij=vlor3(j,itori,itori1)
5574           pom=vl2ij*cosphi+vl3ij*sinphi
5575           pom1=1.0d0/(pom*pom+1.0d0)
5576           etors=etors+vl1ij*pom1
5577           if (energy_dec) etors_ii=etors_ii+ &
5578                      vl1ij*pom1
5579           pom=-pom*pom1*pom1
5580           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5581         enddo
5582 ! Subtract the constant term
5583         etors=etors-v0(itori,itori1,iblock)
5584           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5585                'etor',i,etors_ii-v0(itori,itori1,iblock)
5586         if (lprn) &
5587         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5588         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5589         (v1(j,itori,itori1,iblock),j=1,6),&
5590         (v2(j,itori,itori1,iblock),j=1,6)
5591         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5592 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5593       enddo
5594 ! 6/20/98 - dihedral angle constraints
5595       edihcnstr=0.0d0
5596 !      do i=1,ndih_constr
5597       do i=idihconstr_start,idihconstr_end
5598         itori=idih_constr(i)
5599         phii=phi(itori)
5600         difi=pinorm(phii-phi0(i))
5601         if (difi.gt.drange(i)) then
5602           difi=difi-drange(i)
5603           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5604           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5605         else if (difi.lt.-drange(i)) then
5606           difi=difi+drange(i)
5607           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5608           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5609         else
5610           difi=0.0
5611         endif
5612 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5613 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5614 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5615       enddo
5616 !d       write (iout,*) 'edihcnstr',edihcnstr
5617       return
5618       end subroutine etor
5619 !-----------------------------------------------------------------------------
5620       subroutine etor_d(etors_d)
5621 ! 6/23/01 Compute double torsional energy
5622 !      implicit real*8 (a-h,o-z)
5623 !      include 'DIMENSIONS'
5624 !      include 'COMMON.VAR'
5625 !      include 'COMMON.GEO'
5626 !      include 'COMMON.LOCAL'
5627 !      include 'COMMON.TORSION'
5628 !      include 'COMMON.INTERACT'
5629 !      include 'COMMON.DERIV'
5630 !      include 'COMMON.CHAIN'
5631 !      include 'COMMON.NAMES'
5632 !      include 'COMMON.IOUNITS'
5633 !      include 'COMMON.FFIELD'
5634 !      include 'COMMON.TORCNSTR'
5635       real(kind=8) :: etors_d,etors_d_ii
5636       logical :: lprn
5637 !el local variables
5638       integer :: i,j,k,l,itori,itori1,itori2,iblock
5639       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5640                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5641                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5642                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5643 ! Set lprn=.true. for debugging
5644       lprn=.false.
5645 !     lprn=.true.
5646       etors_d=0.0D0
5647 !      write(iout,*) "a tu??"
5648       do i=iphid_start,iphid_end
5649         etors_d_ii=0.0D0
5650         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5651             .or. itype(i-3).eq.ntyp1 &
5652             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5653         itori=itortyp(itype(i-2))
5654         itori1=itortyp(itype(i-1))
5655         itori2=itortyp(itype(i))
5656         phii=phi(i)
5657         phii1=phi(i+1)
5658         gloci1=0.0D0
5659         gloci2=0.0D0
5660         iblock=1
5661         if (iabs(itype(i+1)).eq.20) iblock=2
5662
5663 ! Regular cosine and sine terms
5664         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5665           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5666           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5667           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5668           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5669           cosphi1=dcos(j*phii)
5670           sinphi1=dsin(j*phii)
5671           cosphi2=dcos(j*phii1)
5672           sinphi2=dsin(j*phii1)
5673           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5674            v2cij*cosphi2+v2sij*sinphi2
5675           if (energy_dec) etors_d_ii=etors_d_ii+ &
5676            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5677           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5678           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5679         enddo
5680         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5681           do l=1,k-1
5682             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5683             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5684             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5685             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5686             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5687             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5688             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5689             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5690             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5691               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5692             if (energy_dec) etors_d_ii=etors_d_ii+ &
5693               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5694               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5695             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5696               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5697             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5698               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5699           enddo
5700         enddo
5701         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5702                             'etor_d',i,etors_d_ii
5703         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5704         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5705       enddo
5706       return
5707       end subroutine etor_d
5708 #endif
5709 !-----------------------------------------------------------------------------
5710       subroutine eback_sc_corr(esccor)
5711 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5712 !        conformational states; temporarily implemented as differences
5713 !        between UNRES torsional potentials (dependent on three types of
5714 !        residues) and the torsional potentials dependent on all 20 types
5715 !        of residues computed from AM1  energy surfaces of terminally-blocked
5716 !        amino-acid residues.
5717 !      implicit real*8 (a-h,o-z)
5718 !      include 'DIMENSIONS'
5719 !      include 'COMMON.VAR'
5720 !      include 'COMMON.GEO'
5721 !      include 'COMMON.LOCAL'
5722 !      include 'COMMON.TORSION'
5723 !      include 'COMMON.SCCOR'
5724 !      include 'COMMON.INTERACT'
5725 !      include 'COMMON.DERIV'
5726 !      include 'COMMON.CHAIN'
5727 !      include 'COMMON.NAMES'
5728 !      include 'COMMON.IOUNITS'
5729 !      include 'COMMON.FFIELD'
5730 !      include 'COMMON.CONTROL'
5731       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5732                    cosphi,sinphi
5733       logical :: lprn
5734       integer :: i,interty,j,isccori,isccori1,intertyp
5735 ! Set lprn=.true. for debugging
5736       lprn=.false.
5737 !      lprn=.true.
5738 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5739       esccor=0.0D0
5740       do i=itau_start,itau_end
5741         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5742         esccor_ii=0.0D0
5743         isccori=isccortyp(itype(i-2))
5744         isccori1=isccortyp(itype(i-1))
5745
5746 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5747         phii=phi(i)
5748         do intertyp=1,3 !intertyp
5749          esccor_ii=0.0D0
5750 !c Added 09 May 2012 (Adasko)
5751 !c  Intertyp means interaction type of backbone mainchain correlation:
5752 !   1 = SC...Ca...Ca...Ca
5753 !   2 = Ca...Ca...Ca...SC
5754 !   3 = SC...Ca...Ca...SCi
5755         gloci=0.0D0
5756         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5757             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5758             (itype(i-1).eq.ntyp1))) &
5759           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5760            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5761            .or.(itype(i).eq.ntyp1))) &
5762           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5763             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5764             (itype(i-3).eq.ntyp1)))) cycle
5765         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5766         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5767        cycle
5768        do j=1,nterm_sccor(isccori,isccori1)
5769           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5770           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5771           cosphi=dcos(j*tauangle(intertyp,i))
5772           sinphi=dsin(j*tauangle(intertyp,i))
5773           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5774           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5775           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5776         enddo
5777         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5778                                 'esccor',i,intertyp,esccor_ii
5779 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5780         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5781         if (lprn) &
5782         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5783         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5784         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5785         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5786         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5787        enddo !intertyp
5788       enddo
5789
5790       return
5791       end subroutine eback_sc_corr
5792 !-----------------------------------------------------------------------------
5793       subroutine multibody(ecorr)
5794 ! This subroutine calculates multi-body contributions to energy following
5795 ! the idea of Skolnick et al. If side chains I and J make a contact and
5796 ! at the same time side chains I+1 and J+1 make a contact, an extra
5797 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5798 !      implicit real*8 (a-h,o-z)
5799 !      include 'DIMENSIONS'
5800 !      include 'COMMON.IOUNITS'
5801 !      include 'COMMON.DERIV'
5802 !      include 'COMMON.INTERACT'
5803 !      include 'COMMON.CONTACTS'
5804       real(kind=8),dimension(3) :: gx,gx1
5805       logical :: lprn
5806       real(kind=8) :: ecorr
5807       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5808 ! Set lprn=.true. for debugging
5809       lprn=.false.
5810
5811       if (lprn) then
5812         write (iout,'(a)') 'Contact function values:'
5813         do i=nnt,nct-2
5814           write (iout,'(i2,20(1x,i2,f10.5))') &
5815               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5816         enddo
5817       endif
5818       ecorr=0.0D0
5819
5820 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5821 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5822       do i=nnt,nct
5823         do j=1,3
5824           gradcorr(j,i)=0.0D0
5825           gradxorr(j,i)=0.0D0
5826         enddo
5827       enddo
5828       do i=nnt,nct-2
5829
5830         DO ISHIFT = 3,4
5831
5832         i1=i+ishift
5833         num_conti=num_cont(i)
5834         num_conti1=num_cont(i1)
5835         do jj=1,num_conti
5836           j=jcont(jj,i)
5837           do kk=1,num_conti1
5838             j1=jcont(kk,i1)
5839             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5840 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5841 !d   &                   ' ishift=',ishift
5842 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5843 ! The system gains extra energy.
5844               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5845             endif   ! j1==j+-ishift
5846           enddo     ! kk
5847         enddo       ! jj
5848
5849         ENDDO ! ISHIFT
5850
5851       enddo         ! i
5852       return
5853       end subroutine multibody
5854 !-----------------------------------------------------------------------------
5855       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5856 !      implicit real*8 (a-h,o-z)
5857 !      include 'DIMENSIONS'
5858 !      include 'COMMON.IOUNITS'
5859 !      include 'COMMON.DERIV'
5860 !      include 'COMMON.INTERACT'
5861 !      include 'COMMON.CONTACTS'
5862       real(kind=8),dimension(3) :: gx,gx1
5863       logical :: lprn
5864       integer :: i,j,k,l,jj,kk,m,ll
5865       real(kind=8) :: eij,ekl
5866       lprn=.false.
5867       eij=facont(jj,i)
5868       ekl=facont(kk,k)
5869 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5870 ! Calculate the multi-body contribution to energy.
5871 ! Calculate multi-body contributions to the gradient.
5872 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5873 !d   & k,l,(gacont(m,kk,k),m=1,3)
5874       do m=1,3
5875         gx(m) =ekl*gacont(m,jj,i)
5876         gx1(m)=eij*gacont(m,kk,k)
5877         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5878         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5879         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5880         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5881       enddo
5882       do m=i,j-1
5883         do ll=1,3
5884           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5885         enddo
5886       enddo
5887       do m=k,l-1
5888         do ll=1,3
5889           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5890         enddo
5891       enddo
5892       esccorr=-eij*ekl
5893       return
5894       end function esccorr
5895 !-----------------------------------------------------------------------------
5896       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5897 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5898 !      implicit real*8 (a-h,o-z)
5899 !      include 'DIMENSIONS'
5900 !      include 'COMMON.IOUNITS'
5901 #ifdef MPI
5902       include "mpif.h"
5903 !      integer :: maxconts !max_cont=maxconts  =nres/4
5904       integer,parameter :: max_dim=26
5905       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5906       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5907 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5908 !el      common /przechowalnia/ zapas
5909       integer :: status(MPI_STATUS_SIZE)
5910       integer,dimension((nres/4)*2) :: req !maxconts*2
5911       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5912 #endif
5913 !      include 'COMMON.SETUP'
5914 !      include 'COMMON.FFIELD'
5915 !      include 'COMMON.DERIV'
5916 !      include 'COMMON.INTERACT'
5917 !      include 'COMMON.CONTACTS'
5918 !      include 'COMMON.CONTROL'
5919 !      include 'COMMON.LOCAL'
5920       real(kind=8),dimension(3) :: gx,gx1
5921       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5922       logical :: lprn,ldone
5923 !el local variables
5924       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5925               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5926
5927 ! Set lprn=.true. for debugging
5928       lprn=.false.
5929 #ifdef MPI
5930 !      maxconts=nres/4
5931       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
5932       n_corr=0
5933       n_corr1=0
5934       if (nfgtasks.le.1) goto 30
5935       if (lprn) then
5936         write (iout,'(a)') 'Contact function values before RECEIVE:'
5937         do i=nnt,nct-2
5938           write (iout,'(2i3,50(1x,i2,f5.2))') &
5939           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
5940           j=1,num_cont_hb(i))
5941         enddo
5942       endif
5943       call flush(iout)
5944       do i=1,ntask_cont_from
5945         ncont_recv(i)=0
5946       enddo
5947       do i=1,ntask_cont_to
5948         ncont_sent(i)=0
5949       enddo
5950 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5951 !     & ntask_cont_to
5952 ! Make the list of contacts to send to send to other procesors
5953 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5954 !      call flush(iout)
5955       do i=iturn3_start,iturn3_end
5956 !        write (iout,*) "make contact list turn3",i," num_cont",
5957 !     &    num_cont_hb(i)
5958         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5959       enddo
5960       do i=iturn4_start,iturn4_end
5961 !        write (iout,*) "make contact list turn4",i," num_cont",
5962 !     &   num_cont_hb(i)
5963         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5964       enddo
5965       do ii=1,nat_sent
5966         i=iat_sent(ii)
5967 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
5968 !     &    num_cont_hb(i)
5969         do j=1,num_cont_hb(i)
5970         do k=1,4
5971           jjc=jcont_hb(j,i)
5972           iproc=iint_sent_local(k,jjc,ii)
5973 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5974           if (iproc.gt.0) then
5975             ncont_sent(iproc)=ncont_sent(iproc)+1
5976             nn=ncont_sent(iproc)
5977             zapas(1,nn,iproc)=i
5978             zapas(2,nn,iproc)=jjc
5979             zapas(3,nn,iproc)=facont_hb(j,i)
5980             zapas(4,nn,iproc)=ees0p(j,i)
5981             zapas(5,nn,iproc)=ees0m(j,i)
5982             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5983             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5984             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5985             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5986             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5987             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5988             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5989             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5990             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5991             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5992             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5993             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5994             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5995             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5996             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5997             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5998             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5999             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6000             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6001             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6002             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6003           endif
6004         enddo
6005         enddo
6006       enddo
6007       if (lprn) then
6008       write (iout,*) &
6009         "Numbers of contacts to be sent to other processors",&
6010         (ncont_sent(i),i=1,ntask_cont_to)
6011       write (iout,*) "Contacts sent"
6012       do ii=1,ntask_cont_to
6013         nn=ncont_sent(ii)
6014         iproc=itask_cont_to(ii)
6015         write (iout,*) nn," contacts to processor",iproc,&
6016          " of CONT_TO_COMM group"
6017         do i=1,nn
6018           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6019         enddo
6020       enddo
6021       call flush(iout)
6022       endif
6023       CorrelType=477
6024       CorrelID=fg_rank+1
6025       CorrelType1=478
6026       CorrelID1=nfgtasks+fg_rank+1
6027       ireq=0
6028 ! Receive the numbers of needed contacts from other processors
6029       do ii=1,ntask_cont_from
6030         iproc=itask_cont_from(ii)
6031         ireq=ireq+1
6032         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6033           FG_COMM,req(ireq),IERR)
6034       enddo
6035 !      write (iout,*) "IRECV ended"
6036 !      call flush(iout)
6037 ! Send the number of contacts needed by other processors
6038       do ii=1,ntask_cont_to
6039         iproc=itask_cont_to(ii)
6040         ireq=ireq+1
6041         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6042           FG_COMM,req(ireq),IERR)
6043       enddo
6044 !      write (iout,*) "ISEND ended"
6045 !      write (iout,*) "number of requests (nn)",ireq
6046       call flush(iout)
6047       if (ireq.gt.0) &
6048         call MPI_Waitall(ireq,req,status_array,ierr)
6049 !      write (iout,*)
6050 !     &  "Numbers of contacts to be received from other processors",
6051 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6052 !      call flush(iout)
6053 ! Receive contacts
6054       ireq=0
6055       do ii=1,ntask_cont_from
6056         iproc=itask_cont_from(ii)
6057         nn=ncont_recv(ii)
6058 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6059 !     &   " of CONT_TO_COMM group"
6060         call flush(iout)
6061         if (nn.gt.0) then
6062           ireq=ireq+1
6063           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6064           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6065 !          write (iout,*) "ireq,req",ireq,req(ireq)
6066         endif
6067       enddo
6068 ! Send the contacts to processors that need them
6069       do ii=1,ntask_cont_to
6070         iproc=itask_cont_to(ii)
6071         nn=ncont_sent(ii)
6072 !        write (iout,*) nn," contacts to processor",iproc,
6073 !     &   " of CONT_TO_COMM group"
6074         if (nn.gt.0) then
6075           ireq=ireq+1
6076           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6077             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6078 !          write (iout,*) "ireq,req",ireq,req(ireq)
6079 !          do i=1,nn
6080 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6081 !          enddo
6082         endif
6083       enddo
6084 !      write (iout,*) "number of requests (contacts)",ireq
6085 !      write (iout,*) "req",(req(i),i=1,4)
6086 !      call flush(iout)
6087       if (ireq.gt.0) &
6088        call MPI_Waitall(ireq,req,status_array,ierr)
6089       do iii=1,ntask_cont_from
6090         iproc=itask_cont_from(iii)
6091         nn=ncont_recv(iii)
6092         if (lprn) then
6093         write (iout,*) "Received",nn," contacts from processor",iproc,&
6094          " of CONT_FROM_COMM group"
6095         call flush(iout)
6096         do i=1,nn
6097           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6098         enddo
6099         call flush(iout)
6100         endif
6101         do i=1,nn
6102           ii=zapas_recv(1,i,iii)
6103 ! Flag the received contacts to prevent double-counting
6104           jj=-zapas_recv(2,i,iii)
6105 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6106 !          call flush(iout)
6107           nnn=num_cont_hb(ii)+1
6108           num_cont_hb(ii)=nnn
6109           jcont_hb(nnn,ii)=jj
6110           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6111           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6112           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6113           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6114           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6115           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6116           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6117           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6118           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6119           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6120           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6121           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6122           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6123           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6124           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6125           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6126           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6127           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6128           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6129           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6130           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6131           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6132           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6133           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6134         enddo
6135       enddo
6136       call flush(iout)
6137       if (lprn) then
6138         write (iout,'(a)') 'Contact function values after receive:'
6139         do i=nnt,nct-2
6140           write (iout,'(2i3,50(1x,i3,f5.2))') &
6141           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6142           j=1,num_cont_hb(i))
6143         enddo
6144         call flush(iout)
6145       endif
6146    30 continue
6147 #endif
6148       if (lprn) then
6149         write (iout,'(a)') 'Contact function values:'
6150         do i=nnt,nct-2
6151           write (iout,'(2i3,50(1x,i3,f5.2))') &
6152           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6153           j=1,num_cont_hb(i))
6154         enddo
6155       endif
6156       ecorr=0.0D0
6157
6158 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6159 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6160 ! Remove the loop below after debugging !!!
6161       do i=nnt,nct
6162         do j=1,3
6163           gradcorr(j,i)=0.0D0
6164           gradxorr(j,i)=0.0D0
6165         enddo
6166       enddo
6167 ! Calculate the local-electrostatic correlation terms
6168       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6169         i1=i+1
6170         num_conti=num_cont_hb(i)
6171         num_conti1=num_cont_hb(i+1)
6172         do jj=1,num_conti
6173           j=jcont_hb(jj,i)
6174           jp=iabs(j)
6175           do kk=1,num_conti1
6176             j1=jcont_hb(kk,i1)
6177             jp1=iabs(j1)
6178 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6179 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6180             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6181                 .or. j.lt.0 .and. j1.gt.0) .and. &
6182                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6183 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6184 ! The system gains extra energy.
6185               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6186               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6187                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6188               n_corr=n_corr+1
6189             else if (j1.eq.j) then
6190 ! Contacts I-J and I-(J+1) occur simultaneously.
6191 ! The system loses extra energy.
6192 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6193             endif
6194           enddo ! kk
6195           do kk=1,num_conti
6196             j1=jcont_hb(kk,i)
6197 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6198 !    &         ' jj=',jj,' kk=',kk
6199             if (j1.eq.j+1) then
6200 ! Contacts I-J and (I+1)-J occur simultaneously.
6201 ! The system loses extra energy.
6202 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6203             endif ! j1==j+1
6204           enddo ! kk
6205         enddo ! jj
6206       enddo ! i
6207       return
6208       end subroutine multibody_hb
6209 !-----------------------------------------------------------------------------
6210       subroutine add_hb_contact(ii,jj,itask)
6211 !      implicit real*8 (a-h,o-z)
6212 !      include "DIMENSIONS"
6213 !      include "COMMON.IOUNITS"
6214 !      include "COMMON.CONTACTS"
6215 !      integer,parameter :: maxconts=nres/4
6216       integer,parameter :: max_dim=26
6217       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6218 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6219 !      common /przechowalnia/ zapas
6220       integer :: i,j,ii,jj,iproc,nn,jjc
6221       integer,dimension(4) :: itask
6222 !      write (iout,*) "itask",itask
6223       do i=1,2
6224         iproc=itask(i)
6225         if (iproc.gt.0) then
6226           do j=1,num_cont_hb(ii)
6227             jjc=jcont_hb(j,ii)
6228 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6229             if (jjc.eq.jj) then
6230               ncont_sent(iproc)=ncont_sent(iproc)+1
6231               nn=ncont_sent(iproc)
6232               zapas(1,nn,iproc)=ii
6233               zapas(2,nn,iproc)=jjc
6234               zapas(3,nn,iproc)=facont_hb(j,ii)
6235               zapas(4,nn,iproc)=ees0p(j,ii)
6236               zapas(5,nn,iproc)=ees0m(j,ii)
6237               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6238               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6239               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6240               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6241               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6242               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6243               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6244               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6245               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6246               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6247               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6248               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6249               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6250               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6251               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6252               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6253               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6254               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6255               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6256               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6257               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6258               exit
6259             endif
6260           enddo
6261         endif
6262       enddo
6263       return
6264       end subroutine add_hb_contact
6265 !-----------------------------------------------------------------------------
6266       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6267 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6268 !      implicit real*8 (a-h,o-z)
6269 !      include 'DIMENSIONS'
6270 !      include 'COMMON.IOUNITS'
6271       integer,parameter :: max_dim=70
6272 #ifdef MPI
6273       include "mpif.h"
6274 !      integer :: maxconts !max_cont=maxconts=nres/4
6275       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6276       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6277 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6278 !      common /przechowalnia/ zapas
6279       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6280         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6281         ierr,iii,nnn
6282 #endif
6283 !      include 'COMMON.SETUP'
6284 !      include 'COMMON.FFIELD'
6285 !      include 'COMMON.DERIV'
6286 !      include 'COMMON.LOCAL'
6287 !      include 'COMMON.INTERACT'
6288 !      include 'COMMON.CONTACTS'
6289 !      include 'COMMON.CHAIN'
6290 !      include 'COMMON.CONTROL'
6291       real(kind=8),dimension(3) :: gx,gx1
6292       integer,dimension(nres) :: num_cont_hb_old
6293       logical :: lprn,ldone
6294 !EL      double precision eello4,eello5,eelo6,eello_turn6
6295 !EL      external eello4,eello5,eello6,eello_turn6
6296 !el local variables
6297       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6298               j1,jp1,i1,num_conti1
6299       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6300       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6301
6302 ! Set lprn=.true. for debugging
6303       lprn=.false.
6304       eturn6=0.0d0
6305 #ifdef MPI
6306 !      maxconts=nres/4
6307       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6308       do i=1,nres
6309         num_cont_hb_old(i)=num_cont_hb(i)
6310       enddo
6311       n_corr=0
6312       n_corr1=0
6313       if (nfgtasks.le.1) goto 30
6314       if (lprn) then
6315         write (iout,'(a)') 'Contact function values before RECEIVE:'
6316         do i=nnt,nct-2
6317           write (iout,'(2i3,50(1x,i2,f5.2))') &
6318           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6319           j=1,num_cont_hb(i))
6320         enddo
6321       endif
6322       call flush(iout)
6323       do i=1,ntask_cont_from
6324         ncont_recv(i)=0
6325       enddo
6326       do i=1,ntask_cont_to
6327         ncont_sent(i)=0
6328       enddo
6329 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6330 !     & ntask_cont_to
6331 ! Make the list of contacts to send to send to other procesors
6332       do i=iturn3_start,iturn3_end
6333 !        write (iout,*) "make contact list turn3",i," num_cont",
6334 !     &    num_cont_hb(i)
6335         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6336       enddo
6337       do i=iturn4_start,iturn4_end
6338 !        write (iout,*) "make contact list turn4",i," num_cont",
6339 !     &   num_cont_hb(i)
6340         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6341       enddo
6342       do ii=1,nat_sent
6343         i=iat_sent(ii)
6344 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6345 !     &    num_cont_hb(i)
6346         do j=1,num_cont_hb(i)
6347         do k=1,4
6348           jjc=jcont_hb(j,i)
6349           iproc=iint_sent_local(k,jjc,ii)
6350 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6351           if (iproc.ne.0) then
6352             ncont_sent(iproc)=ncont_sent(iproc)+1
6353             nn=ncont_sent(iproc)
6354             zapas(1,nn,iproc)=i
6355             zapas(2,nn,iproc)=jjc
6356             zapas(3,nn,iproc)=d_cont(j,i)
6357             ind=3
6358             do kk=1,3
6359               ind=ind+1
6360               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6361             enddo
6362             do kk=1,2
6363               do ll=1,2
6364                 ind=ind+1
6365                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6366               enddo
6367             enddo
6368             do jj=1,5
6369               do kk=1,3
6370                 do ll=1,2
6371                   do mm=1,2
6372                     ind=ind+1
6373                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6374                   enddo
6375                 enddo
6376               enddo
6377             enddo
6378           endif
6379         enddo
6380         enddo
6381       enddo
6382       if (lprn) then
6383       write (iout,*) &
6384         "Numbers of contacts to be sent to other processors",&
6385         (ncont_sent(i),i=1,ntask_cont_to)
6386       write (iout,*) "Contacts sent"
6387       do ii=1,ntask_cont_to
6388         nn=ncont_sent(ii)
6389         iproc=itask_cont_to(ii)
6390         write (iout,*) nn," contacts to processor",iproc,&
6391          " of CONT_TO_COMM group"
6392         do i=1,nn
6393           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6394         enddo
6395       enddo
6396       call flush(iout)
6397       endif
6398       CorrelType=477
6399       CorrelID=fg_rank+1
6400       CorrelType1=478
6401       CorrelID1=nfgtasks+fg_rank+1
6402       ireq=0
6403 ! Receive the numbers of needed contacts from other processors
6404       do ii=1,ntask_cont_from
6405         iproc=itask_cont_from(ii)
6406         ireq=ireq+1
6407         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6408           FG_COMM,req(ireq),IERR)
6409       enddo
6410 !      write (iout,*) "IRECV ended"
6411 !      call flush(iout)
6412 ! Send the number of contacts needed by other processors
6413       do ii=1,ntask_cont_to
6414         iproc=itask_cont_to(ii)
6415         ireq=ireq+1
6416         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6417           FG_COMM,req(ireq),IERR)
6418       enddo
6419 !      write (iout,*) "ISEND ended"
6420 !      write (iout,*) "number of requests (nn)",ireq
6421       call flush(iout)
6422       if (ireq.gt.0) &
6423         call MPI_Waitall(ireq,req,status_array,ierr)
6424 !      write (iout,*)
6425 !     &  "Numbers of contacts to be received from other processors",
6426 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6427 !      call flush(iout)
6428 ! Receive contacts
6429       ireq=0
6430       do ii=1,ntask_cont_from
6431         iproc=itask_cont_from(ii)
6432         nn=ncont_recv(ii)
6433 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6434 !     &   " of CONT_TO_COMM group"
6435         call flush(iout)
6436         if (nn.gt.0) then
6437           ireq=ireq+1
6438           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6439           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6440 !          write (iout,*) "ireq,req",ireq,req(ireq)
6441         endif
6442       enddo
6443 ! Send the contacts to processors that need them
6444       do ii=1,ntask_cont_to
6445         iproc=itask_cont_to(ii)
6446         nn=ncont_sent(ii)
6447 !        write (iout,*) nn," contacts to processor",iproc,
6448 !     &   " of CONT_TO_COMM group"
6449         if (nn.gt.0) then
6450           ireq=ireq+1
6451           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6452             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6453 !          write (iout,*) "ireq,req",ireq,req(ireq)
6454 !          do i=1,nn
6455 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6456 !          enddo
6457         endif
6458       enddo
6459 !      write (iout,*) "number of requests (contacts)",ireq
6460 !      write (iout,*) "req",(req(i),i=1,4)
6461 !      call flush(iout)
6462       if (ireq.gt.0) &
6463        call MPI_Waitall(ireq,req,status_array,ierr)
6464       do iii=1,ntask_cont_from
6465         iproc=itask_cont_from(iii)
6466         nn=ncont_recv(iii)
6467         if (lprn) then
6468         write (iout,*) "Received",nn," contacts from processor",iproc,&
6469          " of CONT_FROM_COMM group"
6470         call flush(iout)
6471         do i=1,nn
6472           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6473         enddo
6474         call flush(iout)
6475         endif
6476         do i=1,nn
6477           ii=zapas_recv(1,i,iii)
6478 ! Flag the received contacts to prevent double-counting
6479           jj=-zapas_recv(2,i,iii)
6480 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6481 !          call flush(iout)
6482           nnn=num_cont_hb(ii)+1
6483           num_cont_hb(ii)=nnn
6484           jcont_hb(nnn,ii)=jj
6485           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6486           ind=3
6487           do kk=1,3
6488             ind=ind+1
6489             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6490           enddo
6491           do kk=1,2
6492             do ll=1,2
6493               ind=ind+1
6494               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6495             enddo
6496           enddo
6497           do jj=1,5
6498             do kk=1,3
6499               do ll=1,2
6500                 do mm=1,2
6501                   ind=ind+1
6502                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6503                 enddo
6504               enddo
6505             enddo
6506           enddo
6507         enddo
6508       enddo
6509       call flush(iout)
6510       if (lprn) then
6511         write (iout,'(a)') 'Contact function values after receive:'
6512         do i=nnt,nct-2
6513           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6514           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6515           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6516         enddo
6517         call flush(iout)
6518       endif
6519    30 continue
6520 #endif
6521       if (lprn) then
6522         write (iout,'(a)') 'Contact function values:'
6523         do i=nnt,nct-2
6524           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6525           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6526           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6527         enddo
6528       endif
6529       ecorr=0.0D0
6530       ecorr5=0.0d0
6531       ecorr6=0.0d0
6532
6533 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6534 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6535 ! Remove the loop below after debugging !!!
6536       do i=nnt,nct
6537         do j=1,3
6538           gradcorr(j,i)=0.0D0
6539           gradxorr(j,i)=0.0D0
6540         enddo
6541       enddo
6542 ! Calculate the dipole-dipole interaction energies
6543       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6544       do i=iatel_s,iatel_e+1
6545         num_conti=num_cont_hb(i)
6546         do jj=1,num_conti
6547           j=jcont_hb(jj,i)
6548 #ifdef MOMENT
6549           call dipole(i,j,jj)
6550 #endif
6551         enddo
6552       enddo
6553       endif
6554 ! Calculate the local-electrostatic correlation terms
6555 !                write (iout,*) "gradcorr5 in eello5 before loop"
6556 !                do iii=1,nres
6557 !                  write (iout,'(i5,3f10.5)')
6558 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6559 !                enddo
6560       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6561 !        write (iout,*) "corr loop i",i
6562         i1=i+1
6563         num_conti=num_cont_hb(i)
6564         num_conti1=num_cont_hb(i+1)
6565         do jj=1,num_conti
6566           j=jcont_hb(jj,i)
6567           jp=iabs(j)
6568           do kk=1,num_conti1
6569             j1=jcont_hb(kk,i1)
6570             jp1=iabs(j1)
6571 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6572 !     &         ' jj=',jj,' kk=',kk
6573 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6574             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6575                 .or. j.lt.0 .and. j1.gt.0) .and. &
6576                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6577 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6578 ! The system gains extra energy.
6579               n_corr=n_corr+1
6580               sqd1=dsqrt(d_cont(jj,i))
6581               sqd2=dsqrt(d_cont(kk,i1))
6582               sred_geom = sqd1*sqd2
6583               IF (sred_geom.lt.cutoff_corr) THEN
6584                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6585                   ekont,fprimcont)
6586 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6587 !d     &         ' jj=',jj,' kk=',kk
6588                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6589                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6590                 do l=1,3
6591                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6592                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6593                 enddo
6594                 n_corr1=n_corr1+1
6595 !d               write (iout,*) 'sred_geom=',sred_geom,
6596 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6597 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6598 !d               write (iout,*) "g_contij",g_contij
6599 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6600 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6601                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6602                 if (wcorr4.gt.0.0d0) &
6603                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6604                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6605                        write (iout,'(a6,4i5,0pf7.3)') &
6606                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6607 !                write (iout,*) "gradcorr5 before eello5"
6608 !                do iii=1,nres
6609 !                  write (iout,'(i5,3f10.5)')
6610 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6611 !                enddo
6612                 if (wcorr5.gt.0.0d0) &
6613                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6614 !                write (iout,*) "gradcorr5 after eello5"
6615 !                do iii=1,nres
6616 !                  write (iout,'(i5,3f10.5)')
6617 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6618 !                enddo
6619                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6620                        write (iout,'(a6,4i5,0pf7.3)') &
6621                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6622 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6623 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6624                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6625                      .or. wturn6.eq.0.0d0))then
6626 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6627                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6628                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6629                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6630 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6631 !d     &            'ecorr6=',ecorr6
6632 !d                write (iout,'(4e15.5)') sred_geom,
6633 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6634 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6635 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6636                 else if (wturn6.gt.0.0d0 &
6637                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6638 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6639                   eturn6=eturn6+eello_turn6(i,jj,kk)
6640                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6641                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6642 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6643                 endif
6644               ENDIF
6645 1111          continue
6646             endif
6647           enddo ! kk
6648         enddo ! jj
6649       enddo ! i
6650       do i=1,nres
6651         num_cont_hb(i)=num_cont_hb_old(i)
6652       enddo
6653 !                write (iout,*) "gradcorr5 in eello5"
6654 !                do iii=1,nres
6655 !                  write (iout,'(i5,3f10.5)')
6656 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6657 !                enddo
6658       return
6659       end subroutine multibody_eello
6660 !-----------------------------------------------------------------------------
6661       subroutine add_hb_contact_eello(ii,jj,itask)
6662 !      implicit real*8 (a-h,o-z)
6663 !      include "DIMENSIONS"
6664 !      include "COMMON.IOUNITS"
6665 !      include "COMMON.CONTACTS"
6666 !      integer,parameter :: maxconts=nres/4
6667       integer,parameter :: max_dim=70
6668       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6669 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6670 !      common /przechowalnia/ zapas
6671
6672       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6673       integer,dimension(4) ::itask
6674 !      write (iout,*) "itask",itask
6675       do i=1,2
6676         iproc=itask(i)
6677         if (iproc.gt.0) then
6678           do j=1,num_cont_hb(ii)
6679             jjc=jcont_hb(j,ii)
6680 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6681             if (jjc.eq.jj) then
6682               ncont_sent(iproc)=ncont_sent(iproc)+1
6683               nn=ncont_sent(iproc)
6684               zapas(1,nn,iproc)=ii
6685               zapas(2,nn,iproc)=jjc
6686               zapas(3,nn,iproc)=d_cont(j,ii)
6687               ind=3
6688               do kk=1,3
6689                 ind=ind+1
6690                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6691               enddo
6692               do kk=1,2
6693                 do ll=1,2
6694                   ind=ind+1
6695                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6696                 enddo
6697               enddo
6698               do jj=1,5
6699                 do kk=1,3
6700                   do ll=1,2
6701                     do mm=1,2
6702                       ind=ind+1
6703                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6704                     enddo
6705                   enddo
6706                 enddo
6707               enddo
6708               exit
6709             endif
6710           enddo
6711         endif
6712       enddo
6713       return
6714       end subroutine add_hb_contact_eello
6715 !-----------------------------------------------------------------------------
6716       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6717 !      implicit real*8 (a-h,o-z)
6718 !      include 'DIMENSIONS'
6719 !      include 'COMMON.IOUNITS'
6720 !      include 'COMMON.DERIV'
6721 !      include 'COMMON.INTERACT'
6722 !      include 'COMMON.CONTACTS'
6723       real(kind=8),dimension(3) :: gx,gx1
6724       logical :: lprn
6725 !el local variables
6726       integer :: i,j,k,l,jj,kk,ll
6727       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6728                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6729                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6730
6731       lprn=.false.
6732       eij=facont_hb(jj,i)
6733       ekl=facont_hb(kk,k)
6734       ees0pij=ees0p(jj,i)
6735       ees0pkl=ees0p(kk,k)
6736       ees0mij=ees0m(jj,i)
6737       ees0mkl=ees0m(kk,k)
6738       ekont=eij*ekl
6739       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6740 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6741 ! Following 4 lines for diagnostics.
6742 !d    ees0pkl=0.0D0
6743 !d    ees0pij=1.0D0
6744 !d    ees0mkl=0.0D0
6745 !d    ees0mij=1.0D0
6746 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6747 !     & 'Contacts ',i,j,
6748 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6749 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6750 !     & 'gradcorr_long'
6751 ! Calculate the multi-body contribution to energy.
6752 !      ecorr=ecorr+ekont*ees
6753 ! Calculate multi-body contributions to the gradient.
6754       coeffpees0pij=coeffp*ees0pij
6755       coeffmees0mij=coeffm*ees0mij
6756       coeffpees0pkl=coeffp*ees0pkl
6757       coeffmees0mkl=coeffm*ees0mkl
6758       do ll=1,3
6759 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6760         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6761         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6762         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6763         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6764         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6765         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6766 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6767         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6768         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6769         coeffmees0mij*gacontm_hb1(ll,kk,k))
6770         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6771         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6772         coeffmees0mij*gacontm_hb2(ll,kk,k))
6773         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6774            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6775            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6776         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6777         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6778         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6779            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6780            coeffmees0mij*gacontm_hb3(ll,kk,k))
6781         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6782         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6783 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6784       enddo
6785 !      write (iout,*)
6786 !grad      do m=i+1,j-1
6787 !grad        do ll=1,3
6788 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6789 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6790 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6791 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6792 !grad        enddo
6793 !grad      enddo
6794 !grad      do m=k+1,l-1
6795 !grad        do ll=1,3
6796 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6797 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6798 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6799 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6800 !grad        enddo
6801 !grad      enddo
6802 !      write (iout,*) "ehbcorr",ekont*ees
6803       ehbcorr=ekont*ees
6804       return
6805       end function ehbcorr
6806 #ifdef MOMENT
6807 !-----------------------------------------------------------------------------
6808       subroutine dipole(i,j,jj)
6809 !      implicit real*8 (a-h,o-z)
6810 !      include 'DIMENSIONS'
6811 !      include 'COMMON.IOUNITS'
6812 !      include 'COMMON.CHAIN'
6813 !      include 'COMMON.FFIELD'
6814 !      include 'COMMON.DERIV'
6815 !      include 'COMMON.INTERACT'
6816 !      include 'COMMON.CONTACTS'
6817 !      include 'COMMON.TORSION'
6818 !      include 'COMMON.VAR'
6819 !      include 'COMMON.GEO'
6820       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6821       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6822       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6823
6824       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6825       allocate(dipderx(3,5,4,maxconts,nres))
6826 !
6827
6828       iti1 = itortyp(itype(i+1))
6829       if (j.lt.nres-1) then
6830         itj1 = itortyp(itype(j+1))
6831       else
6832         itj1=ntortyp+1
6833       endif
6834       do iii=1,2
6835         dipi(iii,1)=Ub2(iii,i)
6836         dipderi(iii)=Ub2der(iii,i)
6837         dipi(iii,2)=b1(iii,iti1)
6838         dipj(iii,1)=Ub2(iii,j)
6839         dipderj(iii)=Ub2der(iii,j)
6840         dipj(iii,2)=b1(iii,itj1)
6841       enddo
6842       kkk=0
6843       do iii=1,2
6844         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6845         do jjj=1,2
6846           kkk=kkk+1
6847           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6848         enddo
6849       enddo
6850       do kkk=1,5
6851         do lll=1,3
6852           mmm=0
6853           do iii=1,2
6854             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6855               auxvec(1))
6856             do jjj=1,2
6857               mmm=mmm+1
6858               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6859             enddo
6860           enddo
6861         enddo
6862       enddo
6863       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6864       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6865       do iii=1,2
6866         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6867       enddo
6868       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6869       do iii=1,2
6870         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6871       enddo
6872       return
6873       end subroutine dipole
6874 #endif
6875 !-----------------------------------------------------------------------------
6876       subroutine calc_eello(i,j,k,l,jj,kk)
6877 !
6878 ! This subroutine computes matrices and vectors needed to calculate
6879 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6880 !
6881       use comm_kut
6882 !      implicit real*8 (a-h,o-z)
6883 !      include 'DIMENSIONS'
6884 !      include 'COMMON.IOUNITS'
6885 !      include 'COMMON.CHAIN'
6886 !      include 'COMMON.DERIV'
6887 !      include 'COMMON.INTERACT'
6888 !      include 'COMMON.CONTACTS'
6889 !      include 'COMMON.TORSION'
6890 !      include 'COMMON.VAR'
6891 !      include 'COMMON.GEO'
6892 !      include 'COMMON.FFIELD'
6893       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6894       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6895       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6896               itj1
6897 !el      logical :: lprn
6898 !el      common /kutas/ lprn
6899 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6900 !d     & ' jj=',jj,' kk=',kk
6901 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6902 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6903 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6904       do iii=1,2
6905         do jjj=1,2
6906           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6907           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6908         enddo
6909       enddo
6910       call transpose2(aa1(1,1),aa1t(1,1))
6911       call transpose2(aa2(1,1),aa2t(1,1))
6912       do kkk=1,5
6913         do lll=1,3
6914           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6915             aa1tder(1,1,lll,kkk))
6916           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6917             aa2tder(1,1,lll,kkk))
6918         enddo
6919       enddo
6920       if (l.eq.j+1) then
6921 ! parallel orientation of the two CA-CA-CA frames.
6922         if (i.gt.1) then
6923           iti=itortyp(itype(i))
6924         else
6925           iti=ntortyp+1
6926         endif
6927         itk1=itortyp(itype(k+1))
6928         itj=itortyp(itype(j))
6929         if (l.lt.nres-1) then
6930           itl1=itortyp(itype(l+1))
6931         else
6932           itl1=ntortyp+1
6933         endif
6934 ! A1 kernel(j+1) A2T
6935 !d        do iii=1,2
6936 !d          write (iout,'(3f10.5,5x,3f10.5)')
6937 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6938 !d        enddo
6939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6940          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
6941          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6942 ! Following matrices are needed only for 6-th order cumulants
6943         IF (wcorr6.gt.0.0d0) THEN
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6945          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
6946          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6948          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
6949          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
6950          ADtEAderx(1,1,1,1,1,1))
6951         lprn=.false.
6952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6953          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
6954          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
6955          ADtEA1derx(1,1,1,1,1,1))
6956         ENDIF
6957 ! End 6-th order cumulants
6958 !d        lprn=.false.
6959 !d        if (lprn) then
6960 !d        write (2,*) 'In calc_eello6'
6961 !d        do iii=1,2
6962 !d          write (2,*) 'iii=',iii
6963 !d          do kkk=1,5
6964 !d            write (2,*) 'kkk=',kkk
6965 !d            do jjj=1,2
6966 !d              write (2,'(3(2f10.5),5x)')
6967 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6968 !d            enddo
6969 !d          enddo
6970 !d        enddo
6971 !d        endif
6972         call transpose2(EUgder(1,1,k),auxmat(1,1))
6973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6974         call transpose2(EUg(1,1,k),auxmat(1,1))
6975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6976         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6977         do iii=1,2
6978           do kkk=1,5
6979             do lll=1,3
6980               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
6981                 EAEAderx(1,1,lll,kkk,iii,1))
6982             enddo
6983           enddo
6984         enddo
6985 ! A1T kernel(i+1) A2
6986         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6987          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
6988          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6989 ! Following matrices are needed only for 6-th order cumulants
6990         IF (wcorr6.gt.0.0d0) THEN
6991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6992          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
6993          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6994         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6995          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
6996          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
6997          ADtEAderx(1,1,1,1,1,2))
6998         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6999          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7000          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7001          ADtEA1derx(1,1,1,1,1,2))
7002         ENDIF
7003 ! End 6-th order cumulants
7004         call transpose2(EUgder(1,1,l),auxmat(1,1))
7005         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7006         call transpose2(EUg(1,1,l),auxmat(1,1))
7007         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7008         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7009         do iii=1,2
7010           do kkk=1,5
7011             do lll=1,3
7012               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7013                 EAEAderx(1,1,lll,kkk,iii,2))
7014             enddo
7015           enddo
7016         enddo
7017 ! AEAb1 and AEAb2
7018 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7019 ! They are needed only when the fifth- or the sixth-order cumulants are
7020 ! indluded.
7021         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7022         call transpose2(AEA(1,1,1),auxmat(1,1))
7023         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7024         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7025         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7026         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7027         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7028         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7029         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7030         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7031         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7032         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7033         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7034         call transpose2(AEA(1,1,2),auxmat(1,1))
7035         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7036         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7037         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7038         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7039         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7040         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7041         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7042         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7043         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7044         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7045         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7046 ! Calculate the Cartesian derivatives of the vectors.
7047         do iii=1,2
7048           do kkk=1,5
7049             do lll=1,3
7050               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7051               call matvec2(auxmat(1,1),b1(1,iti),&
7052                 AEAb1derx(1,lll,kkk,iii,1,1))
7053               call matvec2(auxmat(1,1),Ub2(1,i),&
7054                 AEAb2derx(1,lll,kkk,iii,1,1))
7055               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7056                 AEAb1derx(1,lll,kkk,iii,2,1))
7057               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7058                 AEAb2derx(1,lll,kkk,iii,2,1))
7059               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7060               call matvec2(auxmat(1,1),b1(1,itj),&
7061                 AEAb1derx(1,lll,kkk,iii,1,2))
7062               call matvec2(auxmat(1,1),Ub2(1,j),&
7063                 AEAb2derx(1,lll,kkk,iii,1,2))
7064               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7065                 AEAb1derx(1,lll,kkk,iii,2,2))
7066               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7067                 AEAb2derx(1,lll,kkk,iii,2,2))
7068             enddo
7069           enddo
7070         enddo
7071         ENDIF
7072 ! End vectors
7073       else
7074 ! Antiparallel orientation of the two CA-CA-CA frames.
7075         if (i.gt.1) then
7076           iti=itortyp(itype(i))
7077         else
7078           iti=ntortyp+1
7079         endif
7080         itk1=itortyp(itype(k+1))
7081         itl=itortyp(itype(l))
7082         itj=itortyp(itype(j))
7083         if (j.lt.nres-1) then
7084           itj1=itortyp(itype(j+1))
7085         else
7086           itj1=ntortyp+1
7087         endif
7088 ! A2 kernel(j-1)T A1T
7089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7090          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7091          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7092 ! Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7094            j.eq.i+4 .and. l.eq.i+3)) THEN
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7096          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7097          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7098         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7099          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7100          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7101          ADtEAderx(1,1,1,1,1,1))
7102         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7103          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7104          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7105          ADtEA1derx(1,1,1,1,1,1))
7106         ENDIF
7107 ! End 6-th order cumulants
7108         call transpose2(EUgder(1,1,k),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7110         call transpose2(EUg(1,1,k),auxmat(1,1))
7111         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7112         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7113         do iii=1,2
7114           do kkk=1,5
7115             do lll=1,3
7116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7117                 EAEAderx(1,1,lll,kkk,iii,1))
7118             enddo
7119           enddo
7120         enddo
7121 ! A2T kernel(i+1)T A1
7122         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7123          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7124          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7125 ! Following matrices are needed only for 6-th order cumulants
7126         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7127            j.eq.i+4 .and. l.eq.i+3)) THEN
7128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7129          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7130          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7132          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7133          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7134          ADtEAderx(1,1,1,1,1,2))
7135         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7136          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7137          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7138          ADtEA1derx(1,1,1,1,1,2))
7139         ENDIF
7140 ! End 6-th order cumulants
7141         call transpose2(EUgder(1,1,j),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7143         call transpose2(EUg(1,1,j),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7150                 EAEAderx(1,1,lll,kkk,iii,2))
7151             enddo
7152           enddo
7153         enddo
7154 ! AEAb1 and AEAb2
7155 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7156 ! They are needed only when the fifth- or the sixth-order cumulants are
7157 ! indluded.
7158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7159           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7160         call transpose2(AEA(1,1,1),auxmat(1,1))
7161         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7163         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7164         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7165         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7166         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7167         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7168         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7169         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7170         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7171         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7172         call transpose2(AEA(1,1,2),auxmat(1,1))
7173         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7174         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7175         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7176         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7177         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7178         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7179         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7180         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7181         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7182         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7183         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7184 ! Calculate the Cartesian derivatives of the vectors.
7185         do iii=1,2
7186           do kkk=1,5
7187             do lll=1,3
7188               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7189               call matvec2(auxmat(1,1),b1(1,iti),&
7190                 AEAb1derx(1,lll,kkk,iii,1,1))
7191               call matvec2(auxmat(1,1),Ub2(1,i),&
7192                 AEAb2derx(1,lll,kkk,iii,1,1))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7194                 AEAb1derx(1,lll,kkk,iii,2,1))
7195               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7196                 AEAb2derx(1,lll,kkk,iii,2,1))
7197               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7198               call matvec2(auxmat(1,1),b1(1,itl),&
7199                 AEAb1derx(1,lll,kkk,iii,1,2))
7200               call matvec2(auxmat(1,1),Ub2(1,l),&
7201                 AEAb2derx(1,lll,kkk,iii,1,2))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7203                 AEAb1derx(1,lll,kkk,iii,2,2))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7205                 AEAb2derx(1,lll,kkk,iii,2,2))
7206             enddo
7207           enddo
7208         enddo
7209         ENDIF
7210 ! End vectors
7211       endif
7212       return
7213       end subroutine calc_eello
7214 !-----------------------------------------------------------------------------
7215       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7216       use comm_kut
7217       implicit none
7218       integer :: nderg
7219       logical :: transp
7220       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7221       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7222       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7223       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7224       integer :: iii,kkk,lll
7225       integer :: jjj,mmm
7226 !el      logical :: lprn
7227 !el      common /kutas/ lprn
7228       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7229       do iii=1,nderg
7230         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7231           AKAderg(1,1,iii))
7232       enddo
7233 !d      if (lprn) write (2,*) 'In kernel'
7234       do kkk=1,5
7235 !d        if (lprn) write (2,*) 'kkk=',kkk
7236         do lll=1,3
7237           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7238             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7239 !d          if (lprn) then
7240 !d            write (2,*) 'lll=',lll
7241 !d            write (2,*) 'iii=1'
7242 !d            do jjj=1,2
7243 !d              write (2,'(3(2f10.5),5x)')
7244 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7245 !d            enddo
7246 !d          endif
7247           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7248             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7249 !d          if (lprn) then
7250 !d            write (2,*) 'lll=',lll
7251 !d            write (2,*) 'iii=2'
7252 !d            do jjj=1,2
7253 !d              write (2,'(3(2f10.5),5x)')
7254 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7255 !d            enddo
7256 !d          endif
7257         enddo
7258       enddo
7259       return
7260       end subroutine kernel
7261 !-----------------------------------------------------------------------------
7262       real(kind=8) function eello4(i,j,k,l,jj,kk)
7263 !      implicit real*8 (a-h,o-z)
7264 !      include 'DIMENSIONS'
7265 !      include 'COMMON.IOUNITS'
7266 !      include 'COMMON.CHAIN'
7267 !      include 'COMMON.DERIV'
7268 !      include 'COMMON.INTERACT'
7269 !      include 'COMMON.CONTACTS'
7270 !      include 'COMMON.TORSION'
7271 !      include 'COMMON.VAR'
7272 !      include 'COMMON.GEO'
7273       real(kind=8),dimension(2,2) :: pizda
7274       real(kind=8),dimension(3) :: ggg1,ggg2
7275       real(kind=8) ::  eel4,glongij,glongkl
7276       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7277 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7278 !d        eello4=0.0d0
7279 !d        return
7280 !d      endif
7281 !d      print *,'eello4:',i,j,k,l,jj,kk
7282 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7283 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7284 !old      eij=facont_hb(jj,i)
7285 !old      ekl=facont_hb(kk,k)
7286 !old      ekont=eij*ekl
7287       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7288 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7289       gcorr_loc(k-1)=gcorr_loc(k-1) &
7290          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7291       if (l.eq.j+1) then
7292         gcorr_loc(l-1)=gcorr_loc(l-1) &
7293            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7294       else
7295         gcorr_loc(j-1)=gcorr_loc(j-1) &
7296            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7297       endif
7298       do iii=1,2
7299         do kkk=1,5
7300           do lll=1,3
7301             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7302                               -EAEAderx(2,2,lll,kkk,iii,1)
7303 !d            derx(lll,kkk,iii)=0.0d0
7304           enddo
7305         enddo
7306       enddo
7307 !d      gcorr_loc(l-1)=0.0d0
7308 !d      gcorr_loc(j-1)=0.0d0
7309 !d      gcorr_loc(k-1)=0.0d0
7310 !d      eel4=1.0d0
7311 !d      write (iout,*)'Contacts have occurred for peptide groups',
7312 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7313 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7314       if (j.lt.nres-1) then
7315         j1=j+1
7316         j2=j-1
7317       else
7318         j1=j-1
7319         j2=j-2
7320       endif
7321       if (l.lt.nres-1) then
7322         l1=l+1
7323         l2=l-1
7324       else
7325         l1=l-1
7326         l2=l-2
7327       endif
7328       do ll=1,3
7329 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7330 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7331         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7332         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7333 !grad        ghalf=0.5d0*ggg1(ll)
7334         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7335         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7336         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7337         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7338         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7339         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7340 !grad        ghalf=0.5d0*ggg2(ll)
7341         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7342         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7343         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7344         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7345         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7346         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7347       enddo
7348 !grad      do m=i+1,j-1
7349 !grad        do ll=1,3
7350 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7351 !grad        enddo
7352 !grad      enddo
7353 !grad      do m=k+1,l-1
7354 !grad        do ll=1,3
7355 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7356 !grad        enddo
7357 !grad      enddo
7358 !grad      do m=i+2,j2
7359 !grad        do ll=1,3
7360 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7361 !grad        enddo
7362 !grad      enddo
7363 !grad      do m=k+2,l2
7364 !grad        do ll=1,3
7365 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7366 !grad        enddo
7367 !grad      enddo
7368 !d      do iii=1,nres-3
7369 !d        write (2,*) iii,gcorr_loc(iii)
7370 !d      enddo
7371       eello4=ekont*eel4
7372 !d      write (2,*) 'ekont',ekont
7373 !d      write (iout,*) 'eello4',ekont*eel4
7374       return
7375       end function eello4
7376 !-----------------------------------------------------------------------------
7377       real(kind=8) function eello5(i,j,k,l,jj,kk)
7378 !      implicit real*8 (a-h,o-z)
7379 !      include 'DIMENSIONS'
7380 !      include 'COMMON.IOUNITS'
7381 !      include 'COMMON.CHAIN'
7382 !      include 'COMMON.DERIV'
7383 !      include 'COMMON.INTERACT'
7384 !      include 'COMMON.CONTACTS'
7385 !      include 'COMMON.TORSION'
7386 !      include 'COMMON.VAR'
7387 !      include 'COMMON.GEO'
7388       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7389       real(kind=8),dimension(2) :: vv
7390       real(kind=8),dimension(3) :: ggg1,ggg2
7391       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7392       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7393       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7394 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7395 !                                                                              C
7396 !                            Parallel chains                                   C
7397 !                                                                              C
7398 !          o             o                   o             o                   C
7399 !         /l\           / \             \   / \           / \   /              C
7400 !        /   \         /   \             \ /   \         /   \ /               C
7401 !       j| o |l1       | o |              o| o |         | o |o                C
7402 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7403 !      \i/   \         /   \ /             /   \         /   \                 C
7404 !       o    k1             o                                                  C
7405 !         (I)          (II)                (III)          (IV)                 C
7406 !                                                                              C
7407 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7408 !                                                                              C
7409 !                            Antiparallel chains                               C
7410 !                                                                              C
7411 !          o             o                   o             o                   C
7412 !         /j\           / \             \   / \           / \   /              C
7413 !        /   \         /   \             \ /   \         /   \ /               C
7414 !      j1| o |l        | o |              o| o |         | o |o                C
7415 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7416 !      \i/   \         /   \ /             /   \         /   \                 C
7417 !       o     k1            o                                                  C
7418 !         (I)          (II)                (III)          (IV)                 C
7419 !                                                                              C
7420 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7421 !                                                                              C
7422 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7423 !                                                                              C
7424 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7425 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7426 !d        eello5=0.0d0
7427 !d        return
7428 !d      endif
7429 !d      write (iout,*)
7430 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7431 !d     &   ' and',k,l
7432       itk=itortyp(itype(k))
7433       itl=itortyp(itype(l))
7434       itj=itortyp(itype(j))
7435       eello5_1=0.0d0
7436       eello5_2=0.0d0
7437       eello5_3=0.0d0
7438       eello5_4=0.0d0
7439 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7440 !d     &   eel5_3_num,eel5_4_num)
7441       do iii=1,2
7442         do kkk=1,5
7443           do lll=1,3
7444             derx(lll,kkk,iii)=0.0d0
7445           enddo
7446         enddo
7447       enddo
7448 !d      eij=facont_hb(jj,i)
7449 !d      ekl=facont_hb(kk,k)
7450 !d      ekont=eij*ekl
7451 !d      write (iout,*)'Contacts have occurred for peptide groups',
7452 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7453 !d      goto 1111
7454 ! Contribution from the graph I.
7455 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7456 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7457       call transpose2(EUg(1,1,k),auxmat(1,1))
7458       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7459       vv(1)=pizda(1,1)-pizda(2,2)
7460       vv(2)=pizda(1,2)+pizda(2,1)
7461       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7462        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7463 ! Explicit gradient in virtual-dihedral angles.
7464       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7465        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7466        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7467       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7468       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7469       vv(1)=pizda(1,1)-pizda(2,2)
7470       vv(2)=pizda(1,2)+pizda(2,1)
7471       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7472        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7473        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7474       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7475       vv(1)=pizda(1,1)-pizda(2,2)
7476       vv(2)=pizda(1,2)+pizda(2,1)
7477       if (l.eq.j+1) then
7478         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7479          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7480          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7481       else
7482         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7483          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7484          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7485       endif
7486 ! Cartesian gradient
7487       do iii=1,2
7488         do kkk=1,5
7489           do lll=1,3
7490             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7491               pizda(1,1))
7492             vv(1)=pizda(1,1)-pizda(2,2)
7493             vv(2)=pizda(1,2)+pizda(2,1)
7494             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7495              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7496              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7497           enddo
7498         enddo
7499       enddo
7500 !      goto 1112
7501 !1111  continue
7502 ! Contribution from graph II
7503       call transpose2(EE(1,1,itk),auxmat(1,1))
7504       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7505       vv(1)=pizda(1,1)+pizda(2,2)
7506       vv(2)=pizda(2,1)-pizda(1,2)
7507       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7508        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7509 ! Explicit gradient in virtual-dihedral angles.
7510       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7511        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7512       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7513       vv(1)=pizda(1,1)+pizda(2,2)
7514       vv(2)=pizda(2,1)-pizda(1,2)
7515       if (l.eq.j+1) then
7516         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7517          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7518          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7519       else
7520         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7521          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7522          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7523       endif
7524 ! Cartesian gradient
7525       do iii=1,2
7526         do kkk=1,5
7527           do lll=1,3
7528             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7529               pizda(1,1))
7530             vv(1)=pizda(1,1)+pizda(2,2)
7531             vv(2)=pizda(2,1)-pizda(1,2)
7532             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7533              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7534              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7535           enddo
7536         enddo
7537       enddo
7538 !d      goto 1112
7539 !d1111  continue
7540       if (l.eq.j+1) then
7541 !d        goto 1110
7542 ! Parallel orientation
7543 ! Contribution from graph III
7544         call transpose2(EUg(1,1,l),auxmat(1,1))
7545         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7546         vv(1)=pizda(1,1)-pizda(2,2)
7547         vv(2)=pizda(1,2)+pizda(2,1)
7548         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7549          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7550 ! Explicit gradient in virtual-dihedral angles.
7551         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7552          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7553          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7554         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7555         vv(1)=pizda(1,1)-pizda(2,2)
7556         vv(2)=pizda(1,2)+pizda(2,1)
7557         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7558          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7559          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7560         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7561         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7562         vv(1)=pizda(1,1)-pizda(2,2)
7563         vv(2)=pizda(1,2)+pizda(2,1)
7564         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7565          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7566          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7567 ! Cartesian gradient
7568         do iii=1,2
7569           do kkk=1,5
7570             do lll=1,3
7571               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7572                 pizda(1,1))
7573               vv(1)=pizda(1,1)-pizda(2,2)
7574               vv(2)=pizda(1,2)+pizda(2,1)
7575               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7576                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7577                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7578             enddo
7579           enddo
7580         enddo
7581 !d        goto 1112
7582 ! Contribution from graph IV
7583 !d1110    continue
7584         call transpose2(EE(1,1,itl),auxmat(1,1))
7585         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7586         vv(1)=pizda(1,1)+pizda(2,2)
7587         vv(2)=pizda(2,1)-pizda(1,2)
7588         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7589          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7590 ! Explicit gradient in virtual-dihedral angles.
7591         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7592          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7593         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7594         vv(1)=pizda(1,1)+pizda(2,2)
7595         vv(2)=pizda(2,1)-pizda(1,2)
7596         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7597          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7598          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7599 ! Cartesian gradient
7600         do iii=1,2
7601           do kkk=1,5
7602             do lll=1,3
7603               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7604                 pizda(1,1))
7605               vv(1)=pizda(1,1)+pizda(2,2)
7606               vv(2)=pizda(2,1)-pizda(1,2)
7607               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7608                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7609                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7610             enddo
7611           enddo
7612         enddo
7613       else
7614 ! Antiparallel orientation
7615 ! Contribution from graph III
7616 !        goto 1110
7617         call transpose2(EUg(1,1,j),auxmat(1,1))
7618         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7619         vv(1)=pizda(1,1)-pizda(2,2)
7620         vv(2)=pizda(1,2)+pizda(2,1)
7621         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7622          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7623 ! Explicit gradient in virtual-dihedral angles.
7624         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7625          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7626          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7627         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7628         vv(1)=pizda(1,1)-pizda(2,2)
7629         vv(2)=pizda(1,2)+pizda(2,1)
7630         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7631          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7632          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7633         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7634         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7635         vv(1)=pizda(1,1)-pizda(2,2)
7636         vv(2)=pizda(1,2)+pizda(2,1)
7637         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7638          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7639          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7640 ! Cartesian gradient
7641         do iii=1,2
7642           do kkk=1,5
7643             do lll=1,3
7644               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7645                 pizda(1,1))
7646               vv(1)=pizda(1,1)-pizda(2,2)
7647               vv(2)=pizda(1,2)+pizda(2,1)
7648               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7649                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7650                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7651             enddo
7652           enddo
7653         enddo
7654 !d        goto 1112
7655 ! Contribution from graph IV
7656 1110    continue
7657         call transpose2(EE(1,1,itj),auxmat(1,1))
7658         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7659         vv(1)=pizda(1,1)+pizda(2,2)
7660         vv(2)=pizda(2,1)-pizda(1,2)
7661         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7662          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7663 ! Explicit gradient in virtual-dihedral angles.
7664         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7665          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7666         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7667         vv(1)=pizda(1,1)+pizda(2,2)
7668         vv(2)=pizda(2,1)-pizda(1,2)
7669         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7670          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7671          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7672 ! Cartesian gradient
7673         do iii=1,2
7674           do kkk=1,5
7675             do lll=1,3
7676               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7677                 pizda(1,1))
7678               vv(1)=pizda(1,1)+pizda(2,2)
7679               vv(2)=pizda(2,1)-pizda(1,2)
7680               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7681                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7682                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7683             enddo
7684           enddo
7685         enddo
7686       endif
7687 1112  continue
7688       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7689 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7690 !d        write (2,*) 'ijkl',i,j,k,l
7691 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7692 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7693 !d      endif
7694 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7695 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7696 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7697 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7698       if (j.lt.nres-1) then
7699         j1=j+1
7700         j2=j-1
7701       else
7702         j1=j-1
7703         j2=j-2
7704       endif
7705       if (l.lt.nres-1) then
7706         l1=l+1
7707         l2=l-1
7708       else
7709         l1=l-1
7710         l2=l-2
7711       endif
7712 !d      eij=1.0d0
7713 !d      ekl=1.0d0
7714 !d      ekont=1.0d0
7715 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7716 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7717 !        summed up outside the subrouine as for the other subroutines
7718 !        handling long-range interactions. The old code is commented out
7719 !        with "cgrad" to keep track of changes.
7720       do ll=1,3
7721 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7722 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7723         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7724         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7725 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7726 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7727 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7728 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7729 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7730 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7731 !     &   gradcorr5ij,
7732 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7733 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7734 !grad        ghalf=0.5d0*ggg1(ll)
7735 !d        ghalf=0.0d0
7736         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7737         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7738         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7739         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7740         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7741         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7742 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7743 !grad        ghalf=0.5d0*ggg2(ll)
7744         ghalf=0.0d0
7745         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7746         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7747         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7748         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7749         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7750         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7751       enddo
7752 !d      goto 1112
7753 !grad      do m=i+1,j-1
7754 !grad        do ll=1,3
7755 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7756 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7757 !grad        enddo
7758 !grad      enddo
7759 !grad      do m=k+1,l-1
7760 !grad        do ll=1,3
7761 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7762 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7763 !grad        enddo
7764 !grad      enddo
7765 !1112  continue
7766 !grad      do m=i+2,j2
7767 !grad        do ll=1,3
7768 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7769 !grad        enddo
7770 !grad      enddo
7771 !grad      do m=k+2,l2
7772 !grad        do ll=1,3
7773 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7774 !grad        enddo
7775 !grad      enddo
7776 !d      do iii=1,nres-3
7777 !d        write (2,*) iii,g_corr5_loc(iii)
7778 !d      enddo
7779       eello5=ekont*eel5
7780 !d      write (2,*) 'ekont',ekont
7781 !d      write (iout,*) 'eello5',ekont*eel5
7782       return
7783       end function eello5
7784 !-----------------------------------------------------------------------------
7785       real(kind=8) function eello6(i,j,k,l,jj,kk)
7786 !      implicit real*8 (a-h,o-z)
7787 !      include 'DIMENSIONS'
7788 !      include 'COMMON.IOUNITS'
7789 !      include 'COMMON.CHAIN'
7790 !      include 'COMMON.DERIV'
7791 !      include 'COMMON.INTERACT'
7792 !      include 'COMMON.CONTACTS'
7793 !      include 'COMMON.TORSION'
7794 !      include 'COMMON.VAR'
7795 !      include 'COMMON.GEO'
7796 !      include 'COMMON.FFIELD'
7797       real(kind=8),dimension(3) :: ggg1,ggg2
7798       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7799                    eello6_6,eel6
7800       real(kind=8) :: gradcorr6ij,gradcorr6kl
7801       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7802 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7803 !d        eello6=0.0d0
7804 !d        return
7805 !d      endif
7806 !d      write (iout,*)
7807 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7808 !d     &   ' and',k,l
7809       eello6_1=0.0d0
7810       eello6_2=0.0d0
7811       eello6_3=0.0d0
7812       eello6_4=0.0d0
7813       eello6_5=0.0d0
7814       eello6_6=0.0d0
7815 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7816 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7817       do iii=1,2
7818         do kkk=1,5
7819           do lll=1,3
7820             derx(lll,kkk,iii)=0.0d0
7821           enddo
7822         enddo
7823       enddo
7824 !d      eij=facont_hb(jj,i)
7825 !d      ekl=facont_hb(kk,k)
7826 !d      ekont=eij*ekl
7827 !d      eij=1.0d0
7828 !d      ekl=1.0d0
7829 !d      ekont=1.0d0
7830       if (l.eq.j+1) then
7831         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7832         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7833         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7834         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7835         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7836         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7837       else
7838         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7839         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7840         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7841         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7842         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7843           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7844         else
7845           eello6_5=0.0d0
7846         endif
7847         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7848       endif
7849 ! If turn contributions are considered, they will be handled separately.
7850       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7851 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7852 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7853 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7854 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7855 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7856 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7857 !d      goto 1112
7858       if (j.lt.nres-1) then
7859         j1=j+1
7860         j2=j-1
7861       else
7862         j1=j-1
7863         j2=j-2
7864       endif
7865       if (l.lt.nres-1) then
7866         l1=l+1
7867         l2=l-1
7868       else
7869         l1=l-1
7870         l2=l-2
7871       endif
7872       do ll=1,3
7873 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7874 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7875 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7876 !grad        ghalf=0.5d0*ggg1(ll)
7877 !d        ghalf=0.0d0
7878         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7879         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7880         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7881         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7882         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7883         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7884         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7885         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7886 !grad        ghalf=0.5d0*ggg2(ll)
7887 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7888 !d        ghalf=0.0d0
7889         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7890         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7891         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7892         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7893         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7894         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7895       enddo
7896 !d      goto 1112
7897 !grad      do m=i+1,j-1
7898 !grad        do ll=1,3
7899 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7900 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7901 !grad        enddo
7902 !grad      enddo
7903 !grad      do m=k+1,l-1
7904 !grad        do ll=1,3
7905 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7906 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7907 !grad        enddo
7908 !grad      enddo
7909 !grad1112  continue
7910 !grad      do m=i+2,j2
7911 !grad        do ll=1,3
7912 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7913 !grad        enddo
7914 !grad      enddo
7915 !grad      do m=k+2,l2
7916 !grad        do ll=1,3
7917 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7918 !grad        enddo
7919 !grad      enddo
7920 !d      do iii=1,nres-3
7921 !d        write (2,*) iii,g_corr6_loc(iii)
7922 !d      enddo
7923       eello6=ekont*eel6
7924 !d      write (2,*) 'ekont',ekont
7925 !d      write (iout,*) 'eello6',ekont*eel6
7926       return
7927       end function eello6
7928 !-----------------------------------------------------------------------------
7929       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7930       use comm_kut
7931 !      implicit real*8 (a-h,o-z)
7932 !      include 'DIMENSIONS'
7933 !      include 'COMMON.IOUNITS'
7934 !      include 'COMMON.CHAIN'
7935 !      include 'COMMON.DERIV'
7936 !      include 'COMMON.INTERACT'
7937 !      include 'COMMON.CONTACTS'
7938 !      include 'COMMON.TORSION'
7939 !      include 'COMMON.VAR'
7940 !      include 'COMMON.GEO'
7941       real(kind=8),dimension(2) :: vv,vv1
7942       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
7943       logical :: swap
7944 !el      logical :: lprn
7945 !el      common /kutas/ lprn
7946       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
7947       real(kind=8) :: s1,s2,s3,s4,s5
7948 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7949 !                                                                              C
7950 !      Parallel       Antiparallel                                             C
7951 !                                                                              C
7952 !          o             o                                                     C
7953 !         /l\           /j\                                                    C
7954 !        /   \         /   \                                                   C
7955 !       /| o |         | o |\                                                  C
7956 !     \ j|/k\|  /   \  |/k\|l /                                                C
7957 !      \ /   \ /     \ /   \ /                                                 C
7958 !       o     o       o     o                                                  C
7959 !       i             i                                                        C
7960 !                                                                              C
7961 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7962       itk=itortyp(itype(k))
7963       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7964       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7965       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7966       call transpose2(EUgC(1,1,k),auxmat(1,1))
7967       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7968       vv1(1)=pizda1(1,1)-pizda1(2,2)
7969       vv1(2)=pizda1(1,2)+pizda1(2,1)
7970       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7971       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7972       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7973       s5=scalar2(vv(1),Dtobr2(1,i))
7974 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7975       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7976       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
7977        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
7978        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
7979        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
7980        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
7981        +scalar2(vv(1),Dtobr2der(1,i)))
7982       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7983       vv1(1)=pizda1(1,1)-pizda1(2,2)
7984       vv1(2)=pizda1(1,2)+pizda1(2,1)
7985       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7986       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7987       if (l.eq.j+1) then
7988         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
7989        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7990        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7991        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7992        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7993       else
7994         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
7995        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7996        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7997        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7998        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7999       endif
8000       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8001       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8002       vv1(1)=pizda1(1,1)-pizda1(2,2)
8003       vv1(2)=pizda1(1,2)+pizda1(2,1)
8004       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8005        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8006        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8007        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8008       do iii=1,2
8009         if (swap) then
8010           ind=3-iii
8011         else
8012           ind=iii
8013         endif
8014         do kkk=1,5
8015           do lll=1,3
8016             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8017             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8018             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8019             call transpose2(EUgC(1,1,k),auxmat(1,1))
8020             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8021               pizda1(1,1))
8022             vv1(1)=pizda1(1,1)-pizda1(2,2)
8023             vv1(2)=pizda1(1,2)+pizda1(2,1)
8024             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8025             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8026              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8027             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8028              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8029             s5=scalar2(vv(1),Dtobr2(1,i))
8030             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8031           enddo
8032         enddo
8033       enddo
8034       return
8035       end function eello6_graph1
8036 !-----------------------------------------------------------------------------
8037       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8038       use comm_kut
8039 !      implicit real*8 (a-h,o-z)
8040 !      include 'DIMENSIONS'
8041 !      include 'COMMON.IOUNITS'
8042 !      include 'COMMON.CHAIN'
8043 !      include 'COMMON.DERIV'
8044 !      include 'COMMON.INTERACT'
8045 !      include 'COMMON.CONTACTS'
8046 !      include 'COMMON.TORSION'
8047 !      include 'COMMON.VAR'
8048 !      include 'COMMON.GEO'
8049       logical :: swap
8050       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8051       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8052 !el      logical :: lprn
8053 !el      common /kutas/ lprn
8054       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8055       real(kind=8) :: s2,s3,s4
8056 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8057 !                                                                              C
8058 !      Parallel       Antiparallel                                             C
8059 !                                                                              C
8060 !          o             o                                                     C
8061 !     \   /l\           /j\   /                                                C
8062 !      \ /   \         /   \ /                                                 C
8063 !       o| o |         | o |o                                                  C
8064 !     \ j|/k\|      \  |/k\|l                                                  C
8065 !      \ /   \       \ /   \                                                   C
8066 !       o             o                                                        C
8067 !       i             i                                                        C
8068 !                                                                              C
8069 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8070 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8071 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8072 !           but not in a cluster cumulant
8073 #ifdef MOMENT
8074       s1=dip(1,jj,i)*dip(1,kk,k)
8075 #endif
8076       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8077       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8078       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8079       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8080       call transpose2(EUg(1,1,k),auxmat(1,1))
8081       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8082       vv(1)=pizda(1,1)-pizda(2,2)
8083       vv(2)=pizda(1,2)+pizda(2,1)
8084       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8085 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8086 #ifdef MOMENT
8087       eello6_graph2=-(s1+s2+s3+s4)
8088 #else
8089       eello6_graph2=-(s2+s3+s4)
8090 #endif
8091 !      eello6_graph2=-s3
8092 ! Derivatives in gamma(i-1)
8093       if (i.gt.1) then
8094 #ifdef MOMENT
8095         s1=dipderg(1,jj,i)*dip(1,kk,k)
8096 #endif
8097         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8098         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8099         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8100         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8101 #ifdef MOMENT
8102         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8103 #else
8104         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8105 #endif
8106 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8107       endif
8108 ! Derivatives in gamma(k-1)
8109 #ifdef MOMENT
8110       s1=dip(1,jj,i)*dipderg(1,kk,k)
8111 #endif
8112       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8113       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8114       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8115       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8116       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8117       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8118       vv(1)=pizda(1,1)-pizda(2,2)
8119       vv(2)=pizda(1,2)+pizda(2,1)
8120       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8121 #ifdef MOMENT
8122       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8123 #else
8124       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8125 #endif
8126 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8127 ! Derivatives in gamma(j-1) or gamma(l-1)
8128       if (j.gt.1) then
8129 #ifdef MOMENT
8130         s1=dipderg(3,jj,i)*dip(1,kk,k)
8131 #endif
8132         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8133         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8134         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8135         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8136         vv(1)=pizda(1,1)-pizda(2,2)
8137         vv(2)=pizda(1,2)+pizda(2,1)
8138         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8139 #ifdef MOMENT
8140         if (swap) then
8141           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8142         else
8143           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8144         endif
8145 #endif
8146         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8147 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8148       endif
8149 ! Derivatives in gamma(l-1) or gamma(j-1)
8150       if (l.gt.1) then
8151 #ifdef MOMENT
8152         s1=dip(1,jj,i)*dipderg(3,kk,k)
8153 #endif
8154         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8155         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8156         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8157         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8158         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8159         vv(1)=pizda(1,1)-pizda(2,2)
8160         vv(2)=pizda(1,2)+pizda(2,1)
8161         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8162 #ifdef MOMENT
8163         if (swap) then
8164           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8165         else
8166           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8167         endif
8168 #endif
8169         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8170 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8171       endif
8172 ! Cartesian derivatives.
8173       if (lprn) then
8174         write (2,*) 'In eello6_graph2'
8175         do iii=1,2
8176           write (2,*) 'iii=',iii
8177           do kkk=1,5
8178             write (2,*) 'kkk=',kkk
8179             do jjj=1,2
8180               write (2,'(3(2f10.5),5x)') &
8181               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8182             enddo
8183           enddo
8184         enddo
8185       endif
8186       do iii=1,2
8187         do kkk=1,5
8188           do lll=1,3
8189 #ifdef MOMENT
8190             if (iii.eq.1) then
8191               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8192             else
8193               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8194             endif
8195 #endif
8196             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8197               auxvec(1))
8198             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8199             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8200               auxvec(1))
8201             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8202             call transpose2(EUg(1,1,k),auxmat(1,1))
8203             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8204               pizda(1,1))
8205             vv(1)=pizda(1,1)-pizda(2,2)
8206             vv(2)=pizda(1,2)+pizda(2,1)
8207             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8208 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8209 #ifdef MOMENT
8210             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8211 #else
8212             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8213 #endif
8214             if (swap) then
8215               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8216             else
8217               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8218             endif
8219           enddo
8220         enddo
8221       enddo
8222       return
8223       end function eello6_graph2
8224 !-----------------------------------------------------------------------------
8225       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8226 !      implicit real*8 (a-h,o-z)
8227 !      include 'DIMENSIONS'
8228 !      include 'COMMON.IOUNITS'
8229 !      include 'COMMON.CHAIN'
8230 !      include 'COMMON.DERIV'
8231 !      include 'COMMON.INTERACT'
8232 !      include 'COMMON.CONTACTS'
8233 !      include 'COMMON.TORSION'
8234 !      include 'COMMON.VAR'
8235 !      include 'COMMON.GEO'
8236       real(kind=8),dimension(2) :: vv,auxvec
8237       real(kind=8),dimension(2,2) :: pizda,auxmat
8238       logical :: swap
8239       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8240       real(kind=8) :: s1,s2,s3,s4
8241 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8242 !                                                                              C
8243 !      Parallel       Antiparallel                                             C
8244 !                                                                              C
8245 !          o             o                                                     C
8246 !         /l\   /   \   /j\                                                    C
8247 !        /   \ /     \ /   \                                                   C
8248 !       /| o |o       o| o |\                                                  C
8249 !       j|/k\|  /      |/k\|l /                                                C
8250 !        /   \ /       /   \ /                                                 C
8251 !       /     o       /     o                                                  C
8252 !       i             i                                                        C
8253 !                                                                              C
8254 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8255 !
8256 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8257 !           energy moment and not to the cluster cumulant.
8258       iti=itortyp(itype(i))
8259       if (j.lt.nres-1) then
8260         itj1=itortyp(itype(j+1))
8261       else
8262         itj1=ntortyp+1
8263       endif
8264       itk=itortyp(itype(k))
8265       itk1=itortyp(itype(k+1))
8266       if (l.lt.nres-1) then
8267         itl1=itortyp(itype(l+1))
8268       else
8269         itl1=ntortyp+1
8270       endif
8271 #ifdef MOMENT
8272       s1=dip(4,jj,i)*dip(4,kk,k)
8273 #endif
8274       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8275       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8276       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8277       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8278       call transpose2(EE(1,1,itk),auxmat(1,1))
8279       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8280       vv(1)=pizda(1,1)+pizda(2,2)
8281       vv(2)=pizda(2,1)-pizda(1,2)
8282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8283 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8284 !d     & "sum",-(s2+s3+s4)
8285 #ifdef MOMENT
8286       eello6_graph3=-(s1+s2+s3+s4)
8287 #else
8288       eello6_graph3=-(s2+s3+s4)
8289 #endif
8290 !      eello6_graph3=-s4
8291 ! Derivatives in gamma(k-1)
8292       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8293       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8294       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8295       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8296 ! Derivatives in gamma(l-1)
8297       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8298       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8299       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8300       vv(1)=pizda(1,1)+pizda(2,2)
8301       vv(2)=pizda(2,1)-pizda(1,2)
8302       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8303       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8304 ! Cartesian derivatives.
8305       do iii=1,2
8306         do kkk=1,5
8307           do lll=1,3
8308 #ifdef MOMENT
8309             if (iii.eq.1) then
8310               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8311             else
8312               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8313             endif
8314 #endif
8315             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8316               auxvec(1))
8317             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8318             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8319               auxvec(1))
8320             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8321             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8322               pizda(1,1))
8323             vv(1)=pizda(1,1)+pizda(2,2)
8324             vv(2)=pizda(2,1)-pizda(1,2)
8325             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8326 #ifdef MOMENT
8327             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8328 #else
8329             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8330 #endif
8331             if (swap) then
8332               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8333             else
8334               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8335             endif
8336 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8337           enddo
8338         enddo
8339       enddo
8340       return
8341       end function eello6_graph3
8342 !-----------------------------------------------------------------------------
8343       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8344 !      implicit real*8 (a-h,o-z)
8345 !      include 'DIMENSIONS'
8346 !      include 'COMMON.IOUNITS'
8347 !      include 'COMMON.CHAIN'
8348 !      include 'COMMON.DERIV'
8349 !      include 'COMMON.INTERACT'
8350 !      include 'COMMON.CONTACTS'
8351 !      include 'COMMON.TORSION'
8352 !      include 'COMMON.VAR'
8353 !      include 'COMMON.GEO'
8354 !      include 'COMMON.FFIELD'
8355       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8356       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8357       logical :: swap
8358       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8359               iii,kkk,lll
8360       real(kind=8) :: s1,s2,s3,s4
8361 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 !                                                                              C
8363 !      Parallel       Antiparallel                                             C
8364 !                                                                              C
8365 !          o             o                                                     C
8366 !         /l\   /   \   /j\                                                    C
8367 !        /   \ /     \ /   \                                                   C
8368 !       /| o |o       o| o |\                                                  C
8369 !     \ j|/k\|      \  |/k\|l                                                  C
8370 !      \ /   \       \ /   \                                                   C
8371 !       o     \       o     \                                                  C
8372 !       i             i                                                        C
8373 !                                                                              C
8374 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8375 !
8376 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8377 !           energy moment and not to the cluster cumulant.
8378 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8379       iti=itortyp(itype(i))
8380       itj=itortyp(itype(j))
8381       if (j.lt.nres-1) then
8382         itj1=itortyp(itype(j+1))
8383       else
8384         itj1=ntortyp+1
8385       endif
8386       itk=itortyp(itype(k))
8387       if (k.lt.nres-1) then
8388         itk1=itortyp(itype(k+1))
8389       else
8390         itk1=ntortyp+1
8391       endif
8392       itl=itortyp(itype(l))
8393       if (l.lt.nres-1) then
8394         itl1=itortyp(itype(l+1))
8395       else
8396         itl1=ntortyp+1
8397       endif
8398 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8399 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8400 !d     & ' itl',itl,' itl1',itl1
8401 #ifdef MOMENT
8402       if (imat.eq.1) then
8403         s1=dip(3,jj,i)*dip(3,kk,k)
8404       else
8405         s1=dip(2,jj,j)*dip(2,kk,l)
8406       endif
8407 #endif
8408       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8409       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8410       if (j.eq.l+1) then
8411         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8412         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8413       else
8414         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8415         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8416       endif
8417       call transpose2(EUg(1,1,k),auxmat(1,1))
8418       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8419       vv(1)=pizda(1,1)-pizda(2,2)
8420       vv(2)=pizda(2,1)+pizda(1,2)
8421       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8422 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8423 #ifdef MOMENT
8424       eello6_graph4=-(s1+s2+s3+s4)
8425 #else
8426       eello6_graph4=-(s2+s3+s4)
8427 #endif
8428 ! Derivatives in gamma(i-1)
8429       if (i.gt.1) then
8430 #ifdef MOMENT
8431         if (imat.eq.1) then
8432           s1=dipderg(2,jj,i)*dip(3,kk,k)
8433         else
8434           s1=dipderg(4,jj,j)*dip(2,kk,l)
8435         endif
8436 #endif
8437         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8438         if (j.eq.l+1) then
8439           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8440           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8441         else
8442           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8443           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8444         endif
8445         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8446         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8447 !d          write (2,*) 'turn6 derivatives'
8448 #ifdef MOMENT
8449           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8450 #else
8451           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8452 #endif
8453         else
8454 #ifdef MOMENT
8455           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8456 #else
8457           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8458 #endif
8459         endif
8460       endif
8461 ! Derivatives in gamma(k-1)
8462 #ifdef MOMENT
8463       if (imat.eq.1) then
8464         s1=dip(3,jj,i)*dipderg(2,kk,k)
8465       else
8466         s1=dip(2,jj,j)*dipderg(4,kk,l)
8467       endif
8468 #endif
8469       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8470       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8471       if (j.eq.l+1) then
8472         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8473         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8474       else
8475         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8476         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8477       endif
8478       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8479       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8480       vv(1)=pizda(1,1)-pizda(2,2)
8481       vv(2)=pizda(2,1)+pizda(1,2)
8482       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8483       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8484 #ifdef MOMENT
8485         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8486 #else
8487         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8488 #endif
8489       else
8490 #ifdef MOMENT
8491         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8492 #else
8493         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8494 #endif
8495       endif
8496 ! Derivatives in gamma(j-1) or gamma(l-1)
8497       if (l.eq.j+1 .and. l.gt.1) then
8498         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8499         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8500         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8501         vv(1)=pizda(1,1)-pizda(2,2)
8502         vv(2)=pizda(2,1)+pizda(1,2)
8503         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8504         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8505       else if (j.gt.1) then
8506         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8507         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8508         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8509         vv(1)=pizda(1,1)-pizda(2,2)
8510         vv(2)=pizda(2,1)+pizda(1,2)
8511         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8512         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8513           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8514         else
8515           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8516         endif
8517       endif
8518 ! Cartesian derivatives.
8519       do iii=1,2
8520         do kkk=1,5
8521           do lll=1,3
8522 #ifdef MOMENT
8523             if (iii.eq.1) then
8524               if (imat.eq.1) then
8525                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8526               else
8527                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8528               endif
8529             else
8530               if (imat.eq.1) then
8531                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8532               else
8533                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8534               endif
8535             endif
8536 #endif
8537             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8538               auxvec(1))
8539             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8540             if (j.eq.l+1) then
8541               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8542                 b1(1,itj1),auxvec(1))
8543               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8544             else
8545               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8546                 b1(1,itl1),auxvec(1))
8547               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8548             endif
8549             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8550               pizda(1,1))
8551             vv(1)=pizda(1,1)-pizda(2,2)
8552             vv(2)=pizda(2,1)+pizda(1,2)
8553             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554             if (swap) then
8555               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8556 #ifdef MOMENT
8557                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8558                    -(s1+s2+s4)
8559 #else
8560                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8561                    -(s2+s4)
8562 #endif
8563                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8564               else
8565 #ifdef MOMENT
8566                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8567 #else
8568                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8569 #endif
8570                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8571               endif
8572             else
8573 #ifdef MOMENT
8574               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8575 #else
8576               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8577 #endif
8578               if (l.eq.j+1) then
8579                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8580               else
8581                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8582               endif
8583             endif
8584           enddo
8585         enddo
8586       enddo
8587       return
8588       end function eello6_graph4
8589 !-----------------------------------------------------------------------------
8590       real(kind=8) function eello_turn6(i,jj,kk)
8591 !      implicit real*8 (a-h,o-z)
8592 !      include 'DIMENSIONS'
8593 !      include 'COMMON.IOUNITS'
8594 !      include 'COMMON.CHAIN'
8595 !      include 'COMMON.DERIV'
8596 !      include 'COMMON.INTERACT'
8597 !      include 'COMMON.CONTACTS'
8598 !      include 'COMMON.TORSION'
8599 !      include 'COMMON.VAR'
8600 !      include 'COMMON.GEO'
8601       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8602       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8603       real(kind=8),dimension(3) :: ggg1,ggg2
8604       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8605       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8606 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8607 !           the respective energy moment and not to the cluster cumulant.
8608 !el local variables
8609       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8610       integer :: j1,j2,l1,l2,ll
8611       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8612       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8613       s1=0.0d0
8614       s8=0.0d0
8615       s13=0.0d0
8616 !
8617       eello_turn6=0.0d0
8618       j=i+4
8619       k=i+1
8620       l=i+3
8621       iti=itortyp(itype(i))
8622       itk=itortyp(itype(k))
8623       itk1=itortyp(itype(k+1))
8624       itl=itortyp(itype(l))
8625       itj=itortyp(itype(j))
8626 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8627 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8628 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8629 !d        eello6=0.0d0
8630 !d        return
8631 !d      endif
8632 !d      write (iout,*)
8633 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8634 !d     &   ' and',k,l
8635 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8636       do iii=1,2
8637         do kkk=1,5
8638           do lll=1,3
8639             derx_turn(lll,kkk,iii)=0.0d0
8640           enddo
8641         enddo
8642       enddo
8643 !d      eij=1.0d0
8644 !d      ekl=1.0d0
8645 !d      ekont=1.0d0
8646       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8647 !d      eello6_5=0.0d0
8648 !d      write (2,*) 'eello6_5',eello6_5
8649 #ifdef MOMENT
8650       call transpose2(AEA(1,1,1),auxmat(1,1))
8651       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8652       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8653       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8654 #endif
8655       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8656       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8657       s2 = scalar2(b1(1,itk),vtemp1(1))
8658 #ifdef MOMENT
8659       call transpose2(AEA(1,1,2),atemp(1,1))
8660       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8661       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8662       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8663 #endif
8664       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8665       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8666       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8667 #ifdef MOMENT
8668       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8669       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8670       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8671       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8672       ss13 = scalar2(b1(1,itk),vtemp4(1))
8673       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8674 #endif
8675 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8676 !      s1=0.0d0
8677 !      s2=0.0d0
8678 !      s8=0.0d0
8679 !      s12=0.0d0
8680 !      s13=0.0d0
8681       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8682 ! Derivatives in gamma(i+2)
8683       s1d =0.0d0
8684       s8d =0.0d0
8685 #ifdef MOMENT
8686       call transpose2(AEA(1,1,1),auxmatd(1,1))
8687       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8688       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8689       call transpose2(AEAderg(1,1,2),atempd(1,1))
8690       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8691       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8692 #endif
8693       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8694       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8695       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8696 !      s1d=0.0d0
8697 !      s2d=0.0d0
8698 !      s8d=0.0d0
8699 !      s12d=0.0d0
8700 !      s13d=0.0d0
8701       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8702 ! Derivatives in gamma(i+3)
8703 #ifdef MOMENT
8704       call transpose2(AEA(1,1,1),auxmatd(1,1))
8705       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8706       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8707       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8708 #endif
8709       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8710       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8711       s2d = scalar2(b1(1,itk),vtemp1d(1))
8712 #ifdef MOMENT
8713       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8714       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8715 #endif
8716       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8717 #ifdef MOMENT
8718       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8719       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8720       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8721 #endif
8722 !      s1d=0.0d0
8723 !      s2d=0.0d0
8724 !      s8d=0.0d0
8725 !      s12d=0.0d0
8726 !      s13d=0.0d0
8727 #ifdef MOMENT
8728       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8729                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8730 #else
8731       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8732                     -0.5d0*ekont*(s2d+s12d)
8733 #endif
8734 ! Derivatives in gamma(i+4)
8735       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8736       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8737       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8738 #ifdef MOMENT
8739       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8740       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8741       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8742 #endif
8743 !      s1d=0.0d0
8744 !      s2d=0.0d0
8745 !      s8d=0.0d0
8746 !      s12d=0.0d0
8747 !      s13d=0.0d0
8748 #ifdef MOMENT
8749       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8750 #else
8751       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8752 #endif
8753 ! Derivatives in gamma(i+5)
8754 #ifdef MOMENT
8755       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8756       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8757       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8758 #endif
8759       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8760       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8761       s2d = scalar2(b1(1,itk),vtemp1d(1))
8762 #ifdef MOMENT
8763       call transpose2(AEA(1,1,2),atempd(1,1))
8764       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8765       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8766 #endif
8767       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8768       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8769 #ifdef MOMENT
8770       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8771       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8772       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8773 #endif
8774 !      s1d=0.0d0
8775 !      s2d=0.0d0
8776 !      s8d=0.0d0
8777 !      s12d=0.0d0
8778 !      s13d=0.0d0
8779 #ifdef MOMENT
8780       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8781                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8782 #else
8783       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8784                     -0.5d0*ekont*(s2d+s12d)
8785 #endif
8786 ! Cartesian derivatives
8787       do iii=1,2
8788         do kkk=1,5
8789           do lll=1,3
8790 #ifdef MOMENT
8791             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8792             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8793             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8794 #endif
8795             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8796             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8797                 vtemp1d(1))
8798             s2d = scalar2(b1(1,itk),vtemp1d(1))
8799 #ifdef MOMENT
8800             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8801             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8802             s8d = -(atempd(1,1)+atempd(2,2))* &
8803                  scalar2(cc(1,1,itl),vtemp2(1))
8804 #endif
8805             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8806                  auxmatd(1,1))
8807             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8808             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8809 !      s1d=0.0d0
8810 !      s2d=0.0d0
8811 !      s8d=0.0d0
8812 !      s12d=0.0d0
8813 !      s13d=0.0d0
8814 #ifdef MOMENT
8815             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8816               - 0.5d0*(s1d+s2d)
8817 #else
8818             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8819               - 0.5d0*s2d
8820 #endif
8821 #ifdef MOMENT
8822             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8823               - 0.5d0*(s8d+s12d)
8824 #else
8825             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8826               - 0.5d0*s12d
8827 #endif
8828           enddo
8829         enddo
8830       enddo
8831 #ifdef MOMENT
8832       do kkk=1,5
8833         do lll=1,3
8834           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8835             achuj_tempd(1,1))
8836           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8837           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8838           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8839           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8840           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8841             vtemp4d(1))
8842           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8843           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8844           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8845         enddo
8846       enddo
8847 #endif
8848 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8849 !d     &  16*eel_turn6_num
8850 !d      goto 1112
8851       if (j.lt.nres-1) then
8852         j1=j+1
8853         j2=j-1
8854       else
8855         j1=j-1
8856         j2=j-2
8857       endif
8858       if (l.lt.nres-1) then
8859         l1=l+1
8860         l2=l-1
8861       else
8862         l1=l-1
8863         l2=l-2
8864       endif
8865       do ll=1,3
8866 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8867 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8868 !grad        ghalf=0.5d0*ggg1(ll)
8869 !d        ghalf=0.0d0
8870         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8871         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8872         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8873           +ekont*derx_turn(ll,2,1)
8874         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8875         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8876           +ekont*derx_turn(ll,4,1)
8877         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8878         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8879         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8880 !grad        ghalf=0.5d0*ggg2(ll)
8881 !d        ghalf=0.0d0
8882         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8883           +ekont*derx_turn(ll,2,2)
8884         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8885         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8886           +ekont*derx_turn(ll,4,2)
8887         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8888         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8889         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8890       enddo
8891 !d      goto 1112
8892 !grad      do m=i+1,j-1
8893 !grad        do ll=1,3
8894 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8895 !grad        enddo
8896 !grad      enddo
8897 !grad      do m=k+1,l-1
8898 !grad        do ll=1,3
8899 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8900 !grad        enddo
8901 !grad      enddo
8902 !grad1112  continue
8903 !grad      do m=i+2,j2
8904 !grad        do ll=1,3
8905 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8906 !grad        enddo
8907 !grad      enddo
8908 !grad      do m=k+2,l2
8909 !grad        do ll=1,3
8910 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8911 !grad        enddo
8912 !grad      enddo
8913 !d      do iii=1,nres-3
8914 !d        write (2,*) iii,g_corr6_loc(iii)
8915 !d      enddo
8916       eello_turn6=ekont*eel_turn6
8917 !d      write (2,*) 'ekont',ekont
8918 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8919       return
8920       end function eello_turn6
8921 !-----------------------------------------------------------------------------
8922       subroutine MATVEC2(A1,V1,V2)
8923 !DIR$ INLINEALWAYS MATVEC2
8924 #ifndef OSF
8925 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8926 #endif
8927 !      implicit real*8 (a-h,o-z)
8928 !      include 'DIMENSIONS'
8929       real(kind=8),dimension(2) :: V1,V2
8930       real(kind=8),dimension(2,2) :: A1
8931       real(kind=8) :: vaux1,vaux2
8932 !      DO 1 I=1,2
8933 !        VI=0.0
8934 !        DO 3 K=1,2
8935 !    3     VI=VI+A1(I,K)*V1(K)
8936 !        Vaux(I)=VI
8937 !    1 CONTINUE
8938
8939       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8940       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8941
8942       v2(1)=vaux1
8943       v2(2)=vaux2
8944       end subroutine MATVEC2
8945 !-----------------------------------------------------------------------------
8946       subroutine MATMAT2(A1,A2,A3)
8947 #ifndef OSF
8948 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8949 #endif
8950 !      implicit real*8 (a-h,o-z)
8951 !      include 'DIMENSIONS'
8952       real(kind=8),dimension(2,2) :: A1,A2,A3
8953       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
8954 !      DIMENSION AI3(2,2)
8955 !        DO  J=1,2
8956 !          A3IJ=0.0
8957 !          DO K=1,2
8958 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8959 !          enddo
8960 !          A3(I,J)=A3IJ
8961 !       enddo
8962 !      enddo
8963
8964       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8965       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8966       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8967       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8968
8969       A3(1,1)=AI3_11
8970       A3(2,1)=AI3_21
8971       A3(1,2)=AI3_12
8972       A3(2,2)=AI3_22
8973       end subroutine MATMAT2
8974 !-----------------------------------------------------------------------------
8975       real(kind=8) function scalar2(u,v)
8976 !DIR$ INLINEALWAYS scalar2
8977       implicit none
8978       real(kind=8),dimension(2) :: u,v
8979       real(kind=8) :: sc
8980       integer :: i
8981       scalar2=u(1)*v(1)+u(2)*v(2)
8982       return
8983       end function scalar2
8984 !-----------------------------------------------------------------------------
8985       subroutine transpose2(a,at)
8986 !DIR$ INLINEALWAYS transpose2
8987 #ifndef OSF
8988 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
8989 #endif
8990       implicit none
8991       real(kind=8),dimension(2,2) :: a,at
8992       at(1,1)=a(1,1)
8993       at(1,2)=a(2,1)
8994       at(2,1)=a(1,2)
8995       at(2,2)=a(2,2)
8996       return
8997       end subroutine transpose2
8998 !-----------------------------------------------------------------------------
8999       subroutine transpose(n,a,at)
9000       implicit none
9001       integer :: n,i,j
9002       real(kind=8),dimension(n,n) :: a,at
9003       do i=1,n
9004         do j=1,n
9005           at(j,i)=a(i,j)
9006         enddo
9007       enddo
9008       return
9009       end subroutine transpose
9010 !-----------------------------------------------------------------------------
9011       subroutine prodmat3(a1,a2,kk,transp,prod)
9012 !DIR$ INLINEALWAYS prodmat3
9013 #ifndef OSF
9014 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9015 #endif
9016       implicit none
9017       integer :: i,j
9018       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9019       logical :: transp
9020 !rc      double precision auxmat(2,2),prod_(2,2)
9021
9022       if (transp) then
9023 !rc        call transpose2(kk(1,1),auxmat(1,1))
9024 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9025 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9026
9027            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9028        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9029            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9030        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9031            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9032        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9033            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9034        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9035
9036       else
9037 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9038 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9039
9040            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9041         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9042            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9043         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9044            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9045         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9046            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9047         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9048
9049       endif
9050 !      call transpose2(a2(1,1),a2t(1,1))
9051
9052 !rc      print *,transp
9053 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9054 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9055
9056       return
9057       end subroutine prodmat3
9058 !-----------------------------------------------------------------------------
9059 ! energy_p_new_barrier.F
9060 !-----------------------------------------------------------------------------
9061       subroutine sum_gradient
9062 !      implicit real*8 (a-h,o-z)
9063       use io_base, only: pdbout
9064 !      include 'DIMENSIONS'
9065 #ifndef ISNAN
9066       external proc_proc
9067 #ifdef WINPGI
9068 !MS$ATTRIBUTES C ::  proc_proc
9069 #endif
9070 #endif
9071 #ifdef MPI
9072       include 'mpif.h'
9073 #endif
9074       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9075                    gloc_scbuf !(3,maxres)
9076
9077       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9078 !#endif
9079 !el local variables
9080       integer :: i,j,k,ierror,ierr
9081       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9082                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9083                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9084                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9085                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9086                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9087                    gsccorr_max,gsccorrx_max,time00
9088
9089 !      include 'COMMON.SETUP'
9090 !      include 'COMMON.IOUNITS'
9091 !      include 'COMMON.FFIELD'
9092 !      include 'COMMON.DERIV'
9093 !      include 'COMMON.INTERACT'
9094 !      include 'COMMON.SBRIDGE'
9095 !      include 'COMMON.CHAIN'
9096 !      include 'COMMON.VAR'
9097 !      include 'COMMON.CONTROL'
9098 !      include 'COMMON.TIME1'
9099 !      include 'COMMON.MAXGRAD'
9100 !      include 'COMMON.SCCOR'
9101 #ifdef TIMING
9102       time01=MPI_Wtime()
9103 #endif
9104 #ifdef DEBUG
9105       write (iout,*) "sum_gradient gvdwc, gvdwx"
9106       do i=1,nres
9107         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9108          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9109       enddo
9110       call flush(iout)
9111 #endif
9112 #ifdef MPI
9113         gradbufc=0.0d0
9114         gradbufx=0.0d0
9115         gradbufc_sum=0.0d0
9116         gloc_scbuf=0.0d0
9117         glocbuf=0.0d0
9118 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9119         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9120           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9121 #endif
9122 !
9123 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9124 !            in virtual-bond-vector coordinates
9125 !
9126 #ifdef DEBUG
9127 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9128 !      do i=1,nres-1
9129 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9130 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9131 !      enddo
9132 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9133 !      do i=1,nres-1
9134 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9135 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9136 !      enddo
9137       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9138       do i=1,nres
9139         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9140          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9141          (gvdwc_scpp(j,i),j=1,3)
9142       enddo
9143       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9144       do i=1,nres
9145         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9146          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9147          (gelc_loc_long(j,i),j=1,3)
9148       enddo
9149       call flush(iout)
9150 #endif
9151 #ifdef SPLITELE
9152       do i=1,nct
9153         do j=1,3
9154           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9155                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9156                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9157                       wel_loc*gel_loc_long(j,i)+ &
9158                       wcorr*gradcorr_long(j,i)+ &
9159                       wcorr5*gradcorr5_long(j,i)+ &
9160                       wcorr6*gradcorr6_long(j,i)+ &
9161                       wturn6*gcorr6_turn_long(j,i)+ &
9162                       wstrain*ghpbc(j,i)
9163         enddo
9164       enddo
9165 #else
9166       do i=1,nct
9167         do j=1,3
9168           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9169                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9170                       welec*gelc_long(j,i)+ &
9171                       wbond*gradb(j,i)+ &
9172                       wel_loc*gel_loc_long(j,i)+ &
9173                       wcorr*gradcorr_long(j,i)+ &
9174                       wcorr5*gradcorr5_long(j,i)+ &
9175                       wcorr6*gradcorr6_long(j,i)+ &
9176                       wturn6*gcorr6_turn_long(j,i)+ &
9177                       wstrain*ghpbc(j,i)
9178         enddo
9179       enddo
9180 #endif
9181 #ifdef MPI
9182       if (nfgtasks.gt.1) then
9183       time00=MPI_Wtime()
9184 #ifdef DEBUG
9185       write (iout,*) "gradbufc before allreduce"
9186       do i=1,nres
9187         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9188       enddo
9189       call flush(iout)
9190 #endif
9191       do i=1,nres
9192         do j=1,3
9193           gradbufc_sum(j,i)=gradbufc(j,i)
9194         enddo
9195       enddo
9196 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9197 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9198 !      time_reduce=time_reduce+MPI_Wtime()-time00
9199 #ifdef DEBUG
9200 !      write (iout,*) "gradbufc_sum after allreduce"
9201 !      do i=1,nres
9202 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9203 !      enddo
9204 !      call flush(iout)
9205 #endif
9206 #ifdef TIMING
9207 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9208 #endif
9209       do i=nnt,nres
9210         do k=1,3
9211           gradbufc(k,i)=0.0d0
9212         enddo
9213       enddo
9214 #ifdef DEBUG
9215       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9216       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9217                         " jgrad_end  ",jgrad_end(i),&
9218                         i=igrad_start,igrad_end)
9219 #endif
9220 !
9221 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9222 ! do not parallelize this part.
9223 !
9224 !      do i=igrad_start,igrad_end
9225 !        do j=jgrad_start(i),jgrad_end(i)
9226 !          do k=1,3
9227 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9228 !          enddo
9229 !        enddo
9230 !      enddo
9231       do j=1,3
9232         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9233       enddo
9234       do i=nres-2,nnt,-1
9235         do j=1,3
9236           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9237         enddo
9238       enddo
9239 #ifdef DEBUG
9240       write (iout,*) "gradbufc after summing"
9241       do i=1,nres
9242         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9243       enddo
9244       call flush(iout)
9245 #endif
9246       else
9247 #endif
9248 !el#define DEBUG
9249 #ifdef DEBUG
9250       write (iout,*) "gradbufc"
9251       do i=1,nres
9252         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9253       enddo
9254       call flush(iout)
9255 #endif
9256 !el#undef DEBUG
9257       do i=1,nres
9258         do j=1,3
9259           gradbufc_sum(j,i)=gradbufc(j,i)
9260           gradbufc(j,i)=0.0d0
9261         enddo
9262       enddo
9263       do j=1,3
9264         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9265       enddo
9266       do i=nres-2,nnt,-1
9267         do j=1,3
9268           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9269         enddo
9270       enddo
9271 !      do i=nnt,nres-1
9272 !        do k=1,3
9273 !          gradbufc(k,i)=0.0d0
9274 !        enddo
9275 !        do j=i+1,nres
9276 !          do k=1,3
9277 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9278 !          enddo
9279 !        enddo
9280 !      enddo
9281 !el#define DEBUG
9282 #ifdef DEBUG
9283       write (iout,*) "gradbufc after summing"
9284       do i=1,nres
9285         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9286       enddo
9287       call flush(iout)
9288 #endif
9289 !el#undef DEBUG
9290 #ifdef MPI
9291       endif
9292 #endif
9293       do k=1,3
9294         gradbufc(k,nres)=0.0d0
9295       enddo
9296 !el----------------
9297 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9298 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9299 !el-----------------
9300       do i=1,nct
9301         do j=1,3
9302 #ifdef SPLITELE
9303           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9304                       wel_loc*gel_loc(j,i)+ &
9305                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9306                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9307                       wel_loc*gel_loc_long(j,i)+ &
9308                       wcorr*gradcorr_long(j,i)+ &
9309                       wcorr5*gradcorr5_long(j,i)+ &
9310                       wcorr6*gradcorr6_long(j,i)+ &
9311                       wturn6*gcorr6_turn_long(j,i))+ &
9312                       wbond*gradb(j,i)+ &
9313                       wcorr*gradcorr(j,i)+ &
9314                       wturn3*gcorr3_turn(j,i)+ &
9315                       wturn4*gcorr4_turn(j,i)+ &
9316                       wcorr5*gradcorr5(j,i)+ &
9317                       wcorr6*gradcorr6(j,i)+ &
9318                       wturn6*gcorr6_turn(j,i)+ &
9319                       wsccor*gsccorc(j,i) &
9320                      +wscloc*gscloc(j,i)
9321 #else
9322           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9323                       wel_loc*gel_loc(j,i)+ &
9324                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9325                       welec*gelc_long(j,i)+ &
9326                       wel_loc*gel_loc_long(j,i)+ &
9327 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9328                       wcorr5*gradcorr5_long(j,i)+ &
9329                       wcorr6*gradcorr6_long(j,i)+ &
9330                       wturn6*gcorr6_turn_long(j,i))+ &
9331                       wbond*gradb(j,i)+ &
9332                       wcorr*gradcorr(j,i)+ &
9333                       wturn3*gcorr3_turn(j,i)+ &
9334                       wturn4*gcorr4_turn(j,i)+ &
9335                       wcorr5*gradcorr5(j,i)+ &
9336                       wcorr6*gradcorr6(j,i)+ &
9337                       wturn6*gcorr6_turn(j,i)+ &
9338                       wsccor*gsccorc(j,i) &
9339                      +wscloc*gscloc(j,i)
9340 #endif
9341           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9342                         wbond*gradbx(j,i)+ &
9343                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9344                         wsccor*gsccorx(j,i) &
9345                        +wscloc*gsclocx(j,i)
9346         enddo
9347       enddo
9348 #ifdef DEBUG
9349       write (iout,*) "gloc before adding corr"
9350       do i=1,4*nres
9351         write (iout,*) i,gloc(i,icg)
9352       enddo
9353 #endif
9354       do i=1,nres-3
9355         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9356          +wcorr5*g_corr5_loc(i) &
9357          +wcorr6*g_corr6_loc(i) &
9358          +wturn4*gel_loc_turn4(i) &
9359          +wturn3*gel_loc_turn3(i) &
9360          +wturn6*gel_loc_turn6(i) &
9361          +wel_loc*gel_loc_loc(i)
9362       enddo
9363 #ifdef DEBUG
9364       write (iout,*) "gloc after adding corr"
9365       do i=1,4*nres
9366         write (iout,*) i,gloc(i,icg)
9367       enddo
9368 #endif
9369 #ifdef MPI
9370       if (nfgtasks.gt.1) then
9371         do j=1,3
9372           do i=1,nres
9373             gradbufc(j,i)=gradc(j,i,icg)
9374             gradbufx(j,i)=gradx(j,i,icg)
9375           enddo
9376         enddo
9377         do i=1,4*nres
9378           glocbuf(i)=gloc(i,icg)
9379         enddo
9380 !#define DEBUG
9381 #ifdef DEBUG
9382       write (iout,*) "gloc_sc before reduce"
9383       do i=1,nres
9384        do j=1,1
9385         write (iout,*) i,j,gloc_sc(j,i,icg)
9386        enddo
9387       enddo
9388 #endif
9389 !#undef DEBUG
9390         do i=1,nres
9391          do j=1,3
9392           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9393          enddo
9394         enddo
9395         time00=MPI_Wtime()
9396         call MPI_Barrier(FG_COMM,IERR)
9397         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9398         time00=MPI_Wtime()
9399         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9400           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9401         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9402           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9403         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9404           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9405         time_reduce=time_reduce+MPI_Wtime()-time00
9406         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9407           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9408         time_reduce=time_reduce+MPI_Wtime()-time00
9409 !#define DEBUG
9410 #ifdef DEBUG
9411       write (iout,*) "gloc_sc after reduce"
9412       do i=1,nres
9413        do j=1,1
9414         write (iout,*) i,j,gloc_sc(j,i,icg)
9415        enddo
9416       enddo
9417 #endif
9418 !#undef DEBUG
9419 #ifdef DEBUG
9420       write (iout,*) "gloc after reduce"
9421       do i=1,4*nres
9422         write (iout,*) i,gloc(i,icg)
9423       enddo
9424 #endif
9425       endif
9426 #endif
9427       if (gnorm_check) then
9428 !
9429 ! Compute the maximum elements of the gradient
9430 !
9431       gvdwc_max=0.0d0
9432       gvdwc_scp_max=0.0d0
9433       gelc_max=0.0d0
9434       gvdwpp_max=0.0d0
9435       gradb_max=0.0d0
9436       ghpbc_max=0.0d0
9437       gradcorr_max=0.0d0
9438       gel_loc_max=0.0d0
9439       gcorr3_turn_max=0.0d0
9440       gcorr4_turn_max=0.0d0
9441       gradcorr5_max=0.0d0
9442       gradcorr6_max=0.0d0
9443       gcorr6_turn_max=0.0d0
9444       gsccorc_max=0.0d0
9445       gscloc_max=0.0d0
9446       gvdwx_max=0.0d0
9447       gradx_scp_max=0.0d0
9448       ghpbx_max=0.0d0
9449       gradxorr_max=0.0d0
9450       gsccorx_max=0.0d0
9451       gsclocx_max=0.0d0
9452       do i=1,nct
9453         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9454         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9455         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9456         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9457          gvdwc_scp_max=gvdwc_scp_norm
9458         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9459         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9460         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9461         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9462         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9463         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9464         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9465         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9466         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9467         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9468         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9469         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9470         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9471           gcorr3_turn(1,i)))
9472         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9473           gcorr3_turn_max=gcorr3_turn_norm
9474         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9475           gcorr4_turn(1,i)))
9476         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9477           gcorr4_turn_max=gcorr4_turn_norm
9478         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9479         if (gradcorr5_norm.gt.gradcorr5_max) &
9480           gradcorr5_max=gradcorr5_norm
9481         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9482         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9483         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9484           gcorr6_turn(1,i)))
9485         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9486           gcorr6_turn_max=gcorr6_turn_norm
9487         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9488         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9489         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9490         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9491         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9492         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9493         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9494         if (gradx_scp_norm.gt.gradx_scp_max) &
9495           gradx_scp_max=gradx_scp_norm
9496         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9497         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9498         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9499         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9500         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9501         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9502         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9503         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9504       enddo
9505       if (gradout) then
9506 #ifdef AIX
9507         open(istat,file=statname,position="append")
9508 #else
9509         open(istat,file=statname,access="append")
9510 #endif
9511         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9512            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9513            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9514            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9515            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9516            gsccorx_max,gsclocx_max
9517         close(istat)
9518         if (gvdwc_max.gt.1.0d4) then
9519           write (iout,*) "gvdwc gvdwx gradb gradbx"
9520           do i=nnt,nct
9521             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9522               gradb(j,i),gradbx(j,i),j=1,3)
9523           enddo
9524           call pdbout(0.0d0,'cipiszcze',iout)
9525           call flush(iout)
9526         endif
9527       endif
9528       endif
9529 !el#define DEBUG
9530 #ifdef DEBUG
9531       write (iout,*) "gradc gradx gloc"
9532       do i=1,nres
9533         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9534          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9535       enddo
9536 #endif
9537 !el#undef DEBUG
9538 #ifdef TIMING
9539       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9540 #endif
9541       return
9542       end subroutine sum_gradient
9543 !-----------------------------------------------------------------------------
9544       subroutine sc_grad
9545 !      implicit real*8 (a-h,o-z)
9546       use calc_data
9547 !      include 'DIMENSIONS'
9548 !      include 'COMMON.CHAIN'
9549 !      include 'COMMON.DERIV'
9550 !      include 'COMMON.CALC'
9551 !      include 'COMMON.IOUNITS'
9552       real(kind=8), dimension(3) :: dcosom1,dcosom2
9553
9554       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9555       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9556       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9557            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9558 ! diagnostics only
9559 !      eom1=0.0d0
9560 !      eom2=0.0d0
9561 !      eom12=evdwij*eps1_om12
9562 ! end diagnostics
9563 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9564 !       " sigder",sigder
9565 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9566 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9567       do k=1,3
9568         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9569         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9570       enddo
9571       do k=1,3
9572         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
9573       enddo
9574 !      write (iout,*) "gg",(gg(k),k=1,3)
9575       do k=1,3
9576         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9577                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9578                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9579         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9580                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9581                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9582 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9583 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9584 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9585 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9586       enddo
9587 !
9588 ! Calculate the components of the gradient in DC and X
9589 !
9590 !grad      do k=i,j-1
9591 !grad        do l=1,3
9592 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9593 !grad        enddo
9594 !grad      enddo
9595       do l=1,3
9596         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9597         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9598       enddo
9599       return
9600       end subroutine sc_grad
9601 #ifdef CRYST_THETA
9602 !-----------------------------------------------------------------------------
9603       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9604
9605       use comm_calcthet
9606 !      implicit real*8 (a-h,o-z)
9607 !      include 'DIMENSIONS'
9608 !      include 'COMMON.LOCAL'
9609 !      include 'COMMON.IOUNITS'
9610 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9611 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9612 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9613       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9614       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9615 !el      integer :: it
9616 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9617 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9618 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9619 !el local variables
9620
9621       delthec=thetai-thet_pred_mean
9622       delthe0=thetai-theta0i
9623 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9624       t3 = thetai-thet_pred_mean
9625       t6 = t3**2
9626       t9 = term1
9627       t12 = t3*sigcsq
9628       t14 = t12+t6*sigsqtc
9629       t16 = 1.0d0
9630       t21 = thetai-theta0i
9631       t23 = t21**2
9632       t26 = term2
9633       t27 = t21*t26
9634       t32 = termexp
9635       t40 = t32**2
9636       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9637        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9638        *(-t12*t9-ak*sig0inv*t27)
9639       return
9640       end subroutine mixder
9641 #endif
9642 !-----------------------------------------------------------------------------
9643 ! cartder.F
9644 !-----------------------------------------------------------------------------
9645       subroutine cartder
9646 !-----------------------------------------------------------------------------
9647 ! This subroutine calculates the derivatives of the consecutive virtual
9648 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9649 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9650 ! in the angles alpha and omega, describing the location of a side chain
9651 ! in its local coordinate system.
9652 !
9653 ! The derivatives are stored in the following arrays:
9654 !
9655 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9656 ! The structure is as follows:
9657 !
9658 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9659 ! 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)
9660 !         . . . . . . . . . . . .  . . . . . .
9661 ! 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)
9662 !                          .
9663 !                          .
9664 !                          .
9665 ! 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)
9666 !
9667 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9668 ! The structure is same as above.
9669 !
9670 ! DCDS - the derivatives of the side chain vectors in the local spherical
9671 ! andgles alph and omega:
9672 !
9673 ! 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)
9674 ! 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)
9675 !                          .
9676 !                          .
9677 !                          .
9678 ! 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)
9679 !
9680 ! Version of March '95, based on an early version of November '91.
9681 !
9682 !**********************************************************************
9683 !      implicit real*8 (a-h,o-z)
9684 !      include 'DIMENSIONS'
9685 !      include 'COMMON.VAR'
9686 !      include 'COMMON.CHAIN'
9687 !      include 'COMMON.DERIV'
9688 !      include 'COMMON.GEO'
9689 !      include 'COMMON.LOCAL'
9690 !      include 'COMMON.INTERACT'
9691       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9692       real(kind=8),dimension(3,3) :: dp,temp
9693 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9694       real(kind=8),dimension(3) :: xx,xx1
9695 !el local variables
9696       integer :: i,k,l,j,m,ind,ind1,jjj
9697       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9698                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9699                  sint2,xp,yp,xxp,yyp,zzp,dj
9700
9701 !      common /przechowalnia/ fromto
9702       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9703 ! get the position of the jth ijth fragment of the chain coordinate system
9704 ! in the fromto array.
9705 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9706 !
9707 !      maxdim=(nres-1)*(nres-2)/2
9708 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9709 ! calculate the derivatives of transformation matrix elements in theta
9710 !
9711
9712 !el      call flush(iout) !el
9713       do i=1,nres-2
9714         rdt(1,1,i)=-rt(1,2,i)
9715         rdt(1,2,i)= rt(1,1,i)
9716         rdt(1,3,i)= 0.0d0
9717         rdt(2,1,i)=-rt(2,2,i)
9718         rdt(2,2,i)= rt(2,1,i)
9719         rdt(2,3,i)= 0.0d0
9720         rdt(3,1,i)=-rt(3,2,i)
9721         rdt(3,2,i)= rt(3,1,i)
9722         rdt(3,3,i)= 0.0d0
9723       enddo
9724 !
9725 ! derivatives in phi
9726 !
9727       do i=2,nres-2
9728         drt(1,1,i)= 0.0d0
9729         drt(1,2,i)= 0.0d0
9730         drt(1,3,i)= 0.0d0
9731         drt(2,1,i)= rt(3,1,i)
9732         drt(2,2,i)= rt(3,2,i)
9733         drt(2,3,i)= rt(3,3,i)
9734         drt(3,1,i)=-rt(2,1,i)
9735         drt(3,2,i)=-rt(2,2,i)
9736         drt(3,3,i)=-rt(2,3,i)
9737       enddo
9738 !
9739 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9740 !
9741       do i=2,nres-2
9742         ind=indmat(i,i+1)
9743         do k=1,3
9744           do l=1,3
9745             temp(k,l)=rt(k,l,i)
9746           enddo
9747         enddo
9748         do k=1,3
9749           do l=1,3
9750             fromto(k,l,ind)=temp(k,l)
9751           enddo
9752         enddo
9753         do j=i+1,nres-2
9754           ind=indmat(i,j+1)
9755           do k=1,3
9756             do l=1,3
9757               dpkl=0.0d0
9758               do m=1,3
9759                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9760               enddo
9761               dp(k,l)=dpkl
9762               fromto(k,l,ind)=dpkl
9763             enddo
9764           enddo
9765           do k=1,3
9766             do l=1,3
9767               temp(k,l)=dp(k,l)
9768             enddo
9769           enddo
9770         enddo
9771       enddo
9772 !
9773 ! Calculate derivatives.
9774 !
9775       ind1=0
9776       do i=1,nres-2
9777         ind1=ind1+1
9778 !
9779 ! Derivatives of DC(i+1) in theta(i+2)
9780 !
9781         do j=1,3
9782           do k=1,2
9783             dpjk=0.0D0
9784             do l=1,3
9785               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9786             enddo
9787             dp(j,k)=dpjk
9788             prordt(j,k,i)=dp(j,k)
9789           enddo
9790           dp(j,3)=0.0D0
9791           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9792         enddo
9793 !
9794 ! Derivatives of SC(i+1) in theta(i+2)
9795 !
9796         xx1(1)=-0.5D0*xloc(2,i+1)
9797         xx1(2)= 0.5D0*xloc(1,i+1)
9798         do j=1,3
9799           xj=0.0D0
9800           do k=1,2
9801             xj=xj+r(j,k,i)*xx1(k)
9802           enddo
9803           xx(j)=xj
9804         enddo
9805         do j=1,3
9806           rj=0.0D0
9807           do k=1,3
9808             rj=rj+prod(j,k,i)*xx(k)
9809           enddo
9810           dxdv(j,ind1)=rj
9811         enddo
9812 !
9813 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9814 ! than the other off-diagonal derivatives.
9815 !
9816         do j=1,3
9817           dxoiij=0.0D0
9818           do k=1,3
9819             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9820           enddo
9821           dxdv(j,ind1+1)=dxoiij
9822         enddo
9823 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9824 !
9825 ! Derivatives of DC(i+1) in phi(i+2)
9826 !
9827         do j=1,3
9828           do k=1,3
9829             dpjk=0.0
9830             do l=2,3
9831               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9832             enddo
9833             dp(j,k)=dpjk
9834             prodrt(j,k,i)=dp(j,k)
9835           enddo
9836           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9837         enddo
9838 !
9839 ! Derivatives of SC(i+1) in phi(i+2)
9840 !
9841         xx(1)= 0.0D0
9842         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9843         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9844         do j=1,3
9845           rj=0.0D0
9846           do k=2,3
9847             rj=rj+prod(j,k,i)*xx(k)
9848           enddo
9849           dxdv(j+3,ind1)=-rj
9850         enddo
9851 !
9852 ! Derivatives of SC(i+1) in phi(i+3).
9853 !
9854         do j=1,3
9855           dxoiij=0.0D0
9856           do k=1,3
9857             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9858           enddo
9859           dxdv(j+3,ind1+1)=dxoiij
9860         enddo
9861 !
9862 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9863 ! theta(nres) and phi(i+3) thru phi(nres).
9864 !
9865         do j=i+1,nres-2
9866           ind1=ind1+1
9867           ind=indmat(i+1,j+1)
9868 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9869           do k=1,3
9870             do l=1,3
9871               tempkl=0.0D0
9872               do m=1,2
9873                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9874               enddo
9875               temp(k,l)=tempkl
9876             enddo
9877           enddo
9878 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9879 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9880 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9881 ! Derivatives of virtual-bond vectors in theta
9882           do k=1,3
9883             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9884           enddo
9885 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9886 ! Derivatives of SC vectors in theta
9887           do k=1,3
9888             dxoijk=0.0D0
9889             do l=1,3
9890               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9891             enddo
9892             dxdv(k,ind1+1)=dxoijk
9893           enddo
9894 !
9895 !--- Calculate the derivatives in phi
9896 !
9897           do k=1,3
9898             do l=1,3
9899               tempkl=0.0D0
9900               do m=1,3
9901                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9902               enddo
9903               temp(k,l)=tempkl
9904             enddo
9905           enddo
9906           do k=1,3
9907             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9908           enddo
9909           do k=1,3
9910             dxoijk=0.0D0
9911             do l=1,3
9912               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9913             enddo
9914             dxdv(k+3,ind1+1)=dxoijk
9915           enddo
9916         enddo
9917       enddo
9918 !
9919 ! Derivatives in alpha and omega:
9920 !
9921       do i=2,nres-1
9922 !       dsci=dsc(itype(i))
9923         dsci=vbld(i+nres)
9924 #ifdef OSF
9925         alphi=alph(i)
9926         omegi=omeg(i)
9927         if(alphi.ne.alphi) alphi=100.0
9928         if(omegi.ne.omegi) omegi=-100.0
9929 #else
9930         alphi=alph(i)
9931         omegi=omeg(i)
9932 #endif
9933 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
9934         cosalphi=dcos(alphi)
9935         sinalphi=dsin(alphi)
9936         cosomegi=dcos(omegi)
9937         sinomegi=dsin(omegi)
9938         temp(1,1)=-dsci*sinalphi
9939         temp(2,1)= dsci*cosalphi*cosomegi
9940         temp(3,1)=-dsci*cosalphi*sinomegi
9941         temp(1,2)=0.0D0
9942         temp(2,2)=-dsci*sinalphi*sinomegi
9943         temp(3,2)=-dsci*sinalphi*cosomegi
9944         theta2=pi-0.5D0*theta(i+1)
9945         cost2=dcos(theta2)
9946         sint2=dsin(theta2)
9947         jjj=0
9948 !d      print *,((temp(l,k),l=1,3),k=1,2)
9949         do j=1,2
9950           xp=temp(1,j)
9951           yp=temp(2,j)
9952           xxp= xp*cost2+yp*sint2
9953           yyp=-xp*sint2+yp*cost2
9954           zzp=temp(3,j)
9955           xx(1)=xxp
9956           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
9957           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
9958           do k=1,3
9959             dj=0.0D0
9960             do l=1,3
9961               dj=dj+prod(k,l,i-1)*xx(l)
9962             enddo
9963             dxds(jjj+k,i)=dj
9964           enddo
9965           jjj=jjj+3
9966         enddo
9967       enddo
9968       return
9969       end subroutine cartder
9970 !-----------------------------------------------------------------------------
9971 ! checkder_p.F
9972 !-----------------------------------------------------------------------------
9973       subroutine check_cartgrad
9974 ! Check the gradient of Cartesian coordinates in internal coordinates.
9975 !      implicit real*8 (a-h,o-z)
9976 !      include 'DIMENSIONS'
9977 !      include 'COMMON.IOUNITS'
9978 !      include 'COMMON.VAR'
9979 !      include 'COMMON.CHAIN'
9980 !      include 'COMMON.GEO'
9981 !      include 'COMMON.LOCAL'
9982 !      include 'COMMON.DERIV'
9983       real(kind=8),dimension(6,nres) :: temp
9984       real(kind=8),dimension(3) :: xx,gg
9985       integer :: i,k,j,ii
9986       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
9987 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9988 !
9989 ! Check the gradient of the virtual-bond and SC vectors in the internal
9990 ! coordinates.
9991 !
9992       aincr=1.0d-7
9993       aincr2=5.0d-8
9994       call cartder
9995       write (iout,'(a)') '**************** dx/dalpha'
9996       write (iout,'(a)')
9997       do i=2,nres-1
9998         alphi=alph(i)
9999         alph(i)=alph(i)+aincr
10000         do k=1,3
10001           temp(k,i)=dc(k,nres+i)
10002         enddo
10003         call chainbuild
10004         do k=1,3
10005           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10006           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10007         enddo
10008         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10009         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10010         write (iout,'(a)')
10011         alph(i)=alphi
10012         call chainbuild
10013       enddo
10014       write (iout,'(a)')
10015       write (iout,'(a)') '**************** dx/domega'
10016       write (iout,'(a)')
10017       do i=2,nres-1
10018         omegi=omeg(i)
10019         omeg(i)=omeg(i)+aincr
10020         do k=1,3
10021           temp(k,i)=dc(k,nres+i)
10022         enddo
10023         call chainbuild
10024         do k=1,3
10025           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10026           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10027                 (aincr*dabs(dxds(k+3,i))+aincr))
10028         enddo
10029         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10030             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10031         write (iout,'(a)')
10032         omeg(i)=omegi
10033         call chainbuild
10034       enddo
10035       write (iout,'(a)')
10036       write (iout,'(a)') '**************** dx/dtheta'
10037       write (iout,'(a)')
10038       do i=3,nres
10039         theti=theta(i)
10040         theta(i)=theta(i)+aincr
10041         do j=i-1,nres-1
10042           do k=1,3
10043             temp(k,j)=dc(k,nres+j)
10044           enddo
10045         enddo
10046         call chainbuild
10047         do j=i-1,nres-1
10048           ii = indmat(i-2,j)
10049 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10050           do k=1,3
10051             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10052             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10053                   (aincr*dabs(dxdv(k,ii))+aincr))
10054           enddo
10055           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10056               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10057           write(iout,'(a)')
10058         enddo
10059         write (iout,'(a)')
10060         theta(i)=theti
10061         call chainbuild
10062       enddo
10063       write (iout,'(a)') '***************** dx/dphi'
10064       write (iout,'(a)')
10065       do i=4,nres
10066         phi(i)=phi(i)+aincr
10067         do j=i-1,nres-1
10068           do k=1,3
10069             temp(k,j)=dc(k,nres+j)
10070           enddo
10071         enddo
10072         call chainbuild
10073         do j=i-1,nres-1
10074           ii = indmat(i-2,j)
10075 !         print *,'ii=',ii
10076           do k=1,3
10077             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10078             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10079                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10080           enddo
10081           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10082               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10083           write(iout,'(a)')
10084         enddo
10085         phi(i)=phi(i)-aincr
10086         call chainbuild
10087       enddo
10088       write (iout,'(a)') '****************** ddc/dtheta'
10089       do i=1,nres-2
10090         thet=theta(i+2)
10091         theta(i+2)=thet+aincr
10092         do j=i,nres
10093           do k=1,3
10094             temp(k,j)=dc(k,j)
10095           enddo
10096         enddo
10097         call chainbuild
10098         do j=i+1,nres-1
10099           ii = indmat(i,j)
10100 !         print *,'ii=',ii
10101           do k=1,3
10102             gg(k)=(dc(k,j)-temp(k,j))/aincr
10103             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10104                  (aincr*dabs(dcdv(k,ii))+aincr))
10105           enddo
10106           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10107                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10108           write (iout,'(a)')
10109         enddo
10110         do j=1,nres
10111           do k=1,3
10112             dc(k,j)=temp(k,j)
10113           enddo
10114         enddo
10115         theta(i+2)=thet
10116       enddo
10117       write (iout,'(a)') '******************* ddc/dphi'
10118       do i=1,nres-3
10119         phii=phi(i+3)
10120         phi(i+3)=phii+aincr
10121         do j=1,nres
10122           do k=1,3
10123             temp(k,j)=dc(k,j)
10124           enddo
10125         enddo
10126         call chainbuild
10127         do j=i+2,nres-1
10128           ii = indmat(i+1,j)
10129 !         print *,'ii=',ii
10130           do k=1,3
10131             gg(k)=(dc(k,j)-temp(k,j))/aincr
10132             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10133                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10134           enddo
10135           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10136                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10137           write (iout,'(a)')
10138         enddo
10139         do j=1,nres
10140           do k=1,3
10141             dc(k,j)=temp(k,j)
10142           enddo
10143         enddo
10144         phi(i+3)=phii
10145       enddo
10146       return
10147       end subroutine check_cartgrad
10148 !-----------------------------------------------------------------------------
10149       subroutine check_ecart
10150 ! Check the gradient of the energy in Cartesian coordinates.
10151 !     implicit real*8 (a-h,o-z)
10152 !     include 'DIMENSIONS'
10153 !     include 'COMMON.CHAIN'
10154 !     include 'COMMON.DERIV'
10155 !     include 'COMMON.IOUNITS'
10156 !     include 'COMMON.VAR'
10157 !     include 'COMMON.CONTACTS'
10158       use comm_srutu
10159 !el      integer :: icall
10160 !el      common /srutu/ icall
10161       real(kind=8),dimension(6) :: ggg
10162       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10163       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10164       real(kind=8),dimension(6,nres) :: grad_s
10165       real(kind=8),dimension(0:n_ene) :: energia,energia1
10166       integer :: uiparm(1)
10167       real(kind=8) :: urparm(1)
10168 !EL      external fdum
10169       integer :: nf,i,j,k
10170       real(kind=8) :: aincr,etot,etot1
10171       icg=1
10172       nf=0
10173       nfl=0
10174       call zerograd
10175       aincr=1.0D-7
10176       print '(a)','CG processor',me,' calling CHECK_CART.'
10177       nf=0
10178       icall=0
10179       call geom_to_var(nvar,x)
10180       call etotal(energia)
10181       etot=energia(0)
10182 !el      call enerprint(energia)
10183       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10184       icall =1
10185       do i=1,nres
10186         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10187       enddo
10188       do i=1,nres
10189         do j=1,3
10190           grad_s(j,i)=gradc(j,i,icg)
10191           grad_s(j+3,i)=gradx(j,i,icg)
10192         enddo
10193       enddo
10194       call flush(iout)
10195       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10196       do i=1,nres
10197         do j=1,3
10198           xx(j)=c(j,i+nres)
10199           ddc(j)=dc(j,i)
10200           ddx(j)=dc(j,i+nres)
10201         enddo
10202         do j=1,3
10203           dc(j,i)=dc(j,i)+aincr
10204           do k=i+1,nres
10205             c(j,k)=c(j,k)+aincr
10206             c(j,k+nres)=c(j,k+nres)+aincr
10207           enddo
10208           call etotal(energia1)
10209           etot1=energia1(0)
10210           ggg(j)=(etot1-etot)/aincr
10211           dc(j,i)=ddc(j)
10212           do k=i+1,nres
10213             c(j,k)=c(j,k)-aincr
10214             c(j,k+nres)=c(j,k+nres)-aincr
10215           enddo
10216         enddo
10217         do j=1,3
10218           c(j,i+nres)=c(j,i+nres)+aincr
10219           dc(j,i+nres)=dc(j,i+nres)+aincr
10220           call etotal(energia1)
10221           etot1=energia1(0)
10222           ggg(j+3)=(etot1-etot)/aincr
10223           c(j,i+nres)=xx(j)
10224           dc(j,i+nres)=ddx(j)
10225         enddo
10226         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10227          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10228       enddo
10229       return
10230       end subroutine check_ecart
10231 !-----------------------------------------------------------------------------
10232       subroutine check_ecartint
10233 ! Check the gradient of the energy in Cartesian coordinates.
10234       use io_base, only: intout
10235 !      implicit real*8 (a-h,o-z)
10236 !      include 'DIMENSIONS'
10237 !      include 'COMMON.CONTROL'
10238 !      include 'COMMON.CHAIN'
10239 !      include 'COMMON.DERIV'
10240 !      include 'COMMON.IOUNITS'
10241 !      include 'COMMON.VAR'
10242 !      include 'COMMON.CONTACTS'
10243 !      include 'COMMON.MD'
10244 !      include 'COMMON.LOCAL'
10245 !      include 'COMMON.SPLITELE'
10246       use comm_srutu
10247 !el      integer :: icall
10248 !el      common /srutu/ icall
10249       real(kind=8),dimension(6) :: ggg,ggg1
10250       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10251       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10252       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10253       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10254       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10255       real(kind=8),dimension(0:n_ene) :: energia,energia1
10256       integer :: uiparm(1)
10257       real(kind=8) :: urparm(1)
10258 !EL      external fdum
10259       integer :: i,j,k,nf
10260       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10261                    etot21,etot22
10262       r_cut=2.0d0
10263       rlambd=0.3d0
10264       icg=1
10265       nf=0
10266       nfl=0
10267       call intout
10268 !      call intcartderiv
10269 !      call checkintcartgrad
10270       call zerograd
10271       aincr=1.0D-4
10272       write(iout,*) 'Calling CHECK_ECARTINT.'
10273       nf=0
10274       icall=0
10275       call geom_to_var(nvar,x)
10276       if (.not.split_ene) then
10277         call etotal(energia)
10278         etot=energia(0)
10279 !el        call enerprint(energia)
10280         call flush(iout)
10281         write (iout,*) "enter cartgrad"
10282         call flush(iout)
10283         call cartgrad
10284         write (iout,*) "exit cartgrad"
10285         call flush(iout)
10286         icall =1
10287         do i=1,nres
10288           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10289         enddo
10290         do j=1,3
10291           grad_s(j,0)=gcart(j,0)
10292         enddo
10293         do i=1,nres
10294           do j=1,3
10295             grad_s(j,i)=gcart(j,i)
10296             grad_s(j+3,i)=gxcart(j,i)
10297           enddo
10298         enddo
10299       else
10300 !- split gradient check
10301         call zerograd
10302         call etotal_long(energia)
10303 !el        call enerprint(energia)
10304         call flush(iout)
10305         write (iout,*) "enter cartgrad"
10306         call flush(iout)
10307         call cartgrad
10308         write (iout,*) "exit cartgrad"
10309         call flush(iout)
10310         icall =1
10311         write (iout,*) "longrange grad"
10312         do i=1,nres
10313           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10314           (gxcart(j,i),j=1,3)
10315         enddo
10316         do j=1,3
10317           grad_s(j,0)=gcart(j,0)
10318         enddo
10319         do i=1,nres
10320           do j=1,3
10321             grad_s(j,i)=gcart(j,i)
10322             grad_s(j+3,i)=gxcart(j,i)
10323           enddo
10324         enddo
10325         call zerograd
10326         call etotal_short(energia)
10327 !el        call enerprint(energia)
10328         call flush(iout)
10329         write (iout,*) "enter cartgrad"
10330         call flush(iout)
10331         call cartgrad
10332         write (iout,*) "exit cartgrad"
10333         call flush(iout)
10334         icall =1
10335         write (iout,*) "shortrange grad"
10336         do i=1,nres
10337           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10338           (gxcart(j,i),j=1,3)
10339         enddo
10340         do j=1,3
10341           grad_s1(j,0)=gcart(j,0)
10342         enddo
10343         do i=1,nres
10344           do j=1,3
10345             grad_s1(j,i)=gcart(j,i)
10346             grad_s1(j+3,i)=gxcart(j,i)
10347           enddo
10348         enddo
10349       endif
10350       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10351       do i=0,nres
10352         do j=1,3
10353           xx(j)=c(j,i+nres)
10354           ddc(j)=dc(j,i)
10355           ddx(j)=dc(j,i+nres)
10356           do k=1,3
10357             dcnorm_safe(k)=dc_norm(k,i)
10358             dxnorm_safe(k)=dc_norm(k,i+nres)
10359           enddo
10360         enddo
10361         do j=1,3
10362           dc(j,i)=ddc(j)+aincr
10363           call chainbuild_cart
10364 #ifdef MPI
10365 ! Broadcast the order to compute internal coordinates to the slaves.
10366 !          if (nfgtasks.gt.1)
10367 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10368 #endif
10369 !          call int_from_cart1(.false.)
10370           if (.not.split_ene) then
10371             call etotal(energia1)
10372             etot1=energia1(0)
10373           else
10374 !- split gradient
10375             call etotal_long(energia1)
10376             etot11=energia1(0)
10377             call etotal_short(energia1)
10378             etot12=energia1(0)
10379 !            write (iout,*) "etot11",etot11," etot12",etot12
10380           endif
10381 !- end split gradient
10382 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10383           dc(j,i)=ddc(j)-aincr
10384           call chainbuild_cart
10385 !          call int_from_cart1(.false.)
10386           if (.not.split_ene) then
10387             call etotal(energia1)
10388             etot2=energia1(0)
10389             ggg(j)=(etot1-etot2)/(2*aincr)
10390           else
10391 !- split gradient
10392             call etotal_long(energia1)
10393             etot21=energia1(0)
10394             ggg(j)=(etot11-etot21)/(2*aincr)
10395             call etotal_short(energia1)
10396             etot22=energia1(0)
10397             ggg1(j)=(etot12-etot22)/(2*aincr)
10398 !- end split gradient
10399 !            write (iout,*) "etot21",etot21," etot22",etot22
10400           endif
10401 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10402           dc(j,i)=ddc(j)
10403           call chainbuild_cart
10404         enddo
10405         do j=1,3
10406           dc(j,i+nres)=ddx(j)+aincr
10407           call chainbuild_cart
10408 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10409 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10410 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10411 !          write (iout,*) "dxnormnorm",dsqrt(
10412 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10413 !          write (iout,*) "dxnormnormsafe",dsqrt(
10414 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10415 !          write (iout,*)
10416           if (.not.split_ene) then
10417             call etotal(energia1)
10418             etot1=energia1(0)
10419           else
10420 !- split gradient
10421             call etotal_long(energia1)
10422             etot11=energia1(0)
10423             call etotal_short(energia1)
10424             etot12=energia1(0)
10425           endif
10426 !- end split gradient
10427 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10428           dc(j,i+nres)=ddx(j)-aincr
10429           call chainbuild_cart
10430 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10431 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10432 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10433 !          write (iout,*)
10434 !          write (iout,*) "dxnormnorm",dsqrt(
10435 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10436 !          write (iout,*) "dxnormnormsafe",dsqrt(
10437 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10438           if (.not.split_ene) then
10439             call etotal(energia1)
10440             etot2=energia1(0)
10441             ggg(j+3)=(etot1-etot2)/(2*aincr)
10442           else
10443 !- split gradient
10444             call etotal_long(energia1)
10445             etot21=energia1(0)
10446             ggg(j+3)=(etot11-etot21)/(2*aincr)
10447             call etotal_short(energia1)
10448             etot22=energia1(0)
10449             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10450 !- end split gradient
10451           endif
10452 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10453           dc(j,i+nres)=ddx(j)
10454           call chainbuild_cart
10455         enddo
10456         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10457          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10458         if (split_ene) then
10459           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10460          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10461          k=1,6)
10462          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10463          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10464          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10465         endif
10466       enddo
10467       return
10468       end subroutine check_ecartint
10469 !-----------------------------------------------------------------------------
10470       subroutine check_eint
10471 ! Check the gradient of energy in internal coordinates.
10472 !      implicit real*8 (a-h,o-z)
10473 !      include 'DIMENSIONS'
10474 !      include 'COMMON.CHAIN'
10475 !      include 'COMMON.DERIV'
10476 !      include 'COMMON.IOUNITS'
10477 !      include 'COMMON.VAR'
10478 !      include 'COMMON.GEO'
10479       use comm_srutu
10480 !el      integer :: icall
10481 !el      common /srutu/ icall
10482       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10483       integer :: uiparm(1)
10484       real(kind=8) :: urparm(1)
10485       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10486       character(len=6) :: key
10487 !EL      external fdum
10488       integer :: i,ii,nf
10489       real(kind=8) :: xi,aincr,etot,etot1,etot2
10490       call zerograd
10491       aincr=1.0D-7
10492       print '(a)','Calling CHECK_INT.'
10493       nf=0
10494       nfl=0
10495       icg=1
10496       call geom_to_var(nvar,x)
10497       call var_to_geom(nvar,x)
10498       call chainbuild
10499       icall=1
10500       print *,'ICG=',ICG
10501       call etotal(energia)
10502       etot = energia(0)
10503 !el      call enerprint(energia)
10504       print *,'ICG=',ICG
10505 #ifdef MPL
10506       if (MyID.ne.BossID) then
10507         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10508         nf=x(nvar+1)
10509         nfl=x(nvar+2)
10510         icg=x(nvar+3)
10511       endif
10512 #endif
10513       nf=1
10514       nfl=3
10515 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10516       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10517 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10518       icall=1
10519       do i=1,nvar
10520         xi=x(i)
10521         x(i)=xi-0.5D0*aincr
10522         call var_to_geom(nvar,x)
10523         call chainbuild
10524         call etotal(energia1)
10525         etot1=energia1(0)
10526         x(i)=xi+0.5D0*aincr
10527         call var_to_geom(nvar,x)
10528         call chainbuild
10529         call etotal(energia2)
10530         etot2=energia2(0)
10531         gg(i)=(etot2-etot1)/aincr
10532         write (iout,*) i,etot1,etot2
10533         x(i)=xi
10534       enddo
10535       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10536           '     RelDiff*100% '
10537       do i=1,nvar
10538         if (i.le.nphi) then
10539           ii=i
10540           key = ' phi'
10541         else if (i.le.nphi+ntheta) then
10542           ii=i-nphi
10543           key=' theta'
10544         else if (i.le.nphi+ntheta+nside) then
10545            ii=i-(nphi+ntheta)
10546            key=' alpha'
10547         else
10548            ii=i-(nphi+ntheta+nside)
10549            key=' omega'
10550         endif
10551         write (iout,'(i3,a,i3,3(1pd16.6))') &
10552        i,key,ii,gg(i),gana(i),&
10553        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10554       enddo
10555       return
10556       end subroutine check_eint
10557 !-----------------------------------------------------------------------------
10558 ! econstr_local.F
10559 !-----------------------------------------------------------------------------
10560       subroutine Econstr_back
10561 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10562 !      implicit real*8 (a-h,o-z)
10563 !      include 'DIMENSIONS'
10564 !      include 'COMMON.CONTROL'
10565 !      include 'COMMON.VAR'
10566 !      include 'COMMON.MD'
10567       use MD_data
10568 !#ifndef LANG0
10569 !      include 'COMMON.LANGEVIN'
10570 !#else
10571 !      include 'COMMON.LANGEVIN.lang0'
10572 !#endif
10573 !      include 'COMMON.CHAIN'
10574 !      include 'COMMON.DERIV'
10575 !      include 'COMMON.GEO'
10576 !      include 'COMMON.LOCAL'
10577 !      include 'COMMON.INTERACT'
10578 !      include 'COMMON.IOUNITS'
10579 !      include 'COMMON.NAMES'
10580 !      include 'COMMON.TIME1'
10581       integer :: i,j,ii,k
10582       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10583
10584       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10585       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10586       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10587
10588       Uconst_back=0.0d0
10589       do i=1,nres
10590         dutheta(i)=0.0d0
10591         dugamma(i)=0.0d0
10592         do j=1,3
10593           duscdiff(j,i)=0.0d0
10594           duscdiffx(j,i)=0.0d0
10595         enddo
10596       enddo
10597       do i=1,nfrag_back
10598         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10599 !
10600 ! Deviations from theta angles
10601 !
10602         utheta_i=0.0d0
10603         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10604           dtheta_i=theta(j)-thetaref(j)
10605           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10606           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10607         enddo
10608         utheta(i)=utheta_i/(ii-1)
10609 !
10610 ! Deviations from gamma angles
10611 !
10612         ugamma_i=0.0d0
10613         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10614           dgamma_i=pinorm(phi(j)-phiref(j))
10615 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10616           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10617           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10618 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10619         enddo
10620         ugamma(i)=ugamma_i/(ii-2)
10621 !
10622 ! Deviations from local SC geometry
10623 !
10624         uscdiff(i)=0.0d0
10625         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10626           dxx=xxtab(j)-xxref(j)
10627           dyy=yytab(j)-yyref(j)
10628           dzz=zztab(j)-zzref(j)
10629           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10630           do k=1,3
10631             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10632              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10633              (ii-1)
10634             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10635              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10636              (ii-1)
10637             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10638            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10639             /(ii-1)
10640           enddo
10641 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10642 !     &      xxref(j),yyref(j),zzref(j)
10643         enddo
10644         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10645 !        write (iout,*) i," uscdiff",uscdiff(i)
10646 !
10647 ! Put together deviations from local geometry
10648 !
10649         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10650           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10651 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10652 !     &   " uconst_back",uconst_back
10653         utheta(i)=dsqrt(utheta(i))
10654         ugamma(i)=dsqrt(ugamma(i))
10655         uscdiff(i)=dsqrt(uscdiff(i))
10656       enddo
10657       return
10658       end subroutine Econstr_back
10659 !-----------------------------------------------------------------------------
10660 ! energy_p_new-sep_barrier.F
10661 !-----------------------------------------------------------------------------
10662       real(kind=8) function sscale(r)
10663 !      include "COMMON.SPLITELE"
10664       real(kind=8) :: r,gamm
10665       if(r.lt.r_cut-rlamb) then
10666         sscale=1.0d0
10667       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10668         gamm=(r-(r_cut-rlamb))/rlamb
10669         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10670       else
10671         sscale=0d0
10672       endif
10673       return
10674       end function sscale
10675 !-----------------------------------------------------------------------------
10676       subroutine elj_long(evdw)
10677 !
10678 ! This subroutine calculates the interaction energy of nonbonded side chains
10679 ! assuming the LJ potential of interaction.
10680 !
10681 !      implicit real*8 (a-h,o-z)
10682 !      include 'DIMENSIONS'
10683 !      include 'COMMON.GEO'
10684 !      include 'COMMON.VAR'
10685 !      include 'COMMON.LOCAL'
10686 !      include 'COMMON.CHAIN'
10687 !      include 'COMMON.DERIV'
10688 !      include 'COMMON.INTERACT'
10689 !      include 'COMMON.TORSION'
10690 !      include 'COMMON.SBRIDGE'
10691 !      include 'COMMON.NAMES'
10692 !      include 'COMMON.IOUNITS'
10693 !      include 'COMMON.CONTACTS'
10694       real(kind=8),parameter :: accur=1.0d-10
10695       real(kind=8),dimension(3) :: gg
10696 !el local variables
10697       integer :: i,iint,j,k,itypi,itypi1,itypj
10698       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10699       real(kind=8) :: e1,e2,evdwij,evdw
10700 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10701       evdw=0.0D0
10702       do i=iatsc_s,iatsc_e
10703         itypi=itype(i)
10704         if (itypi.eq.ntyp1) cycle
10705         itypi1=itype(i+1)
10706         xi=c(1,nres+i)
10707         yi=c(2,nres+i)
10708         zi=c(3,nres+i)
10709 !
10710 ! Calculate SC interaction energy.
10711 !
10712         do iint=1,nint_gr(i)
10713 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10714 !d   &                  'iend=',iend(i,iint)
10715           do j=istart(i,iint),iend(i,iint)
10716             itypj=itype(j)
10717             if (itypj.eq.ntyp1) cycle
10718             xj=c(1,nres+j)-xi
10719             yj=c(2,nres+j)-yi
10720             zj=c(3,nres+j)-zi
10721             rij=xj*xj+yj*yj+zj*zj
10722             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10723             if (sss.lt.1.0d0) then
10724               rrij=1.0D0/rij
10725               eps0ij=eps(itypi,itypj)
10726               fac=rrij**expon2
10727               e1=fac*fac*aa(itypi,itypj)
10728               e2=fac*bb(itypi,itypj)
10729               evdwij=e1+e2
10730               evdw=evdw+(1.0d0-sss)*evdwij
10731 !
10732 ! Calculate the components of the gradient in DC and X
10733 !
10734               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
10735               gg(1)=xj*fac
10736               gg(2)=yj*fac
10737               gg(3)=zj*fac
10738               do k=1,3
10739                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10740                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10741                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10742                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10743               enddo
10744             endif
10745           enddo      ! j
10746         enddo        ! iint
10747       enddo          ! i
10748       do i=1,nct
10749         do j=1,3
10750           gvdwc(j,i)=expon*gvdwc(j,i)
10751           gvdwx(j,i)=expon*gvdwx(j,i)
10752         enddo
10753       enddo
10754 !******************************************************************************
10755 !
10756 !                              N O T E !!!
10757 !
10758 ! To save time, the factor of EXPON has been extracted from ALL components
10759 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10760 ! use!
10761 !
10762 !******************************************************************************
10763       return
10764       end subroutine elj_long
10765 !-----------------------------------------------------------------------------
10766       subroutine elj_short(evdw)
10767 !
10768 ! This subroutine calculates the interaction energy of nonbonded side chains
10769 ! assuming the LJ potential of interaction.
10770 !
10771 !      implicit real*8 (a-h,o-z)
10772 !      include 'DIMENSIONS'
10773 !      include 'COMMON.GEO'
10774 !      include 'COMMON.VAR'
10775 !      include 'COMMON.LOCAL'
10776 !      include 'COMMON.CHAIN'
10777 !      include 'COMMON.DERIV'
10778 !      include 'COMMON.INTERACT'
10779 !      include 'COMMON.TORSION'
10780 !      include 'COMMON.SBRIDGE'
10781 !      include 'COMMON.NAMES'
10782 !      include 'COMMON.IOUNITS'
10783 !      include 'COMMON.CONTACTS'
10784       real(kind=8),parameter :: accur=1.0d-10
10785       real(kind=8),dimension(3) :: gg
10786 !el local variables
10787       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
10788       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10789       real(kind=8) :: e1,e2,evdwij,evdw
10790 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10791       evdw=0.0D0
10792       do i=iatsc_s,iatsc_e
10793         itypi=itype(i)
10794         if (itypi.eq.ntyp1) cycle
10795         itypi1=itype(i+1)
10796         xi=c(1,nres+i)
10797         yi=c(2,nres+i)
10798         zi=c(3,nres+i)
10799 ! Change 12/1/95
10800         num_conti=0
10801 !
10802 ! Calculate SC interaction energy.
10803 !
10804         do iint=1,nint_gr(i)
10805 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10806 !d   &                  'iend=',iend(i,iint)
10807           do j=istart(i,iint),iend(i,iint)
10808             itypj=itype(j)
10809             if (itypj.eq.ntyp1) cycle
10810             xj=c(1,nres+j)-xi
10811             yj=c(2,nres+j)-yi
10812             zj=c(3,nres+j)-zi
10813 ! Change 12/1/95 to calculate four-body interactions
10814             rij=xj*xj+yj*yj+zj*zj
10815             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10816             if (sss.gt.0.0d0) then
10817               rrij=1.0D0/rij
10818               eps0ij=eps(itypi,itypj)
10819               fac=rrij**expon2
10820               e1=fac*fac*aa(itypi,itypj)
10821               e2=fac*bb(itypi,itypj)
10822               evdwij=e1+e2
10823               evdw=evdw+sss*evdwij
10824 !
10825 ! Calculate the components of the gradient in DC and X
10826 !
10827               fac=-rrij*(e1+evdwij)*sss
10828               gg(1)=xj*fac
10829               gg(2)=yj*fac
10830               gg(3)=zj*fac
10831               do k=1,3
10832                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10833                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10834                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10835                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10836               enddo
10837             endif
10838           enddo      ! j
10839         enddo        ! iint
10840       enddo          ! i
10841       do i=1,nct
10842         do j=1,3
10843           gvdwc(j,i)=expon*gvdwc(j,i)
10844           gvdwx(j,i)=expon*gvdwx(j,i)
10845         enddo
10846       enddo
10847 !******************************************************************************
10848 !
10849 !                              N O T E !!!
10850 !
10851 ! To save time, the factor of EXPON has been extracted from ALL components
10852 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10853 ! use!
10854 !
10855 !******************************************************************************
10856       return
10857       end subroutine elj_short
10858 !-----------------------------------------------------------------------------
10859       subroutine eljk_long(evdw)
10860 !
10861 ! This subroutine calculates the interaction energy of nonbonded side chains
10862 ! assuming the LJK potential of interaction.
10863 !
10864 !      implicit real*8 (a-h,o-z)
10865 !      include 'DIMENSIONS'
10866 !      include 'COMMON.GEO'
10867 !      include 'COMMON.VAR'
10868 !      include 'COMMON.LOCAL'
10869 !      include 'COMMON.CHAIN'
10870 !      include 'COMMON.DERIV'
10871 !      include 'COMMON.INTERACT'
10872 !      include 'COMMON.IOUNITS'
10873 !      include 'COMMON.NAMES'
10874       real(kind=8),dimension(3) :: gg
10875       logical :: scheck
10876 !el local variables
10877       integer :: i,iint,j,k,itypi,itypi1,itypj
10878       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10879                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10880 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10881       evdw=0.0D0
10882       do i=iatsc_s,iatsc_e
10883         itypi=itype(i)
10884         if (itypi.eq.ntyp1) cycle
10885         itypi1=itype(i+1)
10886         xi=c(1,nres+i)
10887         yi=c(2,nres+i)
10888         zi=c(3,nres+i)
10889 !
10890 ! Calculate SC interaction energy.
10891 !
10892         do iint=1,nint_gr(i)
10893           do j=istart(i,iint),iend(i,iint)
10894             itypj=itype(j)
10895             if (itypj.eq.ntyp1) cycle
10896             xj=c(1,nres+j)-xi
10897             yj=c(2,nres+j)-yi
10898             zj=c(3,nres+j)-zi
10899             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10900             fac_augm=rrij**expon
10901             e_augm=augm(itypi,itypj)*fac_augm
10902             r_inv_ij=dsqrt(rrij)
10903             rij=1.0D0/r_inv_ij
10904             sss=sscale(rij/sigma(itypi,itypj))
10905             if (sss.lt.1.0d0) then
10906               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10907               fac=r_shift_inv**expon
10908               e1=fac*fac*aa(itypi,itypj)
10909               e2=fac*bb(itypi,itypj)
10910               evdwij=e_augm+e1+e2
10911 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10912 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10913 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10914 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10915 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10916 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10917 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10918               evdw=evdw+(1.0d0-sss)*evdwij
10919 !
10920 ! Calculate the components of the gradient in DC and X
10921 !
10922               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10923               fac=fac*(1.0d0-sss)
10924               gg(1)=xj*fac
10925               gg(2)=yj*fac
10926               gg(3)=zj*fac
10927               do k=1,3
10928                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10929                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10930                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10931                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10932               enddo
10933             endif
10934           enddo      ! j
10935         enddo        ! iint
10936       enddo          ! i
10937       do i=1,nct
10938         do j=1,3
10939           gvdwc(j,i)=expon*gvdwc(j,i)
10940           gvdwx(j,i)=expon*gvdwx(j,i)
10941         enddo
10942       enddo
10943       return
10944       end subroutine eljk_long
10945 !-----------------------------------------------------------------------------
10946       subroutine eljk_short(evdw)
10947 !
10948 ! This subroutine calculates the interaction energy of nonbonded side chains
10949 ! assuming the LJK potential of interaction.
10950 !
10951 !      implicit real*8 (a-h,o-z)
10952 !      include 'DIMENSIONS'
10953 !      include 'COMMON.GEO'
10954 !      include 'COMMON.VAR'
10955 !      include 'COMMON.LOCAL'
10956 !      include 'COMMON.CHAIN'
10957 !      include 'COMMON.DERIV'
10958 !      include 'COMMON.INTERACT'
10959 !      include 'COMMON.IOUNITS'
10960 !      include 'COMMON.NAMES'
10961       real(kind=8),dimension(3) :: gg
10962       logical :: scheck
10963 !el local variables
10964       integer :: i,iint,j,k,itypi,itypi1,itypj
10965       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10966                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10967 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10968       evdw=0.0D0
10969       do i=iatsc_s,iatsc_e
10970         itypi=itype(i)
10971         if (itypi.eq.ntyp1) cycle
10972         itypi1=itype(i+1)
10973         xi=c(1,nres+i)
10974         yi=c(2,nres+i)
10975         zi=c(3,nres+i)
10976 !
10977 ! Calculate SC interaction energy.
10978 !
10979         do iint=1,nint_gr(i)
10980           do j=istart(i,iint),iend(i,iint)
10981             itypj=itype(j)
10982             if (itypj.eq.ntyp1) cycle
10983             xj=c(1,nres+j)-xi
10984             yj=c(2,nres+j)-yi
10985             zj=c(3,nres+j)-zi
10986             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10987             fac_augm=rrij**expon
10988             e_augm=augm(itypi,itypj)*fac_augm
10989             r_inv_ij=dsqrt(rrij)
10990             rij=1.0D0/r_inv_ij
10991             sss=sscale(rij/sigma(itypi,itypj))
10992             if (sss.gt.0.0d0) then
10993               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10994               fac=r_shift_inv**expon
10995               e1=fac*fac*aa(itypi,itypj)
10996               e2=fac*bb(itypi,itypj)
10997               evdwij=e_augm+e1+e2
10998 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10999 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11000 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11001 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11002 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11003 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11004 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11005               evdw=evdw+sss*evdwij
11006 !
11007 ! Calculate the components of the gradient in DC and X
11008 !
11009               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11010               fac=fac*sss
11011               gg(1)=xj*fac
11012               gg(2)=yj*fac
11013               gg(3)=zj*fac
11014               do k=1,3
11015                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11016                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11017                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11018                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11019               enddo
11020             endif
11021           enddo      ! j
11022         enddo        ! iint
11023       enddo          ! i
11024       do i=1,nct
11025         do j=1,3
11026           gvdwc(j,i)=expon*gvdwc(j,i)
11027           gvdwx(j,i)=expon*gvdwx(j,i)
11028         enddo
11029       enddo
11030       return
11031       end subroutine eljk_short
11032 !-----------------------------------------------------------------------------
11033       subroutine ebp_long(evdw)
11034 !
11035 ! This subroutine calculates the interaction energy of nonbonded side chains
11036 ! assuming the Berne-Pechukas potential of interaction.
11037 !
11038       use calc_data
11039 !      implicit real*8 (a-h,o-z)
11040 !      include 'DIMENSIONS'
11041 !      include 'COMMON.GEO'
11042 !      include 'COMMON.VAR'
11043 !      include 'COMMON.LOCAL'
11044 !      include 'COMMON.CHAIN'
11045 !      include 'COMMON.DERIV'
11046 !      include 'COMMON.NAMES'
11047 !      include 'COMMON.INTERACT'
11048 !      include 'COMMON.IOUNITS'
11049 !      include 'COMMON.CALC'
11050       use comm_srutu
11051 !el      integer :: icall
11052 !el      common /srutu/ icall
11053 !     double precision rrsave(maxdim)
11054       logical :: lprn
11055 !el local variables
11056       integer :: iint,itypi,itypi1,itypj
11057       real(kind=8) :: rrij,xi,yi,zi,fac
11058       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11059       evdw=0.0D0
11060 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11061       evdw=0.0D0
11062 !     if (icall.eq.0) then
11063 !       lprn=.true.
11064 !     else
11065         lprn=.false.
11066 !     endif
11067 !el      ind=0
11068       do i=iatsc_s,iatsc_e
11069         itypi=itype(i)
11070         if (itypi.eq.ntyp1) cycle
11071         itypi1=itype(i+1)
11072         xi=c(1,nres+i)
11073         yi=c(2,nres+i)
11074         zi=c(3,nres+i)
11075         dxi=dc_norm(1,nres+i)
11076         dyi=dc_norm(2,nres+i)
11077         dzi=dc_norm(3,nres+i)
11078 !        dsci_inv=dsc_inv(itypi)
11079         dsci_inv=vbld_inv(i+nres)
11080 !
11081 ! Calculate SC interaction energy.
11082 !
11083         do iint=1,nint_gr(i)
11084           do j=istart(i,iint),iend(i,iint)
11085 !el            ind=ind+1
11086             itypj=itype(j)
11087             if (itypj.eq.ntyp1) cycle
11088 !            dscj_inv=dsc_inv(itypj)
11089             dscj_inv=vbld_inv(j+nres)
11090             chi1=chi(itypi,itypj)
11091             chi2=chi(itypj,itypi)
11092             chi12=chi1*chi2
11093             chip1=chip(itypi)
11094             chip2=chip(itypj)
11095             chip12=chip1*chip2
11096             alf1=alp(itypi)
11097             alf2=alp(itypj)
11098             alf12=0.5D0*(alf1+alf2)
11099             xj=c(1,nres+j)-xi
11100             yj=c(2,nres+j)-yi
11101             zj=c(3,nres+j)-zi
11102             dxj=dc_norm(1,nres+j)
11103             dyj=dc_norm(2,nres+j)
11104             dzj=dc_norm(3,nres+j)
11105             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11106             rij=dsqrt(rrij)
11107             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11108
11109             if (sss.lt.1.0d0) then
11110
11111 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11112               call sc_angular
11113 ! Calculate whole angle-dependent part of epsilon and contributions
11114 ! to its derivatives
11115               fac=(rrij*sigsq)**expon2
11116               e1=fac*fac*aa(itypi,itypj)
11117               e2=fac*bb(itypi,itypj)
11118               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11119               eps2der=evdwij*eps3rt
11120               eps3der=evdwij*eps2rt
11121               evdwij=evdwij*eps2rt*eps3rt
11122               evdw=evdw+evdwij*(1.0d0-sss)
11123               if (lprn) then
11124               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11125               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11126 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11127 !d     &          restyp(itypi),i,restyp(itypj),j,
11128 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11129 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11130 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11131 !d     &          evdwij
11132               endif
11133 ! Calculate gradient components.
11134               e1=e1*eps1*eps2rt**2*eps3rt**2
11135               fac=-expon*(e1+evdwij)
11136               sigder=fac/sigsq
11137               fac=rrij*fac
11138 ! Calculate radial part of the gradient
11139               gg(1)=xj*fac
11140               gg(2)=yj*fac
11141               gg(3)=zj*fac
11142 ! Calculate the angular part of the gradient and sum add the contributions
11143 ! to the appropriate components of the Cartesian gradient.
11144               call sc_grad_scale(1.0d0-sss)
11145             endif
11146           enddo      ! j
11147         enddo        ! iint
11148       enddo          ! i
11149 !     stop
11150       return
11151       end subroutine ebp_long
11152 !-----------------------------------------------------------------------------
11153       subroutine ebp_short(evdw)
11154 !
11155 ! This subroutine calculates the interaction energy of nonbonded side chains
11156 ! assuming the Berne-Pechukas potential of interaction.
11157 !
11158       use calc_data
11159 !      implicit real*8 (a-h,o-z)
11160 !      include 'DIMENSIONS'
11161 !      include 'COMMON.GEO'
11162 !      include 'COMMON.VAR'
11163 !      include 'COMMON.LOCAL'
11164 !      include 'COMMON.CHAIN'
11165 !      include 'COMMON.DERIV'
11166 !      include 'COMMON.NAMES'
11167 !      include 'COMMON.INTERACT'
11168 !      include 'COMMON.IOUNITS'
11169 !      include 'COMMON.CALC'
11170       use comm_srutu
11171 !el      integer :: icall
11172 !el      common /srutu/ icall
11173 !     double precision rrsave(maxdim)
11174       logical :: lprn
11175 !el local variables
11176       integer :: iint,itypi,itypi1,itypj
11177       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11178       real(kind=8) :: sss,e1,e2,evdw
11179       evdw=0.0D0
11180 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11181       evdw=0.0D0
11182 !     if (icall.eq.0) then
11183 !       lprn=.true.
11184 !     else
11185         lprn=.false.
11186 !     endif
11187 !el      ind=0
11188       do i=iatsc_s,iatsc_e
11189         itypi=itype(i)
11190         if (itypi.eq.ntyp1) cycle
11191         itypi1=itype(i+1)
11192         xi=c(1,nres+i)
11193         yi=c(2,nres+i)
11194         zi=c(3,nres+i)
11195         dxi=dc_norm(1,nres+i)
11196         dyi=dc_norm(2,nres+i)
11197         dzi=dc_norm(3,nres+i)
11198 !        dsci_inv=dsc_inv(itypi)
11199         dsci_inv=vbld_inv(i+nres)
11200 !
11201 ! Calculate SC interaction energy.
11202 !
11203         do iint=1,nint_gr(i)
11204           do j=istart(i,iint),iend(i,iint)
11205 !el            ind=ind+1
11206             itypj=itype(j)
11207             if (itypj.eq.ntyp1) cycle
11208 !            dscj_inv=dsc_inv(itypj)
11209             dscj_inv=vbld_inv(j+nres)
11210             chi1=chi(itypi,itypj)
11211             chi2=chi(itypj,itypi)
11212             chi12=chi1*chi2
11213             chip1=chip(itypi)
11214             chip2=chip(itypj)
11215             chip12=chip1*chip2
11216             alf1=alp(itypi)
11217             alf2=alp(itypj)
11218             alf12=0.5D0*(alf1+alf2)
11219             xj=c(1,nres+j)-xi
11220             yj=c(2,nres+j)-yi
11221             zj=c(3,nres+j)-zi
11222             dxj=dc_norm(1,nres+j)
11223             dyj=dc_norm(2,nres+j)
11224             dzj=dc_norm(3,nres+j)
11225             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11226             rij=dsqrt(rrij)
11227             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11228
11229             if (sss.gt.0.0d0) then
11230
11231 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11232               call sc_angular
11233 ! Calculate whole angle-dependent part of epsilon and contributions
11234 ! to its derivatives
11235               fac=(rrij*sigsq)**expon2
11236               e1=fac*fac*aa(itypi,itypj)
11237               e2=fac*bb(itypi,itypj)
11238               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11239               eps2der=evdwij*eps3rt
11240               eps3der=evdwij*eps2rt
11241               evdwij=evdwij*eps2rt*eps3rt
11242               evdw=evdw+evdwij*sss
11243               if (lprn) then
11244               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11245               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11246 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11247 !d     &          restyp(itypi),i,restyp(itypj),j,
11248 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11249 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11250 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11251 !d     &          evdwij
11252               endif
11253 ! Calculate gradient components.
11254               e1=e1*eps1*eps2rt**2*eps3rt**2
11255               fac=-expon*(e1+evdwij)
11256               sigder=fac/sigsq
11257               fac=rrij*fac
11258 ! Calculate radial part of the gradient
11259               gg(1)=xj*fac
11260               gg(2)=yj*fac
11261               gg(3)=zj*fac
11262 ! Calculate the angular part of the gradient and sum add the contributions
11263 ! to the appropriate components of the Cartesian gradient.
11264               call sc_grad_scale(sss)
11265             endif
11266           enddo      ! j
11267         enddo        ! iint
11268       enddo          ! i
11269 !     stop
11270       return
11271       end subroutine ebp_short
11272 !-----------------------------------------------------------------------------
11273       subroutine egb_long(evdw)
11274 !
11275 ! This subroutine calculates the interaction energy of nonbonded side chains
11276 ! assuming the Gay-Berne potential of interaction.
11277 !
11278       use calc_data
11279 !      implicit real*8 (a-h,o-z)
11280 !      include 'DIMENSIONS'
11281 !      include 'COMMON.GEO'
11282 !      include 'COMMON.VAR'
11283 !      include 'COMMON.LOCAL'
11284 !      include 'COMMON.CHAIN'
11285 !      include 'COMMON.DERIV'
11286 !      include 'COMMON.NAMES'
11287 !      include 'COMMON.INTERACT'
11288 !      include 'COMMON.IOUNITS'
11289 !      include 'COMMON.CALC'
11290 !      include 'COMMON.CONTROL'
11291       logical :: lprn
11292 !el local variables
11293       integer :: iint,itypi,itypi1,itypj
11294       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11295       real(kind=8) :: sss,e1,e2,evdw
11296       evdw=0.0D0
11297 !cccc      energy_dec=.false.
11298 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11299       evdw=0.0D0
11300       lprn=.false.
11301 !     if (icall.eq.0) lprn=.false.
11302 !el      ind=0
11303       do i=iatsc_s,iatsc_e
11304         itypi=itype(i)
11305         if (itypi.eq.ntyp1) cycle
11306         itypi1=itype(i+1)
11307         xi=c(1,nres+i)
11308         yi=c(2,nres+i)
11309         zi=c(3,nres+i)
11310         dxi=dc_norm(1,nres+i)
11311         dyi=dc_norm(2,nres+i)
11312         dzi=dc_norm(3,nres+i)
11313 !        dsci_inv=dsc_inv(itypi)
11314         dsci_inv=vbld_inv(i+nres)
11315 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11316 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11317 !
11318 ! Calculate SC interaction energy.
11319 !
11320         do iint=1,nint_gr(i)
11321           do j=istart(i,iint),iend(i,iint)
11322 !el            ind=ind+1
11323             itypj=itype(j)
11324             if (itypj.eq.ntyp1) cycle
11325 !            dscj_inv=dsc_inv(itypj)
11326             dscj_inv=vbld_inv(j+nres)
11327 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11328 !     &       1.0d0/vbld(j+nres)
11329 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11330             sig0ij=sigma(itypi,itypj)
11331             chi1=chi(itypi,itypj)
11332             chi2=chi(itypj,itypi)
11333             chi12=chi1*chi2
11334             chip1=chip(itypi)
11335             chip2=chip(itypj)
11336             chip12=chip1*chip2
11337             alf1=alp(itypi)
11338             alf2=alp(itypj)
11339             alf12=0.5D0*(alf1+alf2)
11340             xj=c(1,nres+j)-xi
11341             yj=c(2,nres+j)-yi
11342             zj=c(3,nres+j)-zi
11343             dxj=dc_norm(1,nres+j)
11344             dyj=dc_norm(2,nres+j)
11345             dzj=dc_norm(3,nres+j)
11346             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11347             rij=dsqrt(rrij)
11348             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11349
11350             if (sss.lt.1.0d0) then
11351
11352 ! Calculate angle-dependent terms of energy and contributions to their
11353 ! derivatives.
11354               call sc_angular
11355               sigsq=1.0D0/sigsq
11356               sig=sig0ij*dsqrt(sigsq)
11357               rij_shift=1.0D0/rij-sig+sig0ij
11358 ! for diagnostics; uncomment
11359 !              rij_shift=1.2*sig0ij
11360 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11361               if (rij_shift.le.0.0D0) then
11362                 evdw=1.0D20
11363 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11364 !d     &          restyp(itypi),i,restyp(itypj),j,
11365 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11366                 return
11367               endif
11368               sigder=-sig*sigsq
11369 !---------------------------------------------------------------
11370               rij_shift=1.0D0/rij_shift
11371               fac=rij_shift**expon
11372               e1=fac*fac*aa(itypi,itypj)
11373               e2=fac*bb(itypi,itypj)
11374               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11375               eps2der=evdwij*eps3rt
11376               eps3der=evdwij*eps2rt
11377 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11378 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11379               evdwij=evdwij*eps2rt*eps3rt
11380               evdw=evdw+evdwij*(1.0d0-sss)
11381               if (lprn) then
11382               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11383               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11384               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11385                 restyp(itypi),i,restyp(itypj),j,&
11386                 epsi,sigm,chi1,chi2,chip1,chip2,&
11387                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11388                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11389                 evdwij
11390               endif
11391
11392               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11393                               'evdw',i,j,evdwij
11394 !              if (energy_dec) write (iout,*) &
11395 !                              'evdw',i,j,evdwij,"egb_long"
11396
11397 ! Calculate gradient components.
11398               e1=e1*eps1*eps2rt**2*eps3rt**2
11399               fac=-expon*(e1+evdwij)*rij_shift
11400               sigder=fac*sigder
11401               fac=rij*fac
11402 !              fac=0.0d0
11403 ! Calculate the radial part of the gradient
11404               gg(1)=xj*fac
11405               gg(2)=yj*fac
11406               gg(3)=zj*fac
11407 ! Calculate angular part of the gradient.
11408               call sc_grad_scale(1.0d0-sss)
11409             endif
11410           enddo      ! j
11411         enddo        ! iint
11412       enddo          ! i
11413 !      write (iout,*) "Number of loop steps in EGB:",ind
11414 !ccc      energy_dec=.false.
11415       return
11416       end subroutine egb_long
11417 !-----------------------------------------------------------------------------
11418       subroutine egb_short(evdw)
11419 !
11420 ! This subroutine calculates the interaction energy of nonbonded side chains
11421 ! assuming the Gay-Berne potential of interaction.
11422 !
11423       use calc_data
11424 !      implicit real*8 (a-h,o-z)
11425 !      include 'DIMENSIONS'
11426 !      include 'COMMON.GEO'
11427 !      include 'COMMON.VAR'
11428 !      include 'COMMON.LOCAL'
11429 !      include 'COMMON.CHAIN'
11430 !      include 'COMMON.DERIV'
11431 !      include 'COMMON.NAMES'
11432 !      include 'COMMON.INTERACT'
11433 !      include 'COMMON.IOUNITS'
11434 !      include 'COMMON.CALC'
11435 !      include 'COMMON.CONTROL'
11436       logical :: lprn
11437 !el local variables
11438       integer :: iint,itypi,itypi1,itypj
11439       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11440       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11441       evdw=0.0D0
11442 !cccc      energy_dec=.false.
11443 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11444       evdw=0.0D0
11445       lprn=.false.
11446 !     if (icall.eq.0) lprn=.false.
11447 !el      ind=0
11448       do i=iatsc_s,iatsc_e
11449         itypi=itype(i)
11450         if (itypi.eq.ntyp1) cycle
11451         itypi1=itype(i+1)
11452         xi=c(1,nres+i)
11453         yi=c(2,nres+i)
11454         zi=c(3,nres+i)
11455         dxi=dc_norm(1,nres+i)
11456         dyi=dc_norm(2,nres+i)
11457         dzi=dc_norm(3,nres+i)
11458 !        dsci_inv=dsc_inv(itypi)
11459         dsci_inv=vbld_inv(i+nres)
11460 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11461 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11462 !
11463 ! Calculate SC interaction energy.
11464 !
11465         do iint=1,nint_gr(i)
11466           do j=istart(i,iint),iend(i,iint)
11467 !el            ind=ind+1
11468             itypj=itype(j)
11469             if (itypj.eq.ntyp1) cycle
11470 !            dscj_inv=dsc_inv(itypj)
11471             dscj_inv=vbld_inv(j+nres)
11472 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11473 !     &       1.0d0/vbld(j+nres)
11474 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11475             sig0ij=sigma(itypi,itypj)
11476             chi1=chi(itypi,itypj)
11477             chi2=chi(itypj,itypi)
11478             chi12=chi1*chi2
11479             chip1=chip(itypi)
11480             chip2=chip(itypj)
11481             chip12=chip1*chip2
11482             alf1=alp(itypi)
11483             alf2=alp(itypj)
11484             alf12=0.5D0*(alf1+alf2)
11485             xj=c(1,nres+j)-xi
11486             yj=c(2,nres+j)-yi
11487             zj=c(3,nres+j)-zi
11488             dxj=dc_norm(1,nres+j)
11489             dyj=dc_norm(2,nres+j)
11490             dzj=dc_norm(3,nres+j)
11491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11492             rij=dsqrt(rrij)
11493             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11494
11495             if (sss.gt.0.0d0) then
11496
11497 ! Calculate angle-dependent terms of energy and contributions to their
11498 ! derivatives.
11499               call sc_angular
11500               sigsq=1.0D0/sigsq
11501               sig=sig0ij*dsqrt(sigsq)
11502               rij_shift=1.0D0/rij-sig+sig0ij
11503 ! for diagnostics; uncomment
11504 !              rij_shift=1.2*sig0ij
11505 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11506               if (rij_shift.le.0.0D0) then
11507                 evdw=1.0D20
11508 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11509 !d     &          restyp(itypi),i,restyp(itypj),j,
11510 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11511                 return
11512               endif
11513               sigder=-sig*sigsq
11514 !---------------------------------------------------------------
11515               rij_shift=1.0D0/rij_shift
11516               fac=rij_shift**expon
11517               e1=fac*fac*aa(itypi,itypj)
11518               e2=fac*bb(itypi,itypj)
11519               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11520               eps2der=evdwij*eps3rt
11521               eps3der=evdwij*eps2rt
11522 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11523 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11524               evdwij=evdwij*eps2rt*eps3rt
11525               evdw=evdw+evdwij*sss
11526               if (lprn) then
11527               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11528               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11529               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11530                 restyp(itypi),i,restyp(itypj),j,&
11531                 epsi,sigm,chi1,chi2,chip1,chip2,&
11532                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11533                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11534                 evdwij
11535               endif
11536
11537               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11538                               'evdw',i,j,evdwij
11539 !              if (energy_dec) write (iout,*) &
11540 !                              'evdw',i,j,evdwij,"egb_short"
11541
11542 ! Calculate gradient components.
11543               e1=e1*eps1*eps2rt**2*eps3rt**2
11544               fac=-expon*(e1+evdwij)*rij_shift
11545               sigder=fac*sigder
11546               fac=rij*fac
11547 !              fac=0.0d0
11548 ! Calculate the radial part of the gradient
11549               gg(1)=xj*fac
11550               gg(2)=yj*fac
11551               gg(3)=zj*fac
11552 ! Calculate angular part of the gradient.
11553               call sc_grad_scale(sss)
11554             endif
11555           enddo      ! j
11556         enddo        ! iint
11557       enddo          ! i
11558 !      write (iout,*) "Number of loop steps in EGB:",ind
11559 !ccc      energy_dec=.false.
11560       return
11561       end subroutine egb_short
11562 !-----------------------------------------------------------------------------
11563       subroutine egbv_long(evdw)
11564 !
11565 ! This subroutine calculates the interaction energy of nonbonded side chains
11566 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11567 !
11568       use calc_data
11569 !      implicit real*8 (a-h,o-z)
11570 !      include 'DIMENSIONS'
11571 !      include 'COMMON.GEO'
11572 !      include 'COMMON.VAR'
11573 !      include 'COMMON.LOCAL'
11574 !      include 'COMMON.CHAIN'
11575 !      include 'COMMON.DERIV'
11576 !      include 'COMMON.NAMES'
11577 !      include 'COMMON.INTERACT'
11578 !      include 'COMMON.IOUNITS'
11579 !      include 'COMMON.CALC'
11580       use comm_srutu
11581 !el      integer :: icall
11582 !el      common /srutu/ icall
11583       logical :: lprn
11584 !el local variables
11585       integer :: iint,itypi,itypi1,itypj
11586       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
11587       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
11588       evdw=0.0D0
11589 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11590       evdw=0.0D0
11591       lprn=.false.
11592 !     if (icall.eq.0) lprn=.true.
11593 !el      ind=0
11594       do i=iatsc_s,iatsc_e
11595         itypi=itype(i)
11596         if (itypi.eq.ntyp1) cycle
11597         itypi1=itype(i+1)
11598         xi=c(1,nres+i)
11599         yi=c(2,nres+i)
11600         zi=c(3,nres+i)
11601         dxi=dc_norm(1,nres+i)
11602         dyi=dc_norm(2,nres+i)
11603         dzi=dc_norm(3,nres+i)
11604 !        dsci_inv=dsc_inv(itypi)
11605         dsci_inv=vbld_inv(i+nres)
11606 !
11607 ! Calculate SC interaction energy.
11608 !
11609         do iint=1,nint_gr(i)
11610           do j=istart(i,iint),iend(i,iint)
11611 !el            ind=ind+1
11612             itypj=itype(j)
11613             if (itypj.eq.ntyp1) cycle
11614 !            dscj_inv=dsc_inv(itypj)
11615             dscj_inv=vbld_inv(j+nres)
11616             sig0ij=sigma(itypi,itypj)
11617             r0ij=r0(itypi,itypj)
11618             chi1=chi(itypi,itypj)
11619             chi2=chi(itypj,itypi)
11620             chi12=chi1*chi2
11621             chip1=chip(itypi)
11622             chip2=chip(itypj)
11623             chip12=chip1*chip2
11624             alf1=alp(itypi)
11625             alf2=alp(itypj)
11626             alf12=0.5D0*(alf1+alf2)
11627             xj=c(1,nres+j)-xi
11628             yj=c(2,nres+j)-yi
11629             zj=c(3,nres+j)-zi
11630             dxj=dc_norm(1,nres+j)
11631             dyj=dc_norm(2,nres+j)
11632             dzj=dc_norm(3,nres+j)
11633             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11634             rij=dsqrt(rrij)
11635
11636             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11637
11638             if (sss.lt.1.0d0) then
11639
11640 ! Calculate angle-dependent terms of energy and contributions to their
11641 ! derivatives.
11642               call sc_angular
11643               sigsq=1.0D0/sigsq
11644               sig=sig0ij*dsqrt(sigsq)
11645               rij_shift=1.0D0/rij-sig+r0ij
11646 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11647               if (rij_shift.le.0.0D0) then
11648                 evdw=1.0D20
11649                 return
11650               endif
11651               sigder=-sig*sigsq
11652 !---------------------------------------------------------------
11653               rij_shift=1.0D0/rij_shift
11654               fac=rij_shift**expon
11655               e1=fac*fac*aa(itypi,itypj)
11656               e2=fac*bb(itypi,itypj)
11657               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11658               eps2der=evdwij*eps3rt
11659               eps3der=evdwij*eps2rt
11660               fac_augm=rrij**expon
11661               e_augm=augm(itypi,itypj)*fac_augm
11662               evdwij=evdwij*eps2rt*eps3rt
11663               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
11664               if (lprn) then
11665               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11666               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11667               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11668                 restyp(itypi),i,restyp(itypj),j,&
11669                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11670                 chi1,chi2,chip1,chip2,&
11671                 eps1,eps2rt**2,eps3rt**2,&
11672                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11673                 evdwij+e_augm
11674               endif
11675 ! Calculate gradient components.
11676               e1=e1*eps1*eps2rt**2*eps3rt**2
11677               fac=-expon*(e1+evdwij)*rij_shift
11678               sigder=fac*sigder
11679               fac=rij*fac-2*expon*rrij*e_augm
11680 ! Calculate the radial part of the gradient
11681               gg(1)=xj*fac
11682               gg(2)=yj*fac
11683               gg(3)=zj*fac
11684 ! Calculate angular part of the gradient.
11685               call sc_grad_scale(1.0d0-sss)
11686             endif
11687           enddo      ! j
11688         enddo        ! iint
11689       enddo          ! i
11690       end subroutine egbv_long
11691 !-----------------------------------------------------------------------------
11692       subroutine egbv_short(evdw)
11693 !
11694 ! This subroutine calculates the interaction energy of nonbonded side chains
11695 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11696 !
11697       use calc_data
11698 !      implicit real*8 (a-h,o-z)
11699 !      include 'DIMENSIONS'
11700 !      include 'COMMON.GEO'
11701 !      include 'COMMON.VAR'
11702 !      include 'COMMON.LOCAL'
11703 !      include 'COMMON.CHAIN'
11704 !      include 'COMMON.DERIV'
11705 !      include 'COMMON.NAMES'
11706 !      include 'COMMON.INTERACT'
11707 !      include 'COMMON.IOUNITS'
11708 !      include 'COMMON.CALC'
11709       use comm_srutu
11710 !el      integer :: icall
11711 !el      common /srutu/ icall
11712       logical :: lprn
11713 !el local variables
11714       integer :: iint,itypi,itypi1,itypj
11715       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
11716       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
11717       evdw=0.0D0
11718 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11719       evdw=0.0D0
11720       lprn=.false.
11721 !     if (icall.eq.0) lprn=.true.
11722 !el      ind=0
11723       do i=iatsc_s,iatsc_e
11724         itypi=itype(i)
11725         if (itypi.eq.ntyp1) cycle
11726         itypi1=itype(i+1)
11727         xi=c(1,nres+i)
11728         yi=c(2,nres+i)
11729         zi=c(3,nres+i)
11730         dxi=dc_norm(1,nres+i)
11731         dyi=dc_norm(2,nres+i)
11732         dzi=dc_norm(3,nres+i)
11733 !        dsci_inv=dsc_inv(itypi)
11734         dsci_inv=vbld_inv(i+nres)
11735 !
11736 ! Calculate SC interaction energy.
11737 !
11738         do iint=1,nint_gr(i)
11739           do j=istart(i,iint),iend(i,iint)
11740 !el            ind=ind+1
11741             itypj=itype(j)
11742             if (itypj.eq.ntyp1) cycle
11743 !            dscj_inv=dsc_inv(itypj)
11744             dscj_inv=vbld_inv(j+nres)
11745             sig0ij=sigma(itypi,itypj)
11746             r0ij=r0(itypi,itypj)
11747             chi1=chi(itypi,itypj)
11748             chi2=chi(itypj,itypi)
11749             chi12=chi1*chi2
11750             chip1=chip(itypi)
11751             chip2=chip(itypj)
11752             chip12=chip1*chip2
11753             alf1=alp(itypi)
11754             alf2=alp(itypj)
11755             alf12=0.5D0*(alf1+alf2)
11756             xj=c(1,nres+j)-xi
11757             yj=c(2,nres+j)-yi
11758             zj=c(3,nres+j)-zi
11759             dxj=dc_norm(1,nres+j)
11760             dyj=dc_norm(2,nres+j)
11761             dzj=dc_norm(3,nres+j)
11762             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11763             rij=dsqrt(rrij)
11764
11765             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11766
11767             if (sss.gt.0.0d0) then
11768
11769 ! Calculate angle-dependent terms of energy and contributions to their
11770 ! derivatives.
11771               call sc_angular
11772               sigsq=1.0D0/sigsq
11773               sig=sig0ij*dsqrt(sigsq)
11774               rij_shift=1.0D0/rij-sig+r0ij
11775 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11776               if (rij_shift.le.0.0D0) then
11777                 evdw=1.0D20
11778                 return
11779               endif
11780               sigder=-sig*sigsq
11781 !---------------------------------------------------------------
11782               rij_shift=1.0D0/rij_shift
11783               fac=rij_shift**expon
11784               e1=fac*fac*aa(itypi,itypj)
11785               e2=fac*bb(itypi,itypj)
11786               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11787               eps2der=evdwij*eps3rt
11788               eps3der=evdwij*eps2rt
11789               fac_augm=rrij**expon
11790               e_augm=augm(itypi,itypj)*fac_augm
11791               evdwij=evdwij*eps2rt*eps3rt
11792               evdw=evdw+(evdwij+e_augm)*sss
11793               if (lprn) then
11794               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11795               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11796               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11797                 restyp(itypi),i,restyp(itypj),j,&
11798                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11799                 chi1,chi2,chip1,chip2,&
11800                 eps1,eps2rt**2,eps3rt**2,&
11801                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11802                 evdwij+e_augm
11803               endif
11804 ! Calculate gradient components.
11805               e1=e1*eps1*eps2rt**2*eps3rt**2
11806               fac=-expon*(e1+evdwij)*rij_shift
11807               sigder=fac*sigder
11808               fac=rij*fac-2*expon*rrij*e_augm
11809 ! Calculate the radial part of the gradient
11810               gg(1)=xj*fac
11811               gg(2)=yj*fac
11812               gg(3)=zj*fac
11813 ! Calculate angular part of the gradient.
11814               call sc_grad_scale(sss)
11815             endif
11816           enddo      ! j
11817         enddo        ! iint
11818       enddo          ! i
11819       end subroutine egbv_short
11820 !-----------------------------------------------------------------------------
11821       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
11822 !
11823 ! This subroutine calculates the average interaction energy and its gradient
11824 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
11825 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
11826 ! The potential depends both on the distance of peptide-group centers and on
11827 ! the orientation of the CA-CA virtual bonds.
11828 !
11829 !      implicit real*8 (a-h,o-z)
11830
11831       use comm_locel
11832 #ifdef MPI
11833       include 'mpif.h'
11834 #endif
11835 !      include 'DIMENSIONS'
11836 !      include 'COMMON.CONTROL'
11837 !      include 'COMMON.SETUP'
11838 !      include 'COMMON.IOUNITS'
11839 !      include 'COMMON.GEO'
11840 !      include 'COMMON.VAR'
11841 !      include 'COMMON.LOCAL'
11842 !      include 'COMMON.CHAIN'
11843 !      include 'COMMON.DERIV'
11844 !      include 'COMMON.INTERACT'
11845 !      include 'COMMON.CONTACTS'
11846 !      include 'COMMON.TORSION'
11847 !      include 'COMMON.VECTORS'
11848 !      include 'COMMON.FFIELD'
11849 !      include 'COMMON.TIME1'
11850       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
11851       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
11852       real(kind=8),dimension(2,2) :: acipa !el,a_temp
11853 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
11854       real(kind=8),dimension(4) :: muij
11855 !el      integer :: num_conti,j1,j2
11856 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
11857 !el                   dz_normi,xmedi,ymedi,zmedi
11858 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
11859 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
11860 !el          num_conti,j1,j2
11861 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
11862 #ifdef MOMENT
11863       real(kind=8) :: scal_el=1.0d0
11864 #else
11865       real(kind=8) :: scal_el=0.5d0
11866 #endif
11867 ! 12/13/98
11868 ! 13-go grudnia roku pamietnego...
11869       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
11870                                              0.0d0,1.0d0,0.0d0,&
11871                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
11872 !el local variables
11873       integer :: i,j,k
11874       real(kind=8) :: fac
11875       real(kind=8) :: dxj,dyj,dzj
11876       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
11877
11878 !      allocate(num_cont_hb(nres)) !(maxres)
11879 !d      write(iout,*) 'In EELEC'
11880 !d      do i=1,nloctyp
11881 !d        write(iout,*) 'Type',i
11882 !d        write(iout,*) 'B1',B1(:,i)
11883 !d        write(iout,*) 'B2',B2(:,i)
11884 !d        write(iout,*) 'CC',CC(:,:,i)
11885 !d        write(iout,*) 'DD',DD(:,:,i)
11886 !d        write(iout,*) 'EE',EE(:,:,i)
11887 !d      enddo
11888 !d      call check_vecgrad
11889 !d      stop
11890       if (icheckgrad.eq.1) then
11891         do i=1,nres-1
11892           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
11893           do k=1,3
11894             dc_norm(k,i)=dc(k,i)*fac
11895           enddo
11896 !          write (iout,*) 'i',i,' fac',fac
11897         enddo
11898       endif
11899       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
11900           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
11901           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
11902 !        call vec_and_deriv
11903 #ifdef TIMING
11904         time01=MPI_Wtime()
11905 #endif
11906         call set_matrices
11907 #ifdef TIMING
11908         time_mat=time_mat+MPI_Wtime()-time01
11909 #endif
11910       endif
11911 !d      do i=1,nres-1
11912 !d        write (iout,*) 'i=',i
11913 !d        do k=1,3
11914 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
11915 !d        enddo
11916 !d        do k=1,3
11917 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
11918 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
11919 !d        enddo
11920 !d      enddo
11921       t_eelecij=0.0d0
11922       ees=0.0D0
11923       evdw1=0.0D0
11924       eel_loc=0.0d0
11925       eello_turn3=0.0d0
11926       eello_turn4=0.0d0
11927 !el      ind=0
11928       do i=1,nres
11929         num_cont_hb(i)=0
11930       enddo
11931 !d      print '(a)','Enter EELEC'
11932 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
11933 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
11934 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
11935       do i=1,nres
11936         gel_loc_loc(i)=0.0d0
11937         gcorr_loc(i)=0.0d0
11938       enddo
11939 !
11940 !
11941 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
11942 !
11943 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
11944 !
11945       do i=iturn3_start,iturn3_end
11946         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
11947         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
11948         dxi=dc(1,i)
11949         dyi=dc(2,i)
11950         dzi=dc(3,i)
11951         dx_normi=dc_norm(1,i)
11952         dy_normi=dc_norm(2,i)
11953         dz_normi=dc_norm(3,i)
11954         xmedi=c(1,i)+0.5d0*dxi
11955         ymedi=c(2,i)+0.5d0*dyi
11956         zmedi=c(3,i)+0.5d0*dzi
11957         num_conti=0
11958         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
11959         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
11960         num_cont_hb(i)=num_conti
11961       enddo
11962       do i=iturn4_start,iturn4_end
11963         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
11964           .or. itype(i+3).eq.ntyp1 &
11965           .or. itype(i+4).eq.ntyp1) cycle
11966         dxi=dc(1,i)
11967         dyi=dc(2,i)
11968         dzi=dc(3,i)
11969         dx_normi=dc_norm(1,i)
11970         dy_normi=dc_norm(2,i)
11971         dz_normi=dc_norm(3,i)
11972         xmedi=c(1,i)+0.5d0*dxi
11973         ymedi=c(2,i)+0.5d0*dyi
11974         zmedi=c(3,i)+0.5d0*dzi
11975         num_conti=num_cont_hb(i)
11976         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
11977         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
11978           call eturn4(i,eello_turn4)
11979         num_cont_hb(i)=num_conti
11980       enddo   ! i
11981 !
11982 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
11983 !
11984       do i=iatel_s,iatel_e
11985         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
11986         dxi=dc(1,i)
11987         dyi=dc(2,i)
11988         dzi=dc(3,i)
11989         dx_normi=dc_norm(1,i)
11990         dy_normi=dc_norm(2,i)
11991         dz_normi=dc_norm(3,i)
11992         xmedi=c(1,i)+0.5d0*dxi
11993         ymedi=c(2,i)+0.5d0*dyi
11994         zmedi=c(3,i)+0.5d0*dzi
11995 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
11996         num_conti=num_cont_hb(i)
11997         do j=ielstart(i),ielend(i)
11998           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
11999           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12000         enddo ! j
12001         num_cont_hb(i)=num_conti
12002       enddo   ! i
12003 !      write (iout,*) "Number of loop steps in EELEC:",ind
12004 !d      do i=1,nres
12005 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12006 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12007 !d      enddo
12008 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12009 !cc      eel_loc=eel_loc+eello_turn3
12010 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12011       return
12012       end subroutine eelec_scale
12013 !-----------------------------------------------------------------------------
12014       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12015 !      implicit real*8 (a-h,o-z)
12016
12017       use comm_locel
12018 !      include 'DIMENSIONS'
12019 #ifdef MPI
12020       include "mpif.h"
12021 #endif
12022 !      include 'COMMON.CONTROL'
12023 !      include 'COMMON.IOUNITS'
12024 !      include 'COMMON.GEO'
12025 !      include 'COMMON.VAR'
12026 !      include 'COMMON.LOCAL'
12027 !      include 'COMMON.CHAIN'
12028 !      include 'COMMON.DERIV'
12029 !      include 'COMMON.INTERACT'
12030 !      include 'COMMON.CONTACTS'
12031 !      include 'COMMON.TORSION'
12032 !      include 'COMMON.VECTORS'
12033 !      include 'COMMON.FFIELD'
12034 !      include 'COMMON.TIME1'
12035       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12036       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12037       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12038 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12039       real(kind=8),dimension(4) :: muij
12040 !el      integer :: num_conti,j1,j2
12041 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12042 !el                   dz_normi,xmedi,ymedi,zmedi
12043 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12044 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12045 !el          num_conti,j1,j2
12046 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12047 #ifdef MOMENT
12048       real(kind=8) :: scal_el=1.0d0
12049 #else
12050       real(kind=8) :: scal_el=0.5d0
12051 #endif
12052 ! 12/13/98
12053 ! 13-go grudnia roku pamietnego...
12054       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12055                                              0.0d0,1.0d0,0.0d0,&
12056                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12057 !el local variables
12058       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12059       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12060       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12061       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12062       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12063       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12064       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12065                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12066                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12067                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12068                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12069                   ecosam,ecosbm,ecosgm,ghalf,time00
12070 !      integer :: maxconts
12071 !      maxconts = nres/4
12072 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12073 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12074 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12075 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12076 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12077 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12078 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12079 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12080 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12081 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12082 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12083 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12084 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12085
12086 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12087 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12088
12089 #ifdef MPI
12090           time00=MPI_Wtime()
12091 #endif
12092 !d      write (iout,*) "eelecij",i,j
12093 !el          ind=ind+1
12094           iteli=itel(i)
12095           itelj=itel(j)
12096           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12097           aaa=app(iteli,itelj)
12098           bbb=bpp(iteli,itelj)
12099           ael6i=ael6(iteli,itelj)
12100           ael3i=ael3(iteli,itelj)
12101           dxj=dc(1,j)
12102           dyj=dc(2,j)
12103           dzj=dc(3,j)
12104           dx_normj=dc_norm(1,j)
12105           dy_normj=dc_norm(2,j)
12106           dz_normj=dc_norm(3,j)
12107           xj=c(1,j)+0.5D0*dxj-xmedi
12108           yj=c(2,j)+0.5D0*dyj-ymedi
12109           zj=c(3,j)+0.5D0*dzj-zmedi
12110           rij=xj*xj+yj*yj+zj*zj
12111           rrmij=1.0D0/rij
12112           rij=dsqrt(rij)
12113           rmij=1.0D0/rij
12114 ! For extracting the short-range part of Evdwpp
12115           sss=sscale(rij/rpp(iteli,itelj))
12116
12117           r3ij=rrmij*rmij
12118           r6ij=r3ij*r3ij
12119           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12120           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12121           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12122           fac=cosa-3.0D0*cosb*cosg
12123           ev1=aaa*r6ij*r6ij
12124 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12125           if (j.eq.i+2) ev1=scal_el*ev1
12126           ev2=bbb*r6ij
12127           fac3=ael6i*r6ij
12128           fac4=ael3i*r3ij
12129           evdwij=ev1+ev2
12130           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12131           el2=fac4*fac
12132           eesij=el1+el2
12133 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12134           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12135           ees=ees+eesij
12136           evdw1=evdw1+evdwij*(1.0d0-sss)
12137 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12138 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12139 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12140 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12141
12142           if (energy_dec) then
12143               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12144               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12145           endif
12146
12147 !
12148 ! Calculate contributions to the Cartesian gradient.
12149 !
12150 #ifdef SPLITELE
12151           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12152           facel=-3*rrmij*(el1+eesij)
12153           fac1=fac
12154           erij(1)=xj*rmij
12155           erij(2)=yj*rmij
12156           erij(3)=zj*rmij
12157 !
12158 ! Radial derivatives. First process both termini of the fragment (i,j)
12159 !
12160           ggg(1)=facel*xj
12161           ggg(2)=facel*yj
12162           ggg(3)=facel*zj
12163 !          do k=1,3
12164 !            ghalf=0.5D0*ggg(k)
12165 !            gelc(k,i)=gelc(k,i)+ghalf
12166 !            gelc(k,j)=gelc(k,j)+ghalf
12167 !          enddo
12168 ! 9/28/08 AL Gradient compotents will be summed only at the end
12169           do k=1,3
12170             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12171             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12172           enddo
12173 !
12174 ! Loop over residues i+1 thru j-1.
12175 !
12176 !grad          do k=i+1,j-1
12177 !grad            do l=1,3
12178 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12179 !grad            enddo
12180 !grad          enddo
12181           ggg(1)=facvdw*xj
12182           ggg(2)=facvdw*yj
12183           ggg(3)=facvdw*zj
12184 !          do k=1,3
12185 !            ghalf=0.5D0*ggg(k)
12186 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12187 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12188 !          enddo
12189 ! 9/28/08 AL Gradient compotents will be summed only at the end
12190           do k=1,3
12191             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12192             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12193           enddo
12194 !
12195 ! Loop over residues i+1 thru j-1.
12196 !
12197 !grad          do k=i+1,j-1
12198 !grad            do l=1,3
12199 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12200 !grad            enddo
12201 !grad          enddo
12202 #else
12203           facvdw=ev1+evdwij*(1.0d0-sss)
12204           facel=el1+eesij
12205           fac1=fac
12206           fac=-3*rrmij*(facvdw+facvdw+facel)
12207           erij(1)=xj*rmij
12208           erij(2)=yj*rmij
12209           erij(3)=zj*rmij
12210 !
12211 ! Radial derivatives. First process both termini of the fragment (i,j)
12212 !
12213           ggg(1)=fac*xj
12214           ggg(2)=fac*yj
12215           ggg(3)=fac*zj
12216 !          do k=1,3
12217 !            ghalf=0.5D0*ggg(k)
12218 !            gelc(k,i)=gelc(k,i)+ghalf
12219 !            gelc(k,j)=gelc(k,j)+ghalf
12220 !          enddo
12221 ! 9/28/08 AL Gradient compotents will be summed only at the end
12222           do k=1,3
12223             gelc_long(k,j)=gelc(k,j)+ggg(k)
12224             gelc_long(k,i)=gelc(k,i)-ggg(k)
12225           enddo
12226 !
12227 ! Loop over residues i+1 thru j-1.
12228 !
12229 !grad          do k=i+1,j-1
12230 !grad            do l=1,3
12231 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12232 !grad            enddo
12233 !grad          enddo
12234 ! 9/28/08 AL Gradient compotents will be summed only at the end
12235           ggg(1)=facvdw*xj
12236           ggg(2)=facvdw*yj
12237           ggg(3)=facvdw*zj
12238           do k=1,3
12239             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12240             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12241           enddo
12242 #endif
12243 !
12244 ! Angular part
12245 !
12246           ecosa=2.0D0*fac3*fac1+fac4
12247           fac4=-3.0D0*fac4
12248           fac3=-6.0D0*fac3
12249           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12250           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12251           do k=1,3
12252             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12253             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12254           enddo
12255 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12256 !d   &          (dcosg(k),k=1,3)
12257           do k=1,3
12258             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12259           enddo
12260 !          do k=1,3
12261 !            ghalf=0.5D0*ggg(k)
12262 !            gelc(k,i)=gelc(k,i)+ghalf
12263 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12264 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12265 !            gelc(k,j)=gelc(k,j)+ghalf
12266 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12267 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12268 !          enddo
12269 !grad          do k=i+1,j-1
12270 !grad            do l=1,3
12271 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12272 !grad            enddo
12273 !grad          enddo
12274           do k=1,3
12275             gelc(k,i)=gelc(k,i) &
12276                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12277                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12278             gelc(k,j)=gelc(k,j) &
12279                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12280                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12281             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12282             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12283           enddo
12284           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12285               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12286               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12287 !
12288 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12289 !   energy of a peptide unit is assumed in the form of a second-order
12290 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12291 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12292 !   are computed for EVERY pair of non-contiguous peptide groups.
12293 !
12294           if (j.lt.nres-1) then
12295             j1=j+1
12296             j2=j-1
12297           else
12298             j1=j-1
12299             j2=j-2
12300           endif
12301           kkk=0
12302           do k=1,2
12303             do l=1,2
12304               kkk=kkk+1
12305               muij(kkk)=mu(k,i)*mu(l,j)
12306             enddo
12307           enddo
12308 !d         write (iout,*) 'EELEC: i',i,' j',j
12309 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12310 !d          write(iout,*) 'muij',muij
12311           ury=scalar(uy(1,i),erij)
12312           urz=scalar(uz(1,i),erij)
12313           vry=scalar(uy(1,j),erij)
12314           vrz=scalar(uz(1,j),erij)
12315           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12316           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12317           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12318           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12319           fac=dsqrt(-ael6i)*r3ij
12320           a22=a22*fac
12321           a23=a23*fac
12322           a32=a32*fac
12323           a33=a33*fac
12324 !d          write (iout,'(4i5,4f10.5)')
12325 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12326 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12327 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12328 !d     &      uy(:,j),uz(:,j)
12329 !d          write (iout,'(4f10.5)')
12330 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12331 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12332 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12333 !d           write (iout,'(9f10.5/)')
12334 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12335 ! Derivatives of the elements of A in virtual-bond vectors
12336           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12337           do k=1,3
12338             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12339             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12340             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12341             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12342             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12343             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12344             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12345             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12346             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12347             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12348             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12349             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12350           enddo
12351 ! Compute radial contributions to the gradient
12352           facr=-3.0d0*rrmij
12353           a22der=a22*facr
12354           a23der=a23*facr
12355           a32der=a32*facr
12356           a33der=a33*facr
12357           agg(1,1)=a22der*xj
12358           agg(2,1)=a22der*yj
12359           agg(3,1)=a22der*zj
12360           agg(1,2)=a23der*xj
12361           agg(2,2)=a23der*yj
12362           agg(3,2)=a23der*zj
12363           agg(1,3)=a32der*xj
12364           agg(2,3)=a32der*yj
12365           agg(3,3)=a32der*zj
12366           agg(1,4)=a33der*xj
12367           agg(2,4)=a33der*yj
12368           agg(3,4)=a33der*zj
12369 ! Add the contributions coming from er
12370           fac3=-3.0d0*fac
12371           do k=1,3
12372             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12373             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12374             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12375             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12376           enddo
12377           do k=1,3
12378 ! Derivatives in DC(i)
12379 !grad            ghalf1=0.5d0*agg(k,1)
12380 !grad            ghalf2=0.5d0*agg(k,2)
12381 !grad            ghalf3=0.5d0*agg(k,3)
12382 !grad            ghalf4=0.5d0*agg(k,4)
12383             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12384             -3.0d0*uryg(k,2)*vry)!+ghalf1
12385             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12386             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12387             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12388             -3.0d0*urzg(k,2)*vry)!+ghalf3
12389             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12390             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12391 ! Derivatives in DC(i+1)
12392             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12393             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12394             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12395             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12396             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12397             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12398             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12399             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12400 ! Derivatives in DC(j)
12401             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12402             -3.0d0*vryg(k,2)*ury)!+ghalf1
12403             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12404             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12405             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12406             -3.0d0*vryg(k,2)*urz)!+ghalf3
12407             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12408             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12409 ! Derivatives in DC(j+1) or DC(nres-1)
12410             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12411             -3.0d0*vryg(k,3)*ury)
12412             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12413             -3.0d0*vrzg(k,3)*ury)
12414             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12415             -3.0d0*vryg(k,3)*urz)
12416             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12417             -3.0d0*vrzg(k,3)*urz)
12418 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12419 !grad              do l=1,4
12420 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12421 !grad              enddo
12422 !grad            endif
12423           enddo
12424           acipa(1,1)=a22
12425           acipa(1,2)=a23
12426           acipa(2,1)=a32
12427           acipa(2,2)=a33
12428           a22=-a22
12429           a23=-a23
12430           do l=1,2
12431             do k=1,3
12432               agg(k,l)=-agg(k,l)
12433               aggi(k,l)=-aggi(k,l)
12434               aggi1(k,l)=-aggi1(k,l)
12435               aggj(k,l)=-aggj(k,l)
12436               aggj1(k,l)=-aggj1(k,l)
12437             enddo
12438           enddo
12439           if (j.lt.nres-1) then
12440             a22=-a22
12441             a32=-a32
12442             do l=1,3,2
12443               do k=1,3
12444                 agg(k,l)=-agg(k,l)
12445                 aggi(k,l)=-aggi(k,l)
12446                 aggi1(k,l)=-aggi1(k,l)
12447                 aggj(k,l)=-aggj(k,l)
12448                 aggj1(k,l)=-aggj1(k,l)
12449               enddo
12450             enddo
12451           else
12452             a22=-a22
12453             a23=-a23
12454             a32=-a32
12455             a33=-a33
12456             do l=1,4
12457               do k=1,3
12458                 agg(k,l)=-agg(k,l)
12459                 aggi(k,l)=-aggi(k,l)
12460                 aggi1(k,l)=-aggi1(k,l)
12461                 aggj(k,l)=-aggj(k,l)
12462                 aggj1(k,l)=-aggj1(k,l)
12463               enddo
12464             enddo
12465           endif
12466           ENDIF ! WCORR
12467           IF (wel_loc.gt.0.0d0) THEN
12468 ! Contribution to the local-electrostatic energy coming from the i-j pair
12469           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12470            +a33*muij(4)
12471 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12472
12473           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12474                   'eelloc',i,j,eel_loc_ij
12475 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12476
12477           eel_loc=eel_loc+eel_loc_ij
12478 ! Partial derivatives in virtual-bond dihedral angles gamma
12479           if (i.gt.1) &
12480           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12481                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12482                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12483           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12484                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12485                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12486 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12487           do l=1,3
12488             ggg(l)=agg(l,1)*muij(1)+ &
12489                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12490             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12491             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12492 !grad            ghalf=0.5d0*ggg(l)
12493 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12494 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12495           enddo
12496 !grad          do k=i+1,j2
12497 !grad            do l=1,3
12498 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12499 !grad            enddo
12500 !grad          enddo
12501 ! Remaining derivatives of eello
12502           do l=1,3
12503             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12504                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12505             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12506                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12507             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12508                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12509             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12510                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12511           enddo
12512           ENDIF
12513 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12514 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12515           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12516              .and. num_conti.le.maxconts) then
12517 !            write (iout,*) i,j," entered corr"
12518 !
12519 ! Calculate the contact function. The ith column of the array JCONT will
12520 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12521 ! greater than I). The arrays FACONT and GACONT will contain the values of
12522 ! the contact function and its derivative.
12523 !           r0ij=1.02D0*rpp(iteli,itelj)
12524 !           r0ij=1.11D0*rpp(iteli,itelj)
12525             r0ij=2.20D0*rpp(iteli,itelj)
12526 !           r0ij=1.55D0*rpp(iteli,itelj)
12527             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12528 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12529             if (fcont.gt.0.0D0) then
12530               num_conti=num_conti+1
12531               if (num_conti.gt.maxconts) then
12532 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12533                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
12534                                ' will skip next contacts for this conf.',num_conti
12535               else
12536                 jcont_hb(num_conti,i)=j
12537 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
12538 !d     &           " jcont_hb",jcont_hb(num_conti,i)
12539                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
12540                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12541 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
12542 !  terms.
12543                 d_cont(num_conti,i)=rij
12544 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
12545 !     --- Electrostatic-interaction matrix ---
12546                 a_chuj(1,1,num_conti,i)=a22
12547                 a_chuj(1,2,num_conti,i)=a23
12548                 a_chuj(2,1,num_conti,i)=a32
12549                 a_chuj(2,2,num_conti,i)=a33
12550 !     --- Gradient of rij
12551                 do kkk=1,3
12552                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
12553                 enddo
12554                 kkll=0
12555                 do k=1,2
12556                   do l=1,2
12557                     kkll=kkll+1
12558                     do m=1,3
12559                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
12560                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
12561                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
12562                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
12563                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
12564                     enddo
12565                   enddo
12566                 enddo
12567                 ENDIF
12568                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
12569 ! Calculate contact energies
12570                 cosa4=4.0D0*cosa
12571                 wij=cosa-3.0D0*cosb*cosg
12572                 cosbg1=cosb+cosg
12573                 cosbg2=cosb-cosg
12574 !               fac3=dsqrt(-ael6i)/r0ij**3
12575                 fac3=dsqrt(-ael6i)*r3ij
12576 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
12577                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
12578                 if (ees0tmp.gt.0) then
12579                   ees0pij=dsqrt(ees0tmp)
12580                 else
12581                   ees0pij=0
12582                 endif
12583 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
12584                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
12585                 if (ees0tmp.gt.0) then
12586                   ees0mij=dsqrt(ees0tmp)
12587                 else
12588                   ees0mij=0
12589                 endif
12590 !               ees0mij=0.0D0
12591                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
12592                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
12593 ! Diagnostics. Comment out or remove after debugging!
12594 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
12595 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
12596 !               ees0m(num_conti,i)=0.0D0
12597 ! End diagnostics.
12598 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
12599 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
12600 ! Angular derivatives of the contact function
12601                 ees0pij1=fac3/ees0pij
12602                 ees0mij1=fac3/ees0mij
12603                 fac3p=-3.0D0*fac3*rrmij
12604                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
12605                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
12606 !               ees0mij1=0.0D0
12607                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
12608                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
12609                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
12610                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
12611                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
12612                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
12613                 ecosap=ecosa1+ecosa2
12614                 ecosbp=ecosb1+ecosb2
12615                 ecosgp=ecosg1+ecosg2
12616                 ecosam=ecosa1-ecosa2
12617                 ecosbm=ecosb1-ecosb2
12618                 ecosgm=ecosg1-ecosg2
12619 ! Diagnostics
12620 !               ecosap=ecosa1
12621 !               ecosbp=ecosb1
12622 !               ecosgp=ecosg1
12623 !               ecosam=0.0D0
12624 !               ecosbm=0.0D0
12625 !               ecosgm=0.0D0
12626 ! End diagnostics
12627                 facont_hb(num_conti,i)=fcont
12628                 fprimcont=fprimcont/rij
12629 !d              facont_hb(num_conti,i)=1.0D0
12630 ! Following line is for diagnostics.
12631 !d              fprimcont=0.0D0
12632                 do k=1,3
12633                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12634                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12635                 enddo
12636                 do k=1,3
12637                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
12638                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
12639                 enddo
12640                 gggp(1)=gggp(1)+ees0pijp*xj
12641                 gggp(2)=gggp(2)+ees0pijp*yj
12642                 gggp(3)=gggp(3)+ees0pijp*zj
12643                 gggm(1)=gggm(1)+ees0mijp*xj
12644                 gggm(2)=gggm(2)+ees0mijp*yj
12645                 gggm(3)=gggm(3)+ees0mijp*zj
12646 ! Derivatives due to the contact function
12647                 gacont_hbr(1,num_conti,i)=fprimcont*xj
12648                 gacont_hbr(2,num_conti,i)=fprimcont*yj
12649                 gacont_hbr(3,num_conti,i)=fprimcont*zj
12650                 do k=1,3
12651 !
12652 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
12653 !          following the change of gradient-summation algorithm.
12654 !
12655 !grad                  ghalfp=0.5D0*gggp(k)
12656 !grad                  ghalfm=0.5D0*gggm(k)
12657                   gacontp_hb1(k,num_conti,i)= & !ghalfp
12658                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12659                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12660                   gacontp_hb2(k,num_conti,i)= & !ghalfp
12661                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12662                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12663                   gacontp_hb3(k,num_conti,i)=gggp(k)
12664                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
12665                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12666                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12667                   gacontm_hb2(k,num_conti,i)= & !ghalfm
12668                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12669                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12670                   gacontm_hb3(k,num_conti,i)=gggm(k)
12671                 enddo
12672               ENDIF ! wcorr
12673               endif  ! num_conti.le.maxconts
12674             endif  ! fcont.gt.0
12675           endif    ! j.gt.i+1
12676           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
12677             do k=1,4
12678               do l=1,3
12679                 ghalf=0.5d0*agg(l,k)
12680                 aggi(l,k)=aggi(l,k)+ghalf
12681                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
12682                 aggj(l,k)=aggj(l,k)+ghalf
12683               enddo
12684             enddo
12685             if (j.eq.nres-1 .and. i.lt.j-2) then
12686               do k=1,4
12687                 do l=1,3
12688                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
12689                 enddo
12690               enddo
12691             endif
12692           endif
12693 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
12694       return
12695       end subroutine eelecij_scale
12696 !-----------------------------------------------------------------------------
12697       subroutine evdwpp_short(evdw1)
12698 !
12699 ! Compute Evdwpp
12700 !
12701 !      implicit real*8 (a-h,o-z)
12702 !      include 'DIMENSIONS'
12703 !      include 'COMMON.CONTROL'
12704 !      include 'COMMON.IOUNITS'
12705 !      include 'COMMON.GEO'
12706 !      include 'COMMON.VAR'
12707 !      include 'COMMON.LOCAL'
12708 !      include 'COMMON.CHAIN'
12709 !      include 'COMMON.DERIV'
12710 !      include 'COMMON.INTERACT'
12711 !      include 'COMMON.CONTACTS'
12712 !      include 'COMMON.TORSION'
12713 !      include 'COMMON.VECTORS'
12714 !      include 'COMMON.FFIELD'
12715       real(kind=8),dimension(3) :: ggg
12716 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12717 #ifdef MOMENT
12718       real(kind=8) :: scal_el=1.0d0
12719 #else
12720       real(kind=8) :: scal_el=0.5d0
12721 #endif
12722 !el local variables
12723       integer :: i,j,k,iteli,itelj,num_conti
12724       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
12725       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
12726                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12727                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
12728
12729       evdw1=0.0D0
12730 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
12731 !     & " iatel_e_vdw",iatel_e_vdw
12732       call flush(iout)
12733       do i=iatel_s_vdw,iatel_e_vdw
12734         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
12735         dxi=dc(1,i)
12736         dyi=dc(2,i)
12737         dzi=dc(3,i)
12738         dx_normi=dc_norm(1,i)
12739         dy_normi=dc_norm(2,i)
12740         dz_normi=dc_norm(3,i)
12741         xmedi=c(1,i)+0.5d0*dxi
12742         ymedi=c(2,i)+0.5d0*dyi
12743         zmedi=c(3,i)+0.5d0*dzi
12744         num_conti=0
12745 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
12746 !     &   ' ielend',ielend_vdw(i)
12747         call flush(iout)
12748         do j=ielstart_vdw(i),ielend_vdw(i)
12749           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12750 !el          ind=ind+1
12751           iteli=itel(i)
12752           itelj=itel(j)
12753           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12754           aaa=app(iteli,itelj)
12755           bbb=bpp(iteli,itelj)
12756           dxj=dc(1,j)
12757           dyj=dc(2,j)
12758           dzj=dc(3,j)
12759           dx_normj=dc_norm(1,j)
12760           dy_normj=dc_norm(2,j)
12761           dz_normj=dc_norm(3,j)
12762           xj=c(1,j)+0.5D0*dxj-xmedi
12763           yj=c(2,j)+0.5D0*dyj-ymedi
12764           zj=c(3,j)+0.5D0*dzj-zmedi
12765           rij=xj*xj+yj*yj+zj*zj
12766           rrmij=1.0D0/rij
12767           rij=dsqrt(rij)
12768           sss=sscale(rij/rpp(iteli,itelj))
12769           if (sss.gt.0.0d0) then
12770             rmij=1.0D0/rij
12771             r3ij=rrmij*rmij
12772             r6ij=r3ij*r3ij
12773             ev1=aaa*r6ij*r6ij
12774 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12775             if (j.eq.i+2) ev1=scal_el*ev1
12776             ev2=bbb*r6ij
12777             evdwij=ev1+ev2
12778             if (energy_dec) then
12779               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12780             endif
12781             evdw1=evdw1+evdwij*sss
12782 !
12783 ! Calculate contributions to the Cartesian gradient.
12784 !
12785             facvdw=-6*rrmij*(ev1+evdwij)*sss
12786             ggg(1)=facvdw*xj
12787             ggg(2)=facvdw*yj
12788             ggg(3)=facvdw*zj
12789             do k=1,3
12790               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12791               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12792             enddo
12793           endif
12794         enddo ! j
12795       enddo   ! i
12796       return
12797       end subroutine evdwpp_short
12798 !-----------------------------------------------------------------------------
12799       subroutine escp_long(evdw2,evdw2_14)
12800 !
12801 ! This subroutine calculates the excluded-volume interaction energy between
12802 ! peptide-group centers and side chains and its gradient in virtual-bond and
12803 ! side-chain vectors.
12804 !
12805 !      implicit real*8 (a-h,o-z)
12806 !      include 'DIMENSIONS'
12807 !      include 'COMMON.GEO'
12808 !      include 'COMMON.VAR'
12809 !      include 'COMMON.LOCAL'
12810 !      include 'COMMON.CHAIN'
12811 !      include 'COMMON.DERIV'
12812 !      include 'COMMON.INTERACT'
12813 !      include 'COMMON.FFIELD'
12814 !      include 'COMMON.IOUNITS'
12815 !      include 'COMMON.CONTROL'
12816       real(kind=8),dimension(3) :: ggg
12817 !el local variables
12818       integer :: i,iint,j,k,iteli,itypj
12819       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12820       real(kind=8) :: evdw2,evdw2_14,evdwij
12821       evdw2=0.0D0
12822       evdw2_14=0.0d0
12823 !d    print '(a)','Enter ESCP'
12824 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12825       do i=iatscp_s,iatscp_e
12826         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12827         iteli=itel(i)
12828         xi=0.5D0*(c(1,i)+c(1,i+1))
12829         yi=0.5D0*(c(2,i)+c(2,i+1))
12830         zi=0.5D0*(c(3,i)+c(3,i+1))
12831
12832         do iint=1,nscp_gr(i)
12833
12834         do j=iscpstart(i,iint),iscpend(i,iint)
12835           itypj=itype(j)
12836           if (itypj.eq.ntyp1) cycle
12837 ! Uncomment following three lines for SC-p interactions
12838 !         xj=c(1,nres+j)-xi
12839 !         yj=c(2,nres+j)-yi
12840 !         zj=c(3,nres+j)-zi
12841 ! Uncomment following three lines for Ca-p interactions
12842           xj=c(1,j)-xi
12843           yj=c(2,j)-yi
12844           zj=c(3,j)-zi
12845           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12846
12847           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12848
12849           if (sss.lt.1.0d0) then
12850
12851             fac=rrij**expon2
12852             e1=fac*fac*aad(itypj,iteli)
12853             e2=fac*bad(itypj,iteli)
12854             if (iabs(j-i) .le. 2) then
12855               e1=scal14*e1
12856               e2=scal14*e2
12857               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
12858             endif
12859             evdwij=e1+e2
12860             evdw2=evdw2+evdwij*(1.0d0-sss)
12861             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12862                 'evdw2',i,j,sss,evdwij
12863 !
12864 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12865 !
12866             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
12867             ggg(1)=xj*fac
12868             ggg(2)=yj*fac
12869             ggg(3)=zj*fac
12870 ! Uncomment following three lines for SC-p interactions
12871 !           do k=1,3
12872 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12873 !           enddo
12874 ! Uncomment following line for SC-p interactions
12875 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12876             do k=1,3
12877               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12878               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12879             enddo
12880           endif
12881         enddo
12882
12883         enddo ! iint
12884       enddo ! i
12885       do i=1,nct
12886         do j=1,3
12887           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12888           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12889           gradx_scp(j,i)=expon*gradx_scp(j,i)
12890         enddo
12891       enddo
12892 !******************************************************************************
12893 !
12894 !                              N O T E !!!
12895 !
12896 ! To save time the factor EXPON has been extracted from ALL components
12897 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12898 ! use!
12899 !
12900 !******************************************************************************
12901       return
12902       end subroutine escp_long
12903 !-----------------------------------------------------------------------------
12904       subroutine escp_short(evdw2,evdw2_14)
12905 !
12906 ! This subroutine calculates the excluded-volume interaction energy between
12907 ! peptide-group centers and side chains and its gradient in virtual-bond and
12908 ! side-chain vectors.
12909 !
12910 !      implicit real*8 (a-h,o-z)
12911 !      include 'DIMENSIONS'
12912 !      include 'COMMON.GEO'
12913 !      include 'COMMON.VAR'
12914 !      include 'COMMON.LOCAL'
12915 !      include 'COMMON.CHAIN'
12916 !      include 'COMMON.DERIV'
12917 !      include 'COMMON.INTERACT'
12918 !      include 'COMMON.FFIELD'
12919 !      include 'COMMON.IOUNITS'
12920 !      include 'COMMON.CONTROL'
12921       real(kind=8),dimension(3) :: ggg
12922 !el local variables
12923       integer :: i,iint,j,k,iteli,itypj
12924       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12925       real(kind=8) :: evdw2,evdw2_14,evdwij
12926       evdw2=0.0D0
12927       evdw2_14=0.0d0
12928 !d    print '(a)','Enter ESCP'
12929 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12930       do i=iatscp_s,iatscp_e
12931         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12932         iteli=itel(i)
12933         xi=0.5D0*(c(1,i)+c(1,i+1))
12934         yi=0.5D0*(c(2,i)+c(2,i+1))
12935         zi=0.5D0*(c(3,i)+c(3,i+1))
12936
12937         do iint=1,nscp_gr(i)
12938
12939         do j=iscpstart(i,iint),iscpend(i,iint)
12940           itypj=itype(j)
12941           if (itypj.eq.ntyp1) cycle
12942 ! Uncomment following three lines for SC-p interactions
12943 !         xj=c(1,nres+j)-xi
12944 !         yj=c(2,nres+j)-yi
12945 !         zj=c(3,nres+j)-zi
12946 ! Uncomment following three lines for Ca-p interactions
12947           xj=c(1,j)-xi
12948           yj=c(2,j)-yi
12949           zj=c(3,j)-zi
12950           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12951
12952           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12953
12954           if (sss.gt.0.0d0) then
12955
12956             fac=rrij**expon2
12957             e1=fac*fac*aad(itypj,iteli)
12958             e2=fac*bad(itypj,iteli)
12959             if (iabs(j-i) .le. 2) then
12960               e1=scal14*e1
12961               e2=scal14*e2
12962               evdw2_14=evdw2_14+(e1+e2)*sss
12963             endif
12964             evdwij=e1+e2
12965             evdw2=evdw2+evdwij*sss
12966             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12967                 'evdw2',i,j,sss,evdwij
12968 !
12969 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12970 !
12971             fac=-(evdwij+e1)*rrij*sss
12972             ggg(1)=xj*fac
12973             ggg(2)=yj*fac
12974             ggg(3)=zj*fac
12975 ! Uncomment following three lines for SC-p interactions
12976 !           do k=1,3
12977 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12978 !           enddo
12979 ! Uncomment following line for SC-p interactions
12980 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12981             do k=1,3
12982               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12983               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12984             enddo
12985           endif
12986         enddo
12987
12988         enddo ! iint
12989       enddo ! i
12990       do i=1,nct
12991         do j=1,3
12992           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12993           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12994           gradx_scp(j,i)=expon*gradx_scp(j,i)
12995         enddo
12996       enddo
12997 !******************************************************************************
12998 !
12999 !                              N O T E !!!
13000 !
13001 ! To save time the factor EXPON has been extracted from ALL components
13002 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13003 ! use!
13004 !
13005 !******************************************************************************
13006       return
13007       end subroutine escp_short
13008 !-----------------------------------------------------------------------------
13009 ! energy_p_new-sep_barrier.F
13010 !-----------------------------------------------------------------------------
13011       subroutine sc_grad_scale(scalfac)
13012 !      implicit real*8 (a-h,o-z)
13013       use calc_data
13014 !      include 'DIMENSIONS'
13015 !      include 'COMMON.CHAIN'
13016 !      include 'COMMON.DERIV'
13017 !      include 'COMMON.CALC'
13018 !      include 'COMMON.IOUNITS'
13019       real(kind=8),dimension(3) :: dcosom1,dcosom2
13020       real(kind=8) :: scalfac
13021 !el local variables
13022 !      integer :: i,j,k,l
13023
13024       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13025       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13026       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13027            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13028 ! diagnostics only
13029 !      eom1=0.0d0
13030 !      eom2=0.0d0
13031 !      eom12=evdwij*eps1_om12
13032 ! end diagnostics
13033 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13034 !     &  " sigder",sigder
13035 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13036 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13037       do k=1,3
13038         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13039         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13040       enddo
13041       do k=1,3
13042         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
13043       enddo
13044 !      write (iout,*) "gg",(gg(k),k=1,3)
13045       do k=1,3
13046         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13047                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13048                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac
13049         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13050                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13051                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac
13052 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13053 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13054 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13055 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13056       enddo
13057 !
13058 ! Calculate the components of the gradient in DC and X
13059 !
13060       do l=1,3
13061         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13062         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13063       enddo
13064       return
13065       end subroutine sc_grad_scale
13066 !-----------------------------------------------------------------------------
13067 ! energy_split-sep.F
13068 !-----------------------------------------------------------------------------
13069       subroutine etotal_long(energia)
13070 !
13071 ! Compute the long-range slow-varying contributions to the energy
13072 !
13073 !      implicit real*8 (a-h,o-z)
13074 !      include 'DIMENSIONS'
13075       use MD_data, only: totT
13076 #ifndef ISNAN
13077       external proc_proc
13078 #ifdef WINPGI
13079 !MS$ATTRIBUTES C ::  proc_proc
13080 #endif
13081 #endif
13082 #ifdef MPI
13083       include "mpif.h"
13084       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13085 #endif
13086 !      include 'COMMON.SETUP'
13087 !      include 'COMMON.IOUNITS'
13088 !      include 'COMMON.FFIELD'
13089 !      include 'COMMON.DERIV'
13090 !      include 'COMMON.INTERACT'
13091 !      include 'COMMON.SBRIDGE'
13092 !      include 'COMMON.CHAIN'
13093 !      include 'COMMON.VAR'
13094 !      include 'COMMON.LOCAL'
13095 !      include 'COMMON.MD'
13096       real(kind=8),dimension(0:n_ene) :: energia
13097 !el local variables
13098       integer :: i,n_corr,n_corr1,ierror,ierr
13099       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13100                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13101                   ecorr,ecorr5,ecorr6,eturn6,time00
13102 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13103 !elwrite(iout,*)"in etotal long"
13104
13105       if (modecalc.eq.12.or.modecalc.eq.14) then
13106 #ifdef MPI
13107 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13108 #else
13109         call int_from_cart1(.false.)
13110 #endif
13111       endif
13112 !elwrite(iout,*)"in etotal long"
13113
13114 #ifdef MPI
13115 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13116 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13117       call flush(iout)
13118       if (nfgtasks.gt.1) then
13119         time00=MPI_Wtime()
13120 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13121         if (fg_rank.eq.0) then
13122           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13123 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13124 !          call flush(iout)
13125 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13126 ! FG slaves as WEIGHTS array.
13127           weights_(1)=wsc
13128           weights_(2)=wscp
13129           weights_(3)=welec
13130           weights_(4)=wcorr
13131           weights_(5)=wcorr5
13132           weights_(6)=wcorr6
13133           weights_(7)=wel_loc
13134           weights_(8)=wturn3
13135           weights_(9)=wturn4
13136           weights_(10)=wturn6
13137           weights_(11)=wang
13138           weights_(12)=wscloc
13139           weights_(13)=wtor
13140           weights_(14)=wtor_d
13141           weights_(15)=wstrain
13142           weights_(16)=wvdwpp
13143           weights_(17)=wbond
13144           weights_(18)=scal14
13145           weights_(21)=wsccor
13146 ! FG Master broadcasts the WEIGHTS_ array
13147           call MPI_Bcast(weights_(1),n_ene,&
13148               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13149         else
13150 ! FG slaves receive the WEIGHTS array
13151           call MPI_Bcast(weights(1),n_ene,&
13152               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13153           wsc=weights(1)
13154           wscp=weights(2)
13155           welec=weights(3)
13156           wcorr=weights(4)
13157           wcorr5=weights(5)
13158           wcorr6=weights(6)
13159           wel_loc=weights(7)
13160           wturn3=weights(8)
13161           wturn4=weights(9)
13162           wturn6=weights(10)
13163           wang=weights(11)
13164           wscloc=weights(12)
13165           wtor=weights(13)
13166           wtor_d=weights(14)
13167           wstrain=weights(15)
13168           wvdwpp=weights(16)
13169           wbond=weights(17)
13170           scal14=weights(18)
13171           wsccor=weights(21)
13172         endif
13173         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13174           king,FG_COMM,IERR)
13175          time_Bcast=time_Bcast+MPI_Wtime()-time00
13176          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13177 !        call chainbuild_cart
13178 !        call int_from_cart1(.false.)
13179       endif
13180 !      write (iout,*) 'Processor',myrank,
13181 !     &  ' calling etotal_short ipot=',ipot
13182 !      call flush(iout)
13183 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13184 #endif
13185 !d    print *,'nnt=',nnt,' nct=',nct
13186 !
13187 !elwrite(iout,*)"in etotal long"
13188 ! Compute the side-chain and electrostatic interaction energy
13189 !
13190       goto (101,102,103,104,105,106) ipot
13191 ! Lennard-Jones potential.
13192   101 call elj_long(evdw)
13193 !d    print '(a)','Exit ELJ'
13194       goto 107
13195 ! Lennard-Jones-Kihara potential (shifted).
13196   102 call eljk_long(evdw)
13197       goto 107
13198 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13199   103 call ebp_long(evdw)
13200       goto 107
13201 ! Gay-Berne potential (shifted LJ, angular dependence).
13202   104 call egb_long(evdw)
13203       goto 107
13204 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13205   105 call egbv_long(evdw)
13206       goto 107
13207 ! Soft-sphere potential
13208   106 call e_softsphere(evdw)
13209 !
13210 ! Calculate electrostatic (H-bonding) energy of the main chain.
13211 !
13212   107 continue
13213       call vec_and_deriv
13214       if (ipot.lt.6) then
13215 #ifdef SPLITELE
13216          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13217              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13218              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13219              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13220 #else
13221          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13222              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13223              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13224              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13225 #endif
13226            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13227          else
13228             ees=0
13229             evdw1=0
13230             eel_loc=0
13231             eello_turn3=0
13232             eello_turn4=0
13233          endif
13234       else
13235 !        write (iout,*) "Soft-spheer ELEC potential"
13236         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13237          eello_turn4)
13238       endif
13239 !
13240 ! Calculate excluded-volume interaction energy between peptide groups
13241 ! and side chains.
13242 !
13243       if (ipot.lt.6) then
13244        if(wscp.gt.0d0) then
13245         call escp_long(evdw2,evdw2_14)
13246        else
13247         evdw2=0
13248         evdw2_14=0
13249        endif
13250       else
13251         call escp_soft_sphere(evdw2,evdw2_14)
13252       endif
13253 !
13254 ! 12/1/95 Multi-body terms
13255 !
13256       n_corr=0
13257       n_corr1=0
13258       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13259           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13260          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13261 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13262 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13263       else
13264          ecorr=0.0d0
13265          ecorr5=0.0d0
13266          ecorr6=0.0d0
13267          eturn6=0.0d0
13268       endif
13269       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13270          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13271       endif
13272 !
13273 ! If performing constraint dynamics, call the constraint energy
13274 !  after the equilibration time
13275       if(usampl.and.totT.gt.eq_time) then
13276          call EconstrQ
13277          call Econstr_back
13278       else
13279          Uconst=0.0d0
13280          Uconst_back=0.0d0
13281       endif
13282 !
13283 ! Sum the energies
13284 !
13285       do i=1,n_ene
13286         energia(i)=0.0d0
13287       enddo
13288       energia(1)=evdw
13289 #ifdef SCP14
13290       energia(2)=evdw2-evdw2_14
13291       energia(18)=evdw2_14
13292 #else
13293       energia(2)=evdw2
13294       energia(18)=0.0d0
13295 #endif
13296 #ifdef SPLITELE
13297       energia(3)=ees
13298       energia(16)=evdw1
13299 #else
13300       energia(3)=ees+evdw1
13301       energia(16)=0.0d0
13302 #endif
13303       energia(4)=ecorr
13304       energia(5)=ecorr5
13305       energia(6)=ecorr6
13306       energia(7)=eel_loc
13307       energia(8)=eello_turn3
13308       energia(9)=eello_turn4
13309       energia(10)=eturn6
13310       energia(20)=Uconst+Uconst_back
13311       call sum_energy(energia,.true.)
13312 !      write (iout,*) "Exit ETOTAL_LONG"
13313       call flush(iout)
13314       return
13315       end subroutine etotal_long
13316 !-----------------------------------------------------------------------------
13317       subroutine etotal_short(energia)
13318 !
13319 ! Compute the short-range fast-varying contributions to the energy
13320 !
13321 !      implicit real*8 (a-h,o-z)
13322 !      include 'DIMENSIONS'
13323 #ifndef ISNAN
13324       external proc_proc
13325 #ifdef WINPGI
13326 !MS$ATTRIBUTES C ::  proc_proc
13327 #endif
13328 #endif
13329 #ifdef MPI
13330       include "mpif.h"
13331       integer :: ierror,ierr
13332       real(kind=8),dimension(n_ene) :: weights_
13333       real(kind=8) :: time00
13334 #endif
13335 !      include 'COMMON.SETUP'
13336 !      include 'COMMON.IOUNITS'
13337 !      include 'COMMON.FFIELD'
13338 !      include 'COMMON.DERIV'
13339 !      include 'COMMON.INTERACT'
13340 !      include 'COMMON.SBRIDGE'
13341 !      include 'COMMON.CHAIN'
13342 !      include 'COMMON.VAR'
13343 !      include 'COMMON.LOCAL'
13344       real(kind=8),dimension(0:n_ene) :: energia
13345 !el local variables
13346       integer :: i,nres6
13347       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13348       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13349       nres6=6*nres
13350
13351 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13352 !      call flush(iout)
13353       if (modecalc.eq.12.or.modecalc.eq.14) then
13354 #ifdef MPI
13355         if (fg_rank.eq.0) call int_from_cart1(.false.)
13356 #else
13357         call int_from_cart1(.false.)
13358 #endif
13359       endif
13360 #ifdef MPI
13361 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13362 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13363 !      call flush(iout)
13364       if (nfgtasks.gt.1) then
13365         time00=MPI_Wtime()
13366 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13367         if (fg_rank.eq.0) then
13368           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13369 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13370 !          call flush(iout)
13371 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13372 ! FG slaves as WEIGHTS array.
13373           weights_(1)=wsc
13374           weights_(2)=wscp
13375           weights_(3)=welec
13376           weights_(4)=wcorr
13377           weights_(5)=wcorr5
13378           weights_(6)=wcorr6
13379           weights_(7)=wel_loc
13380           weights_(8)=wturn3
13381           weights_(9)=wturn4
13382           weights_(10)=wturn6
13383           weights_(11)=wang
13384           weights_(12)=wscloc
13385           weights_(13)=wtor
13386           weights_(14)=wtor_d
13387           weights_(15)=wstrain
13388           weights_(16)=wvdwpp
13389           weights_(17)=wbond
13390           weights_(18)=scal14
13391           weights_(21)=wsccor
13392 ! FG Master broadcasts the WEIGHTS_ array
13393           call MPI_Bcast(weights_(1),n_ene,&
13394               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13395         else
13396 ! FG slaves receive the WEIGHTS array
13397           call MPI_Bcast(weights(1),n_ene,&
13398               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13399           wsc=weights(1)
13400           wscp=weights(2)
13401           welec=weights(3)
13402           wcorr=weights(4)
13403           wcorr5=weights(5)
13404           wcorr6=weights(6)
13405           wel_loc=weights(7)
13406           wturn3=weights(8)
13407           wturn4=weights(9)
13408           wturn6=weights(10)
13409           wang=weights(11)
13410           wscloc=weights(12)
13411           wtor=weights(13)
13412           wtor_d=weights(14)
13413           wstrain=weights(15)
13414           wvdwpp=weights(16)
13415           wbond=weights(17)
13416           scal14=weights(18)
13417           wsccor=weights(21)
13418         endif
13419 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13420         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13421           king,FG_COMM,IERR)
13422 !        write (iout,*) "Processor",myrank," BROADCAST c"
13423         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13424           king,FG_COMM,IERR)
13425 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13426         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13427           king,FG_COMM,IERR)
13428 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13429         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13430           king,FG_COMM,IERR)
13431 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13432         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13433           king,FG_COMM,IERR)
13434 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13435         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13436           king,FG_COMM,IERR)
13437 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13438         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13439           king,FG_COMM,IERR)
13440 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13441         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13442           king,FG_COMM,IERR)
13443 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13444         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13445           king,FG_COMM,IERR)
13446          time_Bcast=time_Bcast+MPI_Wtime()-time00
13447 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13448       endif
13449 !      write (iout,*) 'Processor',myrank,
13450 !     &  ' calling etotal_short ipot=',ipot
13451 !      call flush(iout)
13452 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13453 #endif
13454 !      call int_from_cart1(.false.)
13455 !
13456 ! Compute the side-chain and electrostatic interaction energy
13457 !
13458       goto (101,102,103,104,105,106) ipot
13459 ! Lennard-Jones potential.
13460   101 call elj_short(evdw)
13461 !d    print '(a)','Exit ELJ'
13462       goto 107
13463 ! Lennard-Jones-Kihara potential (shifted).
13464   102 call eljk_short(evdw)
13465       goto 107
13466 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13467   103 call ebp_short(evdw)
13468       goto 107
13469 ! Gay-Berne potential (shifted LJ, angular dependence).
13470   104 call egb_short(evdw)
13471       goto 107
13472 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13473   105 call egbv_short(evdw)
13474       goto 107
13475 ! Soft-sphere potential - already dealt with in the long-range part
13476   106 evdw=0.0d0
13477 !  106 call e_softsphere_short(evdw)
13478 !
13479 ! Calculate electrostatic (H-bonding) energy of the main chain.
13480 !
13481   107 continue
13482 !
13483 ! Calculate the short-range part of Evdwpp
13484 !
13485       call evdwpp_short(evdw1)
13486 !
13487 ! Calculate the short-range part of ESCp
13488 !
13489       if (ipot.lt.6) then
13490         call escp_short(evdw2,evdw2_14)
13491       endif
13492 !
13493 ! Calculate the bond-stretching energy
13494 !
13495       call ebond(estr)
13496 !
13497 ! Calculate the disulfide-bridge and other energy and the contributions
13498 ! from other distance constraints.
13499       call edis(ehpb)
13500 !
13501 ! Calculate the virtual-bond-angle energy.
13502 !
13503       call ebend(ebe)
13504 !
13505 ! Calculate the SC local energy.
13506 !
13507       call vec_and_deriv
13508       call esc(escloc)
13509 !
13510 ! Calculate the virtual-bond torsional energy.
13511 !
13512       call etor(etors,edihcnstr)
13513 !
13514 ! 6/23/01 Calculate double-torsional energy
13515 !
13516       call etor_d(etors_d)
13517 !
13518 ! 21/5/07 Calculate local sicdechain correlation energy
13519 !
13520       if (wsccor.gt.0.0d0) then
13521         call eback_sc_corr(esccor)
13522       else
13523         esccor=0.0d0
13524       endif
13525 !
13526 ! Put energy components into an array
13527 !
13528       do i=1,n_ene
13529         energia(i)=0.0d0
13530       enddo
13531       energia(1)=evdw
13532 #ifdef SCP14
13533       energia(2)=evdw2-evdw2_14
13534       energia(18)=evdw2_14
13535 #else
13536       energia(2)=evdw2
13537       energia(18)=0.0d0
13538 #endif
13539 #ifdef SPLITELE
13540       energia(16)=evdw1
13541 #else
13542       energia(3)=evdw1
13543 #endif
13544       energia(11)=ebe
13545       energia(12)=escloc
13546       energia(13)=etors
13547       energia(14)=etors_d
13548       energia(15)=ehpb
13549       energia(17)=estr
13550       energia(19)=edihcnstr
13551       energia(21)=esccor
13552 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
13553       call flush(iout)
13554       call sum_energy(energia,.true.)
13555 !      write (iout,*) "Exit ETOTAL_SHORT"
13556       call flush(iout)
13557       return
13558       end subroutine etotal_short
13559 !-----------------------------------------------------------------------------
13560 ! gnmr1.f
13561 !-----------------------------------------------------------------------------
13562       real(kind=8) function gnmr1(y,ymin,ymax)
13563 !      implicit none
13564       real(kind=8) :: y,ymin,ymax
13565       real(kind=8) :: wykl=4.0d0
13566       if (y.lt.ymin) then
13567         gnmr1=(ymin-y)**wykl/wykl
13568       else if (y.gt.ymax) then
13569         gnmr1=(y-ymax)**wykl/wykl
13570       else
13571         gnmr1=0.0d0
13572       endif
13573       return
13574       end function gnmr1
13575 !-----------------------------------------------------------------------------
13576       real(kind=8) function gnmr1prim(y,ymin,ymax)
13577 !      implicit none
13578       real(kind=8) :: y,ymin,ymax
13579       real(kind=8) :: wykl=4.0d0
13580       if (y.lt.ymin) then
13581         gnmr1prim=-(ymin-y)**(wykl-1)
13582       else if (y.gt.ymax) then
13583         gnmr1prim=(y-ymax)**(wykl-1)
13584       else
13585         gnmr1prim=0.0d0
13586       endif
13587       return
13588       end function gnmr1prim
13589 !-----------------------------------------------------------------------------
13590       real(kind=8) function harmonic(y,ymax)
13591 !      implicit none
13592       real(kind=8) :: y,ymax
13593       real(kind=8) :: wykl=2.0d0
13594       harmonic=(y-ymax)**wykl
13595       return
13596       end function harmonic
13597 !-----------------------------------------------------------------------------
13598       real(kind=8) function harmonicprim(y,ymax)
13599       real(kind=8) :: y,ymin,ymax
13600       real(kind=8) :: wykl=2.0d0
13601       harmonicprim=(y-ymax)*wykl
13602       return
13603       end function harmonicprim
13604 !-----------------------------------------------------------------------------
13605 ! gradient_p.F
13606 !-----------------------------------------------------------------------------
13607       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
13608
13609       use io_base, only:intout,briefout
13610 !      implicit real*8 (a-h,o-z)
13611 !      include 'DIMENSIONS'
13612 !      include 'COMMON.CHAIN'
13613 !      include 'COMMON.DERIV'
13614 !      include 'COMMON.VAR'
13615 !      include 'COMMON.INTERACT'
13616 !      include 'COMMON.FFIELD'
13617 !      include 'COMMON.MD'
13618 !      include 'COMMON.IOUNITS'
13619       real(kind=8),external :: ufparm
13620       integer :: uiparm(1)
13621       real(kind=8) :: urparm(1)
13622       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13623       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
13624       integer :: n,nf,ind,ind1,i,k,j
13625 !
13626 ! This subroutine calculates total internal coordinate gradient.
13627 ! Depending on the number of function evaluations, either whole energy
13628 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
13629 ! internal coordinates are reevaluated or only the cartesian-in-internal
13630 ! coordinate derivatives are evaluated. The subroutine was designed to work
13631 ! with SUMSL.
13632 !
13633 !
13634       icg=mod(nf,2)+1
13635
13636 !d      print *,'grad',nf,icg
13637       if (nf-nfl+1) 20,30,40
13638    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
13639 !    write (iout,*) 'grad 20'
13640       if (nf.eq.0) return
13641       goto 40
13642    30 call var_to_geom(n,x)
13643       call chainbuild
13644 !    write (iout,*) 'grad 30'
13645 !
13646 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
13647 !
13648    40 call cartder
13649 !     write (iout,*) 'grad 40'
13650 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
13651 !
13652 ! Convert the Cartesian gradient into internal-coordinate gradient.
13653 !
13654       ind=0
13655       ind1=0
13656       do i=1,nres-2
13657         gthetai=0.0D0
13658         gphii=0.0D0
13659         do j=i+1,nres-1
13660           ind=ind+1
13661 !         ind=indmat(i,j)
13662 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
13663           do k=1,3
13664             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
13665           enddo
13666           do k=1,3
13667             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
13668           enddo
13669         enddo
13670         do j=i+1,nres-1
13671           ind1=ind1+1
13672 !         ind1=indmat(i,j)
13673 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
13674           do k=1,3
13675             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
13676             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
13677           enddo
13678         enddo
13679         if (i.gt.1) g(i-1)=gphii
13680         if (n.gt.nphi) g(nphi+i)=gthetai
13681       enddo
13682       if (n.le.nphi+ntheta) goto 10
13683       do i=2,nres-1
13684         if (itype(i).ne.10) then
13685           galphai=0.0D0
13686           gomegai=0.0D0
13687           do k=1,3
13688             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
13689           enddo
13690           do k=1,3
13691             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
13692           enddo
13693           g(ialph(i,1))=galphai
13694           g(ialph(i,1)+nside)=gomegai
13695         endif
13696       enddo
13697 !
13698 ! Add the components corresponding to local energy terms.
13699 !
13700    10 continue
13701       do i=1,nvar
13702 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
13703         g(i)=g(i)+gloc(i,icg)
13704       enddo
13705 ! Uncomment following three lines for diagnostics.
13706 !d    call intout
13707 !elwrite(iout,*) "in gradient after calling intout"
13708 !d    call briefout(0,0.0d0)
13709 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
13710       return
13711       end subroutine gradient
13712 !-----------------------------------------------------------------------------
13713       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
13714
13715       use comm_chu
13716 !      implicit real*8 (a-h,o-z)
13717 !      include 'DIMENSIONS'
13718 !      include 'COMMON.DERIV'
13719 !      include 'COMMON.IOUNITS'
13720 !      include 'COMMON.GEO'
13721       integer :: n,nf
13722 !el      integer :: jjj
13723 !el      common /chuju/ jjj
13724       real(kind=8) :: energia(0:n_ene)
13725       integer :: uiparm(1)
13726       real(kind=8) :: urparm(1)
13727       real(kind=8) :: f
13728       real(kind=8),external :: ufparm
13729       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
13730 !     if (jjj.gt.0) then
13731 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13732 !     endif
13733       nfl=nf
13734       icg=mod(nf,2)+1
13735 !d      print *,'func',nf,nfl,icg
13736       call var_to_geom(n,x)
13737       call zerograd
13738       call chainbuild
13739 !d    write (iout,*) 'ETOTAL called from FUNC'
13740       call etotal(energia)
13741       call sum_gradient
13742       f=energia(0)
13743 !     if (jjj.gt.0) then
13744 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13745 !       write (iout,*) 'f=',etot
13746 !       jjj=0
13747 !     endif
13748       return
13749       end subroutine func
13750 !-----------------------------------------------------------------------------
13751       subroutine cartgrad
13752 !      implicit real*8 (a-h,o-z)
13753 !      include 'DIMENSIONS'
13754       use energy_data
13755       use MD_data, only: totT
13756 #ifdef MPI
13757       include 'mpif.h'
13758 #endif
13759 !      include 'COMMON.CHAIN'
13760 !      include 'COMMON.DERIV'
13761 !      include 'COMMON.VAR'
13762 !      include 'COMMON.INTERACT'
13763 !      include 'COMMON.FFIELD'
13764 !      include 'COMMON.MD'
13765 !      include 'COMMON.IOUNITS'
13766 !      include 'COMMON.TIME1'
13767 !
13768       integer :: i,j
13769
13770 ! This subrouting calculates total Cartesian coordinate gradient.
13771 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
13772 !
13773 !el#define DEBUG
13774 #ifdef TIMING
13775       time00=MPI_Wtime()
13776 #endif
13777       icg=1
13778       call sum_gradient
13779 #ifdef TIMING
13780 #endif
13781 !el      write (iout,*) "After sum_gradient"
13782 #ifdef DEBUG
13783 !el      write (iout,*) "After sum_gradient"
13784       do i=1,nres-1
13785         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
13786         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
13787       enddo
13788 #endif
13789 ! If performing constraint dynamics, add the gradients of the constraint energy
13790       if(usampl.and.totT.gt.eq_time) then
13791          do i=1,nct
13792            do j=1,3
13793              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
13794              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
13795            enddo
13796          enddo
13797          do i=1,nres-3
13798            gloc(i,icg)=gloc(i,icg)+dugamma(i)
13799          enddo
13800          do i=1,nres-2
13801            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
13802          enddo
13803       endif
13804 !elwrite (iout,*) "After sum_gradient"
13805 #ifdef TIMING
13806       time01=MPI_Wtime()
13807 #endif
13808       call intcartderiv
13809 !elwrite (iout,*) "After sum_gradient"
13810 #ifdef TIMING
13811       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
13812 #endif
13813 !     call checkintcartgrad
13814 !     write(iout,*) 'calling int_to_cart'
13815 #ifdef DEBUG
13816       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
13817 #endif
13818       do i=1,nct
13819         do j=1,3
13820           gcart(j,i)=gradc(j,i,icg)
13821           gxcart(j,i)=gradx(j,i,icg)
13822         enddo
13823 #ifdef DEBUG
13824         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
13825           (gxcart(j,i),j=1,3),gloc(i,icg)
13826 #endif
13827       enddo
13828 #ifdef TIMING
13829       time01=MPI_Wtime()
13830 #endif
13831       call int_to_cart
13832 #ifdef TIMING
13833       time_inttocart=time_inttocart+MPI_Wtime()-time01
13834 #endif
13835 #ifdef DEBUG
13836       write (iout,*) "gcart and gxcart after int_to_cart"
13837       do i=0,nres-1
13838         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13839             (gxcart(j,i),j=1,3)
13840       enddo
13841 #endif
13842 #ifdef TIMING
13843       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
13844 #endif
13845 !el#undef DEBUG
13846       return
13847       end subroutine cartgrad
13848 !-----------------------------------------------------------------------------
13849       subroutine zerograd
13850 !      implicit real*8 (a-h,o-z)
13851 !      include 'DIMENSIONS'
13852 !      include 'COMMON.DERIV'
13853 !      include 'COMMON.CHAIN'
13854 !      include 'COMMON.VAR'
13855 !      include 'COMMON.MD'
13856 !      include 'COMMON.SCCOR'
13857 !
13858 !el local variables
13859       integer :: i,j,intertyp
13860 ! Initialize Cartesian-coordinate gradient
13861 !
13862 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
13863 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
13864
13865 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
13866 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
13867 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
13868 !      allocate(gradcorr_long(3,nres))
13869 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
13870 !      allocate(gcorr6_turn_long(3,nres))
13871 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
13872
13873 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
13874
13875 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
13876 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
13877
13878 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
13879 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
13880
13881 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
13882 !      allocate(gscloc(3,nres)) !(3,maxres)
13883 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
13884
13885
13886
13887 !      common /deriv_scloc/
13888 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
13889 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
13890 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
13891 !      common /mpgrad/
13892 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
13893
13894
13895
13896 !          gradc(j,i,icg)=0.0d0
13897 !          gradx(j,i,icg)=0.0d0
13898
13899 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
13900 !elwrite(iout,*) "icg",icg
13901       do i=1,nres
13902         do j=1,3
13903           gvdwx(j,i)=0.0D0
13904           gradx_scp(j,i)=0.0D0
13905           gvdwc(j,i)=0.0D0
13906           gvdwc_scp(j,i)=0.0D0
13907           gvdwc_scpp(j,i)=0.0d0
13908           gelc(j,i)=0.0D0
13909           gelc_long(j,i)=0.0D0
13910           gradb(j,i)=0.0d0
13911           gradbx(j,i)=0.0d0
13912           gvdwpp(j,i)=0.0d0
13913           gel_loc(j,i)=0.0d0
13914           gel_loc_long(j,i)=0.0d0
13915           ghpbc(j,i)=0.0D0
13916           ghpbx(j,i)=0.0D0
13917           gcorr3_turn(j,i)=0.0d0
13918           gcorr4_turn(j,i)=0.0d0
13919           gradcorr(j,i)=0.0d0
13920           gradcorr_long(j,i)=0.0d0
13921           gradcorr5_long(j,i)=0.0d0
13922           gradcorr6_long(j,i)=0.0d0
13923           gcorr6_turn_long(j,i)=0.0d0
13924           gradcorr5(j,i)=0.0d0
13925           gradcorr6(j,i)=0.0d0
13926           gcorr6_turn(j,i)=0.0d0
13927           gsccorc(j,i)=0.0d0
13928           gsccorx(j,i)=0.0d0
13929           gradc(j,i,icg)=0.0d0
13930           gradx(j,i,icg)=0.0d0
13931           gscloc(j,i)=0.0d0
13932           gsclocx(j,i)=0.0d0
13933           do intertyp=1,3
13934            gloc_sc(intertyp,i,icg)=0.0d0
13935           enddo
13936         enddo
13937       enddo
13938 !
13939 ! Initialize the gradient of local energy terms.
13940 !
13941 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
13942 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13943 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13944 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
13945 !      allocate(gel_loc_turn3(nres))
13946 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
13947 !      allocate(gsccor_loc(nres))       !(maxres)
13948
13949       do i=1,4*nres
13950         gloc(i,icg)=0.0D0
13951       enddo
13952       do i=1,nres
13953         gel_loc_loc(i)=0.0d0
13954         gcorr_loc(i)=0.0d0
13955         g_corr5_loc(i)=0.0d0
13956         g_corr6_loc(i)=0.0d0
13957         gel_loc_turn3(i)=0.0d0
13958         gel_loc_turn4(i)=0.0d0
13959         gel_loc_turn6(i)=0.0d0
13960         gsccor_loc(i)=0.0d0
13961       enddo
13962 ! initialize gcart and gxcart
13963 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
13964       do i=0,nres
13965         do j=1,3
13966           gcart(j,i)=0.0d0
13967           gxcart(j,i)=0.0d0
13968         enddo
13969       enddo
13970       return
13971       end subroutine zerograd
13972 !-----------------------------------------------------------------------------
13973       real(kind=8) function fdum()
13974       fdum=0.0D0
13975       return
13976       end function fdum
13977 !-----------------------------------------------------------------------------
13978 ! intcartderiv.F
13979 !-----------------------------------------------------------------------------
13980       subroutine intcartderiv
13981 !      implicit real*8 (a-h,o-z)
13982 !      include 'DIMENSIONS'
13983 #ifdef MPI
13984       include 'mpif.h'
13985 #endif
13986 !      include 'COMMON.SETUP'
13987 !      include 'COMMON.CHAIN'
13988 !      include 'COMMON.VAR'
13989 !      include 'COMMON.GEO'
13990 !      include 'COMMON.INTERACT'
13991 !      include 'COMMON.DERIV'
13992 !      include 'COMMON.IOUNITS'
13993 !      include 'COMMON.LOCAL'
13994 !      include 'COMMON.SCCOR'
13995       real(kind=8) :: pi4,pi34
13996       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
13997       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
13998                     dcosomega,dsinomega !(3,3,maxres)
13999       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14000
14001       integer :: i,j,k
14002       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14003                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14004                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14005                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14006       integer :: nres2
14007       nres2=2*nres
14008
14009 !el from module energy-------------
14010 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14011 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14012 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14013
14014 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14015 !el      allocate(dsintau(3,3,3,0:nres2))
14016 !el      allocate(dtauangle(3,3,3,0:nres2))
14017 !el      allocate(domicron(3,2,2,0:nres2))
14018 !el      allocate(dcosomicron(3,2,2,0:nres2))
14019
14020
14021
14022 #if defined(MPI) && defined(PARINTDER)
14023       if (nfgtasks.gt.1 .and. me.eq.king) &
14024         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14025 #endif
14026       pi4 = 0.5d0*pipol
14027       pi34 = 3*pi4
14028
14029 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14030 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14031
14032 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14033       do i=1,nres
14034         do j=1,3
14035           dtheta(j,1,i)=0.0d0
14036           dtheta(j,2,i)=0.0d0
14037           dphi(j,1,i)=0.0d0
14038           dphi(j,2,i)=0.0d0
14039           dphi(j,3,i)=0.0d0
14040         enddo
14041       enddo
14042 ! Derivatives of theta's
14043 #if defined(MPI) && defined(PARINTDER)
14044 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14045       do i=max0(ithet_start-1,3),ithet_end
14046 #else
14047       do i=3,nres
14048 #endif
14049         cost=dcos(theta(i))
14050         sint=sqrt(1-cost*cost)
14051         do j=1,3
14052           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14053           vbld(i-1)
14054           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14055           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14056           vbld(i)
14057           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14058         enddo
14059       enddo
14060 #if defined(MPI) && defined(PARINTDER)
14061 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14062       do i=max0(ithet_start-1,3),ithet_end
14063 #else
14064       do i=3,nres
14065 #endif
14066       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14067         cost1=dcos(omicron(1,i))
14068         sint1=sqrt(1-cost1*cost1)
14069         cost2=dcos(omicron(2,i))
14070         sint2=sqrt(1-cost2*cost2)
14071        do j=1,3
14072 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14073           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14074           cost1*dc_norm(j,i-2))/ &
14075           vbld(i-1)
14076           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14077           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14078           +cost1*(dc_norm(j,i-1+nres)))/ &
14079           vbld(i-1+nres)
14080           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14081 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14082 !C Looks messy but better than if in loop
14083           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14084           +cost2*dc_norm(j,i-1))/ &
14085           vbld(i)
14086           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14087           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14088            +cost2*(-dc_norm(j,i-1+nres)))/ &
14089           vbld(i-1+nres)
14090 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14091           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14092         enddo
14093        endif
14094       enddo
14095 !elwrite(iout,*) "after vbld write"
14096 ! Derivatives of phi:
14097 ! If phi is 0 or 180 degrees, then the formulas
14098 ! have to be derived by power series expansion of the
14099 ! conventional formulas around 0 and 180.
14100 #ifdef PARINTDER
14101       do i=iphi1_start,iphi1_end
14102 #else
14103       do i=4,nres
14104 #endif
14105 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14106 ! the conventional case
14107         sint=dsin(theta(i))
14108         sint1=dsin(theta(i-1))
14109         sing=dsin(phi(i))
14110         cost=dcos(theta(i))
14111         cost1=dcos(theta(i-1))
14112         cosg=dcos(phi(i))
14113         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14114         fac0=1.0d0/(sint1*sint)
14115         fac1=cost*fac0
14116         fac2=cost1*fac0
14117         fac3=cosg*cost1/(sint1*sint1)
14118         fac4=cosg*cost/(sint*sint)
14119 !    Obtaining the gamma derivatives from sine derivative
14120        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14121            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14122            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14123          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14124          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14125          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14126          do j=1,3
14127             ctgt=cost/sint
14128             ctgt1=cost1/sint1
14129             cosg_inv=1.0d0/cosg
14130             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14131             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14132               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14133             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14134             dsinphi(j,2,i)= &
14135               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14136               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14137             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14138             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14139               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14140 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14141             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14142             endif
14143 ! Bug fixed 3/24/05 (AL)
14144          enddo
14145 !   Obtaining the gamma derivatives from cosine derivative
14146         else
14147            do j=1,3
14148            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14149            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14150            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14151            dc_norm(j,i-3))/vbld(i-2)
14152            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14153            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14154            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14155            dcostheta(j,1,i)
14156            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14157            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14158            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14159            dc_norm(j,i-1))/vbld(i)
14160            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14161            endif
14162          enddo
14163         endif
14164       enddo
14165 !alculate derivative of Tauangle
14166 #ifdef PARINTDER
14167       do i=itau_start,itau_end
14168 #else
14169       do i=3,nres
14170 !elwrite(iout,*) " vecpr",i,nres
14171 #endif
14172        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14173 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14174 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14175 !c dtauangle(j,intertyp,dervityp,residue number)
14176 !c INTERTYP=1 SC...Ca...Ca..Ca
14177 ! the conventional case
14178         sint=dsin(theta(i))
14179         sint1=dsin(omicron(2,i-1))
14180         sing=dsin(tauangle(1,i))
14181         cost=dcos(theta(i))
14182         cost1=dcos(omicron(2,i-1))
14183         cosg=dcos(tauangle(1,i))
14184 !elwrite(iout,*) " vecpr5",i,nres
14185         do j=1,3
14186 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14187 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14188         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14189 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14190         enddo
14191         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14192         fac0=1.0d0/(sint1*sint)
14193         fac1=cost*fac0
14194         fac2=cost1*fac0
14195         fac3=cosg*cost1/(sint1*sint1)
14196         fac4=cosg*cost/(sint*sint)
14197 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14198 !    Obtaining the gamma derivatives from sine derivative
14199        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14200            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14201            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14202          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14203          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14204          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14205         do j=1,3
14206             ctgt=cost/sint
14207             ctgt1=cost1/sint1
14208             cosg_inv=1.0d0/cosg
14209             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14210        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14211        *vbld_inv(i-2+nres)
14212             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14213             dsintau(j,1,2,i)= &
14214               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14215               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14216 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14217             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14218 ! Bug fixed 3/24/05 (AL)
14219             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14220               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14221 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14222             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14223          enddo
14224 !   Obtaining the gamma derivatives from cosine derivative
14225         else
14226            do j=1,3
14227            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14228            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14229            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14230            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14231            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14232            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14233            dcostheta(j,1,i)
14234            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14235            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14236            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14237            dc_norm(j,i-1))/vbld(i)
14238            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14239 !         write (iout,*) "else",i
14240          enddo
14241         endif
14242 !        do k=1,3
14243 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14244 !        enddo
14245       enddo
14246 !C Second case Ca...Ca...Ca...SC
14247 #ifdef PARINTDER
14248       do i=itau_start,itau_end
14249 #else
14250       do i=4,nres
14251 #endif
14252        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14253           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14254 ! the conventional case
14255         sint=dsin(omicron(1,i))
14256         sint1=dsin(theta(i-1))
14257         sing=dsin(tauangle(2,i))
14258         cost=dcos(omicron(1,i))
14259         cost1=dcos(theta(i-1))
14260         cosg=dcos(tauangle(2,i))
14261 !        do j=1,3
14262 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14263 !        enddo
14264         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14265         fac0=1.0d0/(sint1*sint)
14266         fac1=cost*fac0
14267         fac2=cost1*fac0
14268         fac3=cosg*cost1/(sint1*sint1)
14269         fac4=cosg*cost/(sint*sint)
14270 !    Obtaining the gamma derivatives from sine derivative
14271        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14272            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14273            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14274          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14275          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14276          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14277         do j=1,3
14278             ctgt=cost/sint
14279             ctgt1=cost1/sint1
14280             cosg_inv=1.0d0/cosg
14281             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)
14283 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14284 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14285             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14286             dsintau(j,2,2,i)= &
14287               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14288               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14289 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14290 !     & sing*ctgt*domicron(j,1,2,i),
14291 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14292             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14293 ! Bug fixed 3/24/05 (AL)
14294             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14295              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14296 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14297             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14298          enddo
14299 !   Obtaining the gamma derivatives from cosine derivative
14300         else
14301            do j=1,3
14302            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14303            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14304            dc_norm(j,i-3))/vbld(i-2)
14305            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14306            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14307            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14308            dcosomicron(j,1,1,i)
14309            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14310            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14311            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14312            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14313            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14314 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14315          enddo
14316         endif
14317       enddo
14318
14319 !CC third case SC...Ca...Ca...SC
14320 #ifdef PARINTDER
14321
14322       do i=itau_start,itau_end
14323 #else
14324       do i=3,nres
14325 #endif
14326 ! the conventional case
14327       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14328       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14329         sint=dsin(omicron(1,i))
14330         sint1=dsin(omicron(2,i-1))
14331         sing=dsin(tauangle(3,i))
14332         cost=dcos(omicron(1,i))
14333         cost1=dcos(omicron(2,i-1))
14334         cosg=dcos(tauangle(3,i))
14335         do j=1,3
14336         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14337 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14338         enddo
14339         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14340         fac0=1.0d0/(sint1*sint)
14341         fac1=cost*fac0
14342         fac2=cost1*fac0
14343         fac3=cosg*cost1/(sint1*sint1)
14344         fac4=cosg*cost/(sint*sint)
14345 !    Obtaining the gamma derivatives from sine derivative
14346        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14347            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14348            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14349          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14350          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14351          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14352         do j=1,3
14353             ctgt=cost/sint
14354             ctgt1=cost1/sint1
14355             cosg_inv=1.0d0/cosg
14356             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14357               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14358               *vbld_inv(i-2+nres)
14359             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14360             dsintau(j,3,2,i)= &
14361               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14362               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14363             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14364 ! Bug fixed 3/24/05 (AL)
14365             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14366               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14367               *vbld_inv(i-1+nres)
14368 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14369             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14370          enddo
14371 !   Obtaining the gamma derivatives from cosine derivative
14372         else
14373            do j=1,3
14374            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14375            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14376            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14377            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14378            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14379            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14380            dcosomicron(j,1,1,i)
14381            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14382            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14383            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14384            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14385            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14386 !          write(iout,*) "else",i
14387          enddo
14388         endif
14389       enddo
14390
14391 #ifdef CRYST_SC
14392 !   Derivatives of side-chain angles alpha and omega
14393 #if defined(MPI) && defined(PARINTDER)
14394         do i=ibond_start,ibond_end
14395 #else
14396         do i=2,nres-1
14397 #endif
14398           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14399              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14400              fac6=fac5/vbld(i)
14401              fac7=fac5*fac5
14402              fac8=fac5/vbld(i+1)
14403              fac9=fac5/vbld(i+nres)
14404              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14405              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14406              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14407              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14408              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14409              sina=sqrt(1-cosa*cosa)
14410              sino=dsin(omeg(i))
14411 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14412              do j=1,3
14413                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14414                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14415                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14416                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14417                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14418                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14419                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14420                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14421                 vbld(i+nres))
14422                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14423             enddo
14424 ! obtaining the derivatives of omega from sines
14425             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14426                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14427                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14428                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14429                dsin(theta(i+1)))
14430                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14431                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14432                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14433                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14434                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14435                coso_inv=1.0d0/dcos(omeg(i))
14436                do j=1,3
14437                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14438                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14439                  (sino*dc_norm(j,i-1))/vbld(i)
14440                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14441                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14442                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14443                  -sino*dc_norm(j,i)/vbld(i+1)
14444                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14445                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14446                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14447                  vbld(i+nres)
14448                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14449               enddo
14450            else
14451 !   obtaining the derivatives of omega from cosines
14452              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14453              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14454              fac12=fac10*sina
14455              fac13=fac12*fac12
14456              fac14=sina*sina
14457              do j=1,3
14458                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14459                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14460                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14461                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14462                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14463                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14464                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14465                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14466                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14467                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14468                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14469                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14470                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14471                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14472                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14473             enddo
14474           endif
14475          else
14476            do j=1,3
14477              do k=1,3
14478                dalpha(k,j,i)=0.0d0
14479                domega(k,j,i)=0.0d0
14480              enddo
14481            enddo
14482          endif
14483        enddo
14484 #endif
14485 #if defined(MPI) && defined(PARINTDER)
14486       if (nfgtasks.gt.1) then
14487 #ifdef DEBUG
14488 !d      write (iout,*) "Gather dtheta"
14489 !d      call flush(iout)
14490       write (iout,*) "dtheta before gather"
14491       do i=1,nres
14492         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14493       enddo
14494 #endif
14495       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14496         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14497         king,FG_COMM,IERROR)
14498 #ifdef DEBUG
14499 !d      write (iout,*) "Gather dphi"
14500 !d      call flush(iout)
14501       write (iout,*) "dphi before gather"
14502       do i=1,nres
14503         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
14504       enddo
14505 #endif
14506       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
14507         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
14508         king,FG_COMM,IERROR)
14509 !d      write (iout,*) "Gather dalpha"
14510 !d      call flush(iout)
14511 #ifdef CRYST_SC
14512       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
14513         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14514         king,FG_COMM,IERROR)
14515 !d      write (iout,*) "Gather domega"
14516 !d      call flush(iout)
14517       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
14518         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14519         king,FG_COMM,IERROR)
14520 #endif
14521       endif
14522 #endif
14523 #ifdef DEBUG
14524       write (iout,*) "dtheta after gather"
14525       do i=1,nres
14526         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
14527       enddo
14528       write (iout,*) "dphi after gather"
14529       do i=1,nres
14530         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
14531       enddo
14532       write (iout,*) "dalpha after gather"
14533       do i=1,nres
14534         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
14535       enddo
14536       write (iout,*) "domega after gather"
14537       do i=1,nres
14538         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
14539       enddo
14540 #endif
14541       return
14542       end subroutine intcartderiv
14543 !-----------------------------------------------------------------------------
14544       subroutine checkintcartgrad
14545 !      implicit real*8 (a-h,o-z)
14546 !      include 'DIMENSIONS'
14547 #ifdef MPI
14548       include 'mpif.h'
14549 #endif
14550 !      include 'COMMON.CHAIN'
14551 !      include 'COMMON.VAR'
14552 !      include 'COMMON.GEO'
14553 !      include 'COMMON.INTERACT'
14554 !      include 'COMMON.DERIV'
14555 !      include 'COMMON.IOUNITS'
14556 !      include 'COMMON.SETUP'
14557       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
14558       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
14559       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
14560       real(kind=8),dimension(3) :: dc_norm_s
14561       real(kind=8) :: aincr=1.0d-5
14562       integer :: i,j
14563       real(kind=8) :: dcji
14564       do i=1,nres
14565         phi_s(i)=phi(i)
14566         theta_s(i)=theta(i)
14567         alph_s(i)=alph(i)
14568         omeg_s(i)=omeg(i)
14569       enddo
14570 ! Check theta gradient
14571       write (iout,*) &
14572        "Analytical (upper) and numerical (lower) gradient of theta"
14573       write (iout,*)
14574       do i=3,nres
14575         do j=1,3
14576           dcji=dc(j,i-2)
14577           dc(j,i-2)=dcji+aincr
14578           call chainbuild_cart
14579           call int_from_cart1(.false.)
14580           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
14581           dc(j,i-2)=dcji
14582           dcji=dc(j,i-1)
14583           dc(j,i-1)=dc(j,i-1)+aincr
14584           call chainbuild_cart
14585           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
14586           dc(j,i-1)=dcji
14587         enddo
14588 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
14589 !el          (dtheta(j,2,i),j=1,3)
14590 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
14591 !el          (dthetanum(j,2,i),j=1,3)
14592 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
14593 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
14594 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
14595 !el        write (iout,*)
14596       enddo
14597 ! Check gamma gradient
14598       write (iout,*) &
14599        "Analytical (upper) and numerical (lower) gradient of gamma"
14600       do i=4,nres
14601         do j=1,3
14602           dcji=dc(j,i-3)
14603           dc(j,i-3)=dcji+aincr
14604           call chainbuild_cart
14605           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
14606           dc(j,i-3)=dcji
14607           dcji=dc(j,i-2)
14608           dc(j,i-2)=dcji+aincr
14609           call chainbuild_cart
14610           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
14611           dc(j,i-2)=dcji
14612           dcji=dc(j,i-1)
14613           dc(j,i-1)=dc(j,i-1)+aincr
14614           call chainbuild_cart
14615           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
14616           dc(j,i-1)=dcji
14617         enddo
14618 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
14619 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
14620 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
14621 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
14622 !el        write (iout,'(5x,3(3f10.5,5x))') &
14623 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
14624 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
14625 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
14626 !el        write (iout,*)
14627       enddo
14628 ! Check alpha gradient
14629       write (iout,*) &
14630        "Analytical (upper) and numerical (lower) gradient of alpha"
14631       do i=2,nres-1
14632        if(itype(i).ne.10) then
14633             do j=1,3
14634               dcji=dc(j,i-1)
14635               dc(j,i-1)=dcji+aincr
14636               call chainbuild_cart
14637               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
14638               /aincr
14639               dc(j,i-1)=dcji
14640               dcji=dc(j,i)
14641               dc(j,i)=dcji+aincr
14642               call chainbuild_cart
14643               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
14644               /aincr
14645               dc(j,i)=dcji
14646               dcji=dc(j,i+nres)
14647               dc(j,i+nres)=dc(j,i+nres)+aincr
14648               call chainbuild_cart
14649               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
14650               /aincr
14651              dc(j,i+nres)=dcji
14652             enddo
14653           endif
14654 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
14655 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
14656 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
14657 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
14658 !el        write (iout,'(5x,3(3f10.5,5x))') &
14659 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
14660 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
14661 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
14662 !el        write (iout,*)
14663       enddo
14664 !     Check omega gradient
14665       write (iout,*) &
14666        "Analytical (upper) and numerical (lower) gradient of omega"
14667       do i=2,nres-1
14668        if(itype(i).ne.10) then
14669             do j=1,3
14670               dcji=dc(j,i-1)
14671               dc(j,i-1)=dcji+aincr
14672               call chainbuild_cart
14673               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
14674               /aincr
14675               dc(j,i-1)=dcji
14676               dcji=dc(j,i)
14677               dc(j,i)=dcji+aincr
14678               call chainbuild_cart
14679               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
14680               /aincr
14681               dc(j,i)=dcji
14682               dcji=dc(j,i+nres)
14683               dc(j,i+nres)=dc(j,i+nres)+aincr
14684               call chainbuild_cart
14685               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
14686               /aincr
14687              dc(j,i+nres)=dcji
14688             enddo
14689           endif
14690 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
14691 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
14692 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
14693 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
14694 !el        write (iout,'(5x,3(3f10.5,5x))') &
14695 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
14696 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
14697 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
14698 !el        write (iout,*)
14699       enddo
14700       return
14701       end subroutine checkintcartgrad
14702 !-----------------------------------------------------------------------------
14703 ! q_measure.F
14704 !-----------------------------------------------------------------------------
14705       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
14706 !      implicit real*8 (a-h,o-z)
14707 !      include 'DIMENSIONS'
14708 !      include 'COMMON.IOUNITS'
14709 !      include 'COMMON.CHAIN'
14710 !      include 'COMMON.INTERACT'
14711 !      include 'COMMON.VAR'
14712       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
14713       integer :: kkk,nsep=3
14714       real(kind=8) :: qm        !dist,
14715       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
14716       logical :: lprn=.false.
14717       logical :: flag
14718 !      real(kind=8) :: sigm,x
14719
14720 !el      sigm(x)=0.25d0*x     ! local function
14721       qqmax=1.0d10
14722       do kkk=1,nperm
14723       qq = 0.0d0
14724       nl=0
14725        if(flag) then
14726         do il=seg1+nsep,seg2
14727           do jl=seg1,il-nsep
14728             nl=nl+1
14729             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
14730                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
14731                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14732             dij=dist(il,jl)
14733             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14734             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14735               nl=nl+1
14736               d0ijCM=dsqrt( &
14737                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14738                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14739                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14740               dijCM=dist(il+nres,jl+nres)
14741               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14742             endif
14743             qq = qq+qqij+qqijCM
14744           enddo
14745         enddo
14746         qq = qq/nl
14747       else
14748       do il=seg1,seg2
14749         if((seg3-il).lt.3) then
14750              secseg=il+3
14751         else
14752              secseg=seg3
14753         endif
14754           do jl=secseg,seg4
14755             nl=nl+1
14756             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14757                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14758                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14759             dij=dist(il,jl)
14760             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14761             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14762               nl=nl+1
14763               d0ijCM=dsqrt( &
14764                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14765                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14766                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14767               dijCM=dist(il+nres,jl+nres)
14768               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14769             endif
14770             qq = qq+qqij+qqijCM
14771           enddo
14772         enddo
14773       qq = qq/nl
14774       endif
14775       if (qqmax.le.qq) qqmax=qq
14776       enddo
14777       qwolynes=1.0d0-qqmax
14778       return
14779       end function qwolynes
14780 !-----------------------------------------------------------------------------
14781       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
14782 !      implicit real*8 (a-h,o-z)
14783 !      include 'DIMENSIONS'
14784 !      include 'COMMON.IOUNITS'
14785 !      include 'COMMON.CHAIN'
14786 !      include 'COMMON.INTERACT'
14787 !      include 'COMMON.VAR'
14788 !      include 'COMMON.MD'
14789       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
14790       integer :: nsep=3, kkk
14791 !el      real(kind=8) :: dist
14792       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
14793       logical :: lprn=.false.
14794       logical :: flag
14795       real(kind=8) :: sim,dd0,fac,ddqij
14796 !el      sigm(x)=0.25d0*x            ! local function
14797       do kkk=1,nperm
14798       do i=0,nres
14799         do j=1,3
14800           dqwol(j,i)=0.0d0
14801           dxqwol(j,i)=0.0d0
14802         enddo
14803       enddo
14804       nl=0
14805        if(flag) then
14806         do il=seg1+nsep,seg2
14807           do jl=seg1,il-nsep
14808             nl=nl+1
14809             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14810                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14811                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14812             dij=dist(il,jl)
14813             sim = 1.0d0/sigm(d0ij)
14814             sim = sim*sim
14815             dd0 = dij-d0ij
14816             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14817             do k=1,3
14818               ddqij = (c(k,il)-c(k,jl))*fac
14819               dqwol(k,il)=dqwol(k,il)+ddqij
14820               dqwol(k,jl)=dqwol(k,jl)-ddqij
14821             enddo
14822
14823             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14824               nl=nl+1
14825               d0ijCM=dsqrt( &
14826                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14827                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14828                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14829               dijCM=dist(il+nres,jl+nres)
14830               sim = 1.0d0/sigm(d0ijCM)
14831               sim = sim*sim
14832               dd0=dijCM-d0ijCM
14833               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14834               do k=1,3
14835                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14836                 dxqwol(k,il)=dxqwol(k,il)+ddqij
14837                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14838               enddo
14839             endif
14840           enddo
14841         enddo
14842        else
14843         do il=seg1,seg2
14844         if((seg3-il).lt.3) then
14845              secseg=il+3
14846         else
14847              secseg=seg3
14848         endif
14849           do jl=secseg,seg4
14850             nl=nl+1
14851             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14852                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14853                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14854             dij=dist(il,jl)
14855             sim = 1.0d0/sigm(d0ij)
14856             sim = sim*sim
14857             dd0 = dij-d0ij
14858             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14859             do k=1,3
14860               ddqij = (c(k,il)-c(k,jl))*fac
14861               dqwol(k,il)=dqwol(k,il)+ddqij
14862               dqwol(k,jl)=dqwol(k,jl)-ddqij
14863             enddo
14864             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14865               nl=nl+1
14866               d0ijCM=dsqrt( &
14867                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14868                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14869                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14870               dijCM=dist(il+nres,jl+nres)
14871               sim = 1.0d0/sigm(d0ijCM)
14872               sim=sim*sim
14873               dd0 = dijCM-d0ijCM
14874               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14875               do k=1,3
14876                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14877                dxqwol(k,il)=dxqwol(k,il)+ddqij
14878                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14879               enddo
14880             endif
14881           enddo
14882         enddo
14883       endif
14884       enddo
14885        do i=0,nres
14886          do j=1,3
14887            dqwol(j,i)=dqwol(j,i)/nl
14888            dxqwol(j,i)=dxqwol(j,i)/nl
14889          enddo
14890        enddo
14891       return
14892       end subroutine qwolynes_prim
14893 !-----------------------------------------------------------------------------
14894       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
14895 !      implicit real*8 (a-h,o-z)
14896 !      include 'DIMENSIONS'
14897 !      include 'COMMON.IOUNITS'
14898 !      include 'COMMON.CHAIN'
14899 !      include 'COMMON.INTERACT'
14900 !      include 'COMMON.VAR'
14901       integer :: seg1,seg2,seg3,seg4
14902       logical :: flag
14903       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
14904       real(kind=8),dimension(3,0:2*nres) :: cdummy
14905       real(kind=8) :: q1,q2
14906       real(kind=8) :: delta=1.0d-10
14907       integer :: i,j
14908
14909       do i=0,nres
14910         do j=1,3
14911           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14912           cdummy(j,i)=c(j,i)
14913           c(j,i)=c(j,i)+delta
14914           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14915           qwolan(j,i)=(q2-q1)/delta
14916           c(j,i)=cdummy(j,i)
14917         enddo
14918       enddo
14919       do i=0,nres
14920         do j=1,3
14921           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14922           cdummy(j,i+nres)=c(j,i+nres)
14923           c(j,i+nres)=c(j,i+nres)+delta
14924           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14925           qwolxan(j,i)=(q2-q1)/delta
14926           c(j,i+nres)=cdummy(j,i+nres)
14927         enddo
14928       enddo
14929 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
14930 !      do i=0,nct
14931 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
14932 !      enddo
14933 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
14934 !      do i=0,nct
14935 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
14936 !      enddo
14937       return
14938       end subroutine qwol_num
14939 !-----------------------------------------------------------------------------
14940       subroutine EconstrQ
14941 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14942 !      implicit real*8 (a-h,o-z)
14943 !      include 'DIMENSIONS'
14944 !      include 'COMMON.CONTROL'
14945 !      include 'COMMON.VAR'
14946 !      include 'COMMON.MD'
14947       use MD_data
14948 !#ifndef LANG0
14949 !      include 'COMMON.LANGEVIN'
14950 !#else
14951 !      include 'COMMON.LANGEVIN.lang0'
14952 !#endif
14953 !      include 'COMMON.CHAIN'
14954 !      include 'COMMON.DERIV'
14955 !      include 'COMMON.GEO'
14956 !      include 'COMMON.LOCAL'
14957 !      include 'COMMON.INTERACT'
14958 !      include 'COMMON.IOUNITS'
14959 !      include 'COMMON.NAMES'
14960 !      include 'COMMON.TIME1'
14961       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
14962       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
14963                    duconst,duxconst
14964       integer :: kstart,kend,lstart,lend,idummy
14965       real(kind=8) :: delta=1.0d-7
14966       integer :: i,j,k,ii
14967       do i=0,nres
14968          do j=1,3
14969             duconst(j,i)=0.0d0
14970             dudconst(j,i)=0.0d0
14971             duxconst(j,i)=0.0d0
14972             dudxconst(j,i)=0.0d0
14973          enddo
14974       enddo
14975       Uconst=0.0d0
14976       do i=1,nfrag
14977          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14978            idummy,idummy)
14979          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
14980 ! Calculating the derivatives of Constraint energy with respect to Q
14981          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
14982            qinfrag(i,iset))
14983 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
14984 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
14985 !         hmnum=(hm2-hm1)/delta
14986 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
14987 !     &   qinfrag(i,iset))
14988 !         write(iout,*) "harmonicnum frag", hmnum
14989 ! Calculating the derivatives of Q with respect to cartesian coordinates
14990          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14991           idummy,idummy)
14992 !         write(iout,*) "dqwol "
14993 !         do ii=1,nres
14994 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
14995 !         enddo
14996 !         write(iout,*) "dxqwol "
14997 !         do ii=1,nres
14998 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
14999 !         enddo
15000 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15001 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15002 !     &  ,idummy,idummy)
15003 !  The gradients of Uconst in Cs
15004          do ii=0,nres
15005             do j=1,3
15006                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15007                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15008             enddo
15009          enddo
15010       enddo
15011       do i=1,npair
15012          kstart=ifrag(1,ipair(1,i,iset),iset)
15013          kend=ifrag(2,ipair(1,i,iset),iset)
15014          lstart=ifrag(1,ipair(2,i,iset),iset)
15015          lend=ifrag(2,ipair(2,i,iset),iset)
15016          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15017          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15018 !  Calculating dU/dQ
15019          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15020 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15021 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15022 !         hmnum=(hm2-hm1)/delta
15023 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15024 !     &   qinpair(i,iset))
15025 !         write(iout,*) "harmonicnum pair ", hmnum
15026 ! Calculating dQ/dXi
15027          call qwolynes_prim(kstart,kend,.false.,&
15028           lstart,lend)
15029 !         write(iout,*) "dqwol "
15030 !         do ii=1,nres
15031 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15032 !         enddo
15033 !         write(iout,*) "dxqwol "
15034 !         do ii=1,nres
15035 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15036 !        enddo
15037 ! Calculating numerical gradients
15038 !        call qwol_num(kstart,kend,.false.
15039 !     &  ,lstart,lend)
15040 ! The gradients of Uconst in Cs
15041          do ii=0,nres
15042             do j=1,3
15043                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15044                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15045             enddo
15046          enddo
15047       enddo
15048 !      write(iout,*) "Uconst inside subroutine ", Uconst
15049 ! Transforming the gradients from Cs to dCs for the backbone
15050       do i=0,nres
15051          do j=i+1,nres
15052            do k=1,3
15053              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15054            enddo
15055          enddo
15056       enddo
15057 !  Transforming the gradients from Cs to dCs for the side chains
15058       do i=1,nres
15059          do j=1,3
15060            dudxconst(j,i)=duxconst(j,i)
15061          enddo
15062       enddo
15063 !      write(iout,*) "dU/ddc backbone "
15064 !       do ii=0,nres
15065 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15066 !      enddo
15067 !      write(iout,*) "dU/ddX side chain "
15068 !      do ii=1,nres
15069 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15070 !      enddo
15071 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15072 !      call dEconstrQ_num
15073       return
15074       end subroutine EconstrQ
15075 !-----------------------------------------------------------------------------
15076       subroutine dEconstrQ_num
15077 ! Calculating numerical dUconst/ddc and dUconst/ddx
15078 !      implicit real*8 (a-h,o-z)
15079 !      include 'DIMENSIONS'
15080 !      include 'COMMON.CONTROL'
15081 !      include 'COMMON.VAR'
15082 !      include 'COMMON.MD'
15083       use MD_data
15084 !#ifndef LANG0
15085 !      include 'COMMON.LANGEVIN'
15086 !#else
15087 !      include 'COMMON.LANGEVIN.lang0'
15088 !#endif
15089 !      include 'COMMON.CHAIN'
15090 !      include 'COMMON.DERIV'
15091 !      include 'COMMON.GEO'
15092 !      include 'COMMON.LOCAL'
15093 !      include 'COMMON.INTERACT'
15094 !      include 'COMMON.IOUNITS'
15095 !      include 'COMMON.NAMES'
15096 !      include 'COMMON.TIME1'
15097       real(kind=8) :: uzap1,uzap2
15098       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15099       integer :: kstart,kend,lstart,lend,idummy
15100       real(kind=8) :: delta=1.0d-7
15101 !el local variables
15102       integer :: i,ii,j
15103 !     real(kind=8) ::
15104 !     For the backbone
15105       do i=0,nres-1
15106          do j=1,3
15107             dUcartan(j,i)=0.0d0
15108             cdummy(j,i)=dc(j,i)
15109             dc(j,i)=dc(j,i)+delta
15110             call chainbuild_cart
15111             uzap2=0.0d0
15112             do ii=1,nfrag
15113              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15114                 idummy,idummy)
15115                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15116                 qinfrag(ii,iset))
15117             enddo
15118             do ii=1,npair
15119                kstart=ifrag(1,ipair(1,ii,iset),iset)
15120                kend=ifrag(2,ipair(1,ii,iset),iset)
15121                lstart=ifrag(1,ipair(2,ii,iset),iset)
15122                lend=ifrag(2,ipair(2,ii,iset),iset)
15123                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15124                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15125                  qinpair(ii,iset))
15126             enddo
15127             dc(j,i)=cdummy(j,i)
15128             call chainbuild_cart
15129             uzap1=0.0d0
15130              do ii=1,nfrag
15131              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15132                 idummy,idummy)
15133                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15134                 qinfrag(ii,iset))
15135             enddo
15136             do ii=1,npair
15137                kstart=ifrag(1,ipair(1,ii,iset),iset)
15138                kend=ifrag(2,ipair(1,ii,iset),iset)
15139                lstart=ifrag(1,ipair(2,ii,iset),iset)
15140                lend=ifrag(2,ipair(2,ii,iset),iset)
15141                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15142                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15143                 qinpair(ii,iset))
15144             enddo
15145             ducartan(j,i)=(uzap2-uzap1)/(delta)
15146          enddo
15147       enddo
15148 ! Calculating numerical gradients for dU/ddx
15149       do i=0,nres-1
15150          duxcartan(j,i)=0.0d0
15151          do j=1,3
15152             cdummy(j,i)=dc(j,i+nres)
15153             dc(j,i+nres)=dc(j,i+nres)+delta
15154             call chainbuild_cart
15155             uzap2=0.0d0
15156             do ii=1,nfrag
15157              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15158                 idummy,idummy)
15159                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15160                 qinfrag(ii,iset))
15161             enddo
15162             do ii=1,npair
15163                kstart=ifrag(1,ipair(1,ii,iset),iset)
15164                kend=ifrag(2,ipair(1,ii,iset),iset)
15165                lstart=ifrag(1,ipair(2,ii,iset),iset)
15166                lend=ifrag(2,ipair(2,ii,iset),iset)
15167                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15168                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15169                 qinpair(ii,iset))
15170             enddo
15171             dc(j,i+nres)=cdummy(j,i)
15172             call chainbuild_cart
15173             uzap1=0.0d0
15174              do ii=1,nfrag
15175                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15176                 ifrag(2,ii,iset),.true.,idummy,idummy)
15177                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15178                 qinfrag(ii,iset))
15179             enddo
15180             do ii=1,npair
15181                kstart=ifrag(1,ipair(1,ii,iset),iset)
15182                kend=ifrag(2,ipair(1,ii,iset),iset)
15183                lstart=ifrag(1,ipair(2,ii,iset),iset)
15184                lend=ifrag(2,ipair(2,ii,iset),iset)
15185                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15186                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15187                 qinpair(ii,iset))
15188             enddo
15189             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15190          enddo
15191       enddo
15192       write(iout,*) "Numerical dUconst/ddc backbone "
15193       do ii=0,nres
15194         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15195       enddo
15196 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15197 !      do ii=1,nres
15198 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15199 !      enddo
15200       return
15201       end subroutine dEconstrQ_num
15202 !-----------------------------------------------------------------------------
15203 ! ssMD.F
15204 !-----------------------------------------------------------------------------
15205       subroutine check_energies
15206
15207 !      use random, only: ran_number
15208
15209 !      implicit none
15210 !     Includes
15211 !      include 'DIMENSIONS'
15212 !      include 'COMMON.CHAIN'
15213 !      include 'COMMON.VAR'
15214 !      include 'COMMON.IOUNITS'
15215 !      include 'COMMON.SBRIDGE'
15216 !      include 'COMMON.LOCAL'
15217 !      include 'COMMON.GEO'
15218
15219 !     External functions
15220 !EL      double precision ran_number
15221 !EL      external ran_number
15222
15223 !     Local variables
15224       integer :: i,j,k,l,lmax,p,pmax
15225       real(kind=8) :: rmin,rmax
15226       real(kind=8) :: eij
15227
15228       real(kind=8) :: d
15229       real(kind=8) :: wi,rij,tj,pj
15230 !      return
15231
15232       i=5
15233       j=14
15234
15235       d=dsc(1)
15236       rmin=2.0D0
15237       rmax=12.0D0
15238
15239       lmax=10000
15240       pmax=1
15241
15242       do k=1,3
15243         c(k,i)=0.0D0
15244         c(k,j)=0.0D0
15245         c(k,nres+i)=0.0D0
15246         c(k,nres+j)=0.0D0
15247       enddo
15248
15249       do l=1,lmax
15250
15251 !t        wi=ran_number(0.0D0,pi)
15252 !        wi=ran_number(0.0D0,pi/6.0D0)
15253 !        wi=0.0D0
15254 !t        tj=ran_number(0.0D0,pi)
15255 !t        pj=ran_number(0.0D0,pi)
15256 !        pj=ran_number(0.0D0,pi/6.0D0)
15257 !        pj=0.0D0
15258
15259         do p=1,pmax
15260 !t           rij=ran_number(rmin,rmax)
15261
15262            c(1,j)=d*sin(pj)*cos(tj)
15263            c(2,j)=d*sin(pj)*sin(tj)
15264            c(3,j)=d*cos(pj)
15265
15266            c(3,nres+i)=-rij
15267
15268            c(1,i)=d*sin(wi)
15269            c(3,i)=-rij-d*cos(wi)
15270
15271            do k=1,3
15272               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15273               dc_norm(k,nres+i)=dc(k,nres+i)/d
15274               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15275               dc_norm(k,nres+j)=dc(k,nres+j)/d
15276            enddo
15277
15278            call dyn_ssbond_ene(i,j,eij)
15279         enddo
15280       enddo
15281       call exit(1)
15282       return
15283       end subroutine check_energies
15284 !-----------------------------------------------------------------------------
15285       subroutine dyn_ssbond_ene(resi,resj,eij)
15286 !      implicit none
15287 !      Includes
15288       use calc_data
15289       use comm_sschecks
15290 !      include 'DIMENSIONS'
15291 !      include 'COMMON.SBRIDGE'
15292 !      include 'COMMON.CHAIN'
15293 !      include 'COMMON.DERIV'
15294 !      include 'COMMON.LOCAL'
15295 !      include 'COMMON.INTERACT'
15296 !      include 'COMMON.VAR'
15297 !      include 'COMMON.IOUNITS'
15298 !      include 'COMMON.CALC'
15299 #ifndef CLUST
15300 #ifndef WHAM
15301        use MD_data
15302 !      include 'COMMON.MD'
15303 !      use MD, only: totT,t_bath
15304 #endif
15305 #endif
15306 !     External functions
15307 !EL      double precision h_base
15308 !EL      external h_base
15309
15310 !     Input arguments
15311       integer :: resi,resj
15312
15313 !     Output arguments
15314       real(kind=8) :: eij
15315
15316 !     Local variables
15317       logical :: havebond
15318       integer itypi,itypj
15319       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15320       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15321       real(kind=8),dimension(3) :: dcosom1,dcosom2
15322       real(kind=8) :: ed
15323       real(kind=8) :: pom1,pom2
15324       real(kind=8) :: ljA,ljB,ljXs
15325       real(kind=8),dimension(1:3) :: d_ljB
15326       real(kind=8) :: ssA,ssB,ssC,ssXs
15327       real(kind=8) :: ssxm,ljxm,ssm,ljm
15328       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15329       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15330       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15331 !-------FIRST METHOD
15332       real(kind=8) :: xm
15333       real(kind=8),dimension(1:3) :: d_xm
15334 !-------END FIRST METHOD
15335 !-------SECOND METHOD
15336 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15337 !-------END SECOND METHOD
15338
15339 !-------TESTING CODE
15340 !el      logical :: checkstop,transgrad
15341 !el      common /sschecks/ checkstop,transgrad
15342
15343       integer :: icheck,nicheck,jcheck,njcheck
15344       real(kind=8),dimension(-1:1) :: echeck
15345       real(kind=8) :: deps,ssx0,ljx0
15346 !-------END TESTING CODE
15347
15348       eij=0.0d0
15349       i=resi
15350       j=resj
15351
15352 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15353 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15354
15355       itypi=itype(i)
15356       dxi=dc_norm(1,nres+i)
15357       dyi=dc_norm(2,nres+i)
15358       dzi=dc_norm(3,nres+i)
15359       dsci_inv=vbld_inv(i+nres)
15360
15361       itypj=itype(j)
15362       xj=c(1,nres+j)-c(1,nres+i)
15363       yj=c(2,nres+j)-c(2,nres+i)
15364       zj=c(3,nres+j)-c(3,nres+i)
15365       dxj=dc_norm(1,nres+j)
15366       dyj=dc_norm(2,nres+j)
15367       dzj=dc_norm(3,nres+j)
15368       dscj_inv=vbld_inv(j+nres)
15369
15370       chi1=chi(itypi,itypj)
15371       chi2=chi(itypj,itypi)
15372       chi12=chi1*chi2
15373       chip1=chip(itypi)
15374       chip2=chip(itypj)
15375       chip12=chip1*chip2
15376       alf1=alp(itypi)
15377       alf2=alp(itypj)
15378       alf12=0.5D0*(alf1+alf2)
15379
15380       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15381       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15382 !     The following are set in sc_angular
15383 !      erij(1)=xj*rij
15384 !      erij(2)=yj*rij
15385 !      erij(3)=zj*rij
15386 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15387 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15388 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15389       call sc_angular
15390       rij=1.0D0/rij  ! Reset this so it makes sense
15391
15392       sig0ij=sigma(itypi,itypj)
15393       sig=sig0ij*dsqrt(1.0D0/sigsq)
15394
15395       ljXs=sig-sig0ij
15396       ljA=eps1*eps2rt**2*eps3rt**2
15397       ljB=ljA*bb(itypi,itypj)
15398       ljA=ljA*aa(itypi,itypj)
15399       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15400
15401       ssXs=d0cm
15402       deltat1=1.0d0-om1
15403       deltat2=1.0d0+om2
15404       deltat12=om2-om1+2.0d0
15405       cosphi=om12-om1*om2
15406       ssA=akcm
15407       ssB=akct*deltat12
15408       ssC=ss_depth &
15409            +akth*(deltat1*deltat1+deltat2*deltat2) &
15410            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15411       ssxm=ssXs-0.5D0*ssB/ssA
15412
15413 !-------TESTING CODE
15414 !$$$c     Some extra output
15415 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15416 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15417 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15418 !$$$      if (ssx0.gt.0.0d0) then
15419 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15420 !$$$      else
15421 !$$$        ssx0=ssxm
15422 !$$$      endif
15423 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15424 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15425 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15426 !$$$      return
15427 !-------END TESTING CODE
15428
15429 !-------TESTING CODE
15430 !     Stop and plot energy and derivative as a function of distance
15431       if (checkstop) then
15432         ssm=ssC-0.25D0*ssB*ssB/ssA
15433         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15434         if (ssm.lt.ljm .and. &
15435              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15436           nicheck=1000
15437           njcheck=1
15438           deps=0.5d-7
15439         else
15440           checkstop=.false.
15441         endif
15442       endif
15443       if (.not.checkstop) then
15444         nicheck=0
15445         njcheck=-1
15446       endif
15447
15448       do icheck=0,nicheck
15449       do jcheck=-1,njcheck
15450       if (checkstop) rij=(ssxm-1.0d0)+ &
15451              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15452 !-------END TESTING CODE
15453
15454       if (rij.gt.ljxm) then
15455         havebond=.false.
15456         ljd=rij-ljXs
15457         fac=(1.0D0/ljd)**expon
15458         e1=fac*fac*aa(itypi,itypj)
15459         e2=fac*bb(itypi,itypj)
15460         eij=eps1*eps2rt*eps3rt*(e1+e2)
15461         eps2der=eij*eps3rt
15462         eps3der=eij*eps2rt
15463         eij=eij*eps2rt*eps3rt
15464
15465         sigder=-sig/sigsq
15466         e1=e1*eps1*eps2rt**2*eps3rt**2
15467         ed=-expon*(e1+eij)/ljd
15468         sigder=ed*sigder
15469         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15470         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15471         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15472              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15473       else if (rij.lt.ssxm) then
15474         havebond=.true.
15475         ssd=rij-ssXs
15476         eij=ssA*ssd*ssd+ssB*ssd+ssC
15477
15478         ed=2*akcm*ssd+akct*deltat12
15479         pom1=akct*ssd
15480         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15481         eom1=-2*akth*deltat1-pom1-om2*pom2
15482         eom2= 2*akth*deltat2+pom1-om1*pom2
15483         eom12=pom2
15484       else
15485         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15486
15487         d_ssxm(1)=0.5D0*akct/ssA
15488         d_ssxm(2)=-d_ssxm(1)
15489         d_ssxm(3)=0.0D0
15490
15491         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15492         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15493         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15494         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15495
15496 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15497         xm=0.5d0*(ssxm+ljxm)
15498         do k=1,3
15499           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15500         enddo
15501         if (rij.lt.xm) then
15502           havebond=.true.
15503           ssm=ssC-0.25D0*ssB*ssB/ssA
15504           d_ssm(1)=0.5D0*akct*ssB/ssA
15505           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15506           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15507           d_ssm(3)=omega
15508           f1=(rij-xm)/(ssxm-xm)
15509           f2=(rij-ssxm)/(xm-ssxm)
15510           h1=h_base(f1,hd1)
15511           h2=h_base(f2,hd2)
15512           eij=ssm*h1+Ht*h2
15513           delta_inv=1.0d0/(xm-ssxm)
15514           deltasq_inv=delta_inv*delta_inv
15515           fac=ssm*hd1-Ht*hd2
15516           fac1=deltasq_inv*fac*(xm-rij)
15517           fac2=deltasq_inv*fac*(rij-ssxm)
15518           ed=delta_inv*(Ht*hd2-ssm*hd1)
15519           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
15520           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
15521           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
15522         else
15523           havebond=.false.
15524           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15525           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
15526           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
15527           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
15528                alf12/eps3rt)
15529           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
15530           f1=(rij-ljxm)/(xm-ljxm)
15531           f2=(rij-xm)/(ljxm-xm)
15532           h1=h_base(f1,hd1)
15533           h2=h_base(f2,hd2)
15534           eij=Ht*h1+ljm*h2
15535           delta_inv=1.0d0/(ljxm-xm)
15536           deltasq_inv=delta_inv*delta_inv
15537           fac=Ht*hd1-ljm*hd2
15538           fac1=deltasq_inv*fac*(ljxm-rij)
15539           fac2=deltasq_inv*fac*(rij-xm)
15540           ed=delta_inv*(ljm*hd2-Ht*hd1)
15541           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
15542           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
15543           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
15544         endif
15545 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15546
15547 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15548 !$$$        ssd=rij-ssXs
15549 !$$$        ljd=rij-ljXs
15550 !$$$        fac1=rij-ljxm
15551 !$$$        fac2=rij-ssxm
15552 !$$$
15553 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
15554 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
15555 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
15556 !$$$
15557 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
15558 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
15559 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15560 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15561 !$$$        d_ssm(3)=omega
15562 !$$$
15563 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
15564 !$$$        do k=1,3
15565 !$$$          d_ljm(k)=ljm*d_ljB(k)
15566 !$$$        enddo
15567 !$$$        ljm=ljm*ljB
15568 !$$$
15569 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
15570 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
15571 !$$$        d_ss(2)=akct*ssd
15572 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
15573 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
15574 !$$$        d_ss(3)=omega
15575 !$$$
15576 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
15577 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
15578 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
15579 !$$$        do k=1,3
15580 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
15581 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
15582 !$$$        enddo
15583 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
15584 !$$$
15585 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
15586 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
15587 !$$$        h1=h_base(f1,hd1)
15588 !$$$        h2=h_base(f2,hd2)
15589 !$$$        eij=ss*h1+ljf*h2
15590 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
15591 !$$$        deltasq_inv=delta_inv*delta_inv
15592 !$$$        fac=ljf*hd2-ss*hd1
15593 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
15594 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
15595 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
15596 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
15597 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
15598 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
15599 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
15600 !$$$
15601 !$$$        havebond=.false.
15602 !$$$        if (ed.gt.0.0d0) havebond=.true.
15603 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15604
15605       endif
15606
15607       if (havebond) then
15608 !#ifndef CLUST
15609 !#ifndef WHAM
15610 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
15611 !          write(iout,'(a15,f12.2,f8.1,2i5)')
15612 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
15613 !        endif
15614 !#endif
15615 !#endif
15616         dyn_ssbond_ij(i,j)=eij
15617       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
15618         dyn_ssbond_ij(i,j)=1.0d300
15619 !#ifndef CLUST
15620 !#ifndef WHAM
15621 !        write(iout,'(a15,f12.2,f8.1,2i5)')
15622 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
15623 !#endif
15624 !#endif
15625       endif
15626
15627 !-------TESTING CODE
15628 !el      if (checkstop) then
15629         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
15630              "CHECKSTOP",rij,eij,ed
15631         echeck(jcheck)=eij
15632 !el      endif
15633       enddo
15634       if (checkstop) then
15635         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
15636       endif
15637       enddo
15638       if (checkstop) then
15639         transgrad=.true.
15640         checkstop=.false.
15641       endif
15642 !-------END TESTING CODE
15643
15644       do k=1,3
15645         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
15646         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
15647       enddo
15648       do k=1,3
15649         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
15650       enddo
15651       do k=1,3
15652         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15653              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15654              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15655         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15656              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15657              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15658       enddo
15659 !grad      do k=i,j-1
15660 !grad        do l=1,3
15661 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
15662 !grad        enddo
15663 !grad      enddo
15664
15665       do l=1,3
15666         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15667         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15668       enddo
15669
15670       return
15671       end subroutine dyn_ssbond_ene
15672 !-----------------------------------------------------------------------------
15673       real(kind=8) function h_base(x,deriv)
15674 !     A smooth function going 0->1 in range [0,1]
15675 !     It should NOT be called outside range [0,1], it will not work there.
15676       implicit none
15677
15678 !     Input arguments
15679       real(kind=8) :: x
15680
15681 !     Output arguments
15682       real(kind=8) :: deriv
15683
15684 !     Local variables
15685       real(kind=8) :: xsq
15686
15687
15688 !     Two parabolas put together.  First derivative zero at extrema
15689 !$$$      if (x.lt.0.5D0) then
15690 !$$$        h_base=2.0D0*x*x
15691 !$$$        deriv=4.0D0*x
15692 !$$$      else
15693 !$$$        deriv=1.0D0-x
15694 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
15695 !$$$        deriv=4.0D0*deriv
15696 !$$$      endif
15697
15698 !     Third degree polynomial.  First derivative zero at extrema
15699       h_base=x*x*(3.0d0-2.0d0*x)
15700       deriv=6.0d0*x*(1.0d0-x)
15701
15702 !     Fifth degree polynomial.  First and second derivatives zero at extrema
15703 !$$$      xsq=x*x
15704 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
15705 !$$$      deriv=x-1.0d0
15706 !$$$      deriv=deriv*deriv
15707 !$$$      deriv=30.0d0*xsq*deriv
15708
15709       return
15710       end function h_base
15711 !-----------------------------------------------------------------------------
15712       subroutine dyn_set_nss
15713 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
15714 !      implicit none
15715       use MD_data, only: totT,t_bath
15716 !     Includes
15717 !      include 'DIMENSIONS'
15718 #ifdef MPI
15719       include "mpif.h"
15720 #endif
15721 !      include 'COMMON.SBRIDGE'
15722 !      include 'COMMON.CHAIN'
15723 !      include 'COMMON.IOUNITS'
15724 !      include 'COMMON.SETUP'
15725 !      include 'COMMON.MD'
15726 !     Local variables
15727       real(kind=8) :: emin
15728       integer :: i,j,imin,ierr
15729       integer :: diff,allnss,newnss
15730       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15731                 newihpb,newjhpb
15732       logical :: found
15733       integer,dimension(0:nfgtasks) :: i_newnss
15734       integer,dimension(0:nfgtasks) :: displ
15735       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15736       integer :: g_newnss
15737
15738       allnss=0
15739       do i=1,nres-1
15740         do j=i+1,nres
15741           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
15742             allnss=allnss+1
15743             allflag(allnss)=0
15744             allihpb(allnss)=i
15745             alljhpb(allnss)=j
15746           endif
15747         enddo
15748       enddo
15749
15750 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15751
15752  1    emin=1.0d300
15753       do i=1,allnss
15754         if (allflag(i).eq.0 .and. &
15755              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
15756           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
15757           imin=i
15758         endif
15759       enddo
15760       if (emin.lt.1.0d300) then
15761         allflag(imin)=1
15762         do i=1,allnss
15763           if (allflag(i).eq.0 .and. &
15764                (allihpb(i).eq.allihpb(imin) .or. &
15765                alljhpb(i).eq.allihpb(imin) .or. &
15766                allihpb(i).eq.alljhpb(imin) .or. &
15767                alljhpb(i).eq.alljhpb(imin))) then
15768             allflag(i)=-1
15769           endif
15770         enddo
15771         goto 1
15772       endif
15773
15774 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15775
15776       newnss=0
15777       do i=1,allnss
15778         if (allflag(i).eq.1) then
15779           newnss=newnss+1
15780           newihpb(newnss)=allihpb(i)
15781           newjhpb(newnss)=alljhpb(i)
15782         endif
15783       enddo
15784
15785 #ifdef MPI
15786       if (nfgtasks.gt.1)then
15787
15788         call MPI_Reduce(newnss,g_newnss,1,&
15789           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
15790         call MPI_Gather(newnss,1,MPI_INTEGER,&
15791                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
15792         displ(0)=0
15793         do i=1,nfgtasks-1,1
15794           displ(i)=i_newnss(i-1)+displ(i-1)
15795         enddo
15796         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
15797                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
15798                          king,FG_COMM,IERR)
15799         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
15800                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
15801                          king,FG_COMM,IERR)
15802         if(fg_rank.eq.0) then
15803 !         print *,'g_newnss',g_newnss
15804 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
15805 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
15806          newnss=g_newnss
15807          do i=1,newnss
15808           newihpb(i)=g_newihpb(i)
15809           newjhpb(i)=g_newjhpb(i)
15810          enddo
15811         endif
15812       endif
15813 #endif
15814
15815       diff=newnss-nss
15816
15817 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
15818
15819       do i=1,nss
15820         found=.false.
15821         do j=1,newnss
15822           if (idssb(i).eq.newihpb(j) .and. &
15823                jdssb(i).eq.newjhpb(j)) found=.true.
15824         enddo
15825 #ifndef CLUST
15826 #ifndef WHAM
15827         if (.not.found.and.fg_rank.eq.0) &
15828             write(iout,'(a15,f12.2,f8.1,2i5)') &
15829              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
15830 #endif
15831 #endif
15832       enddo
15833
15834       do i=1,newnss
15835         found=.false.
15836         do j=1,nss
15837           if (newihpb(i).eq.idssb(j) .and. &
15838                newjhpb(i).eq.jdssb(j)) found=.true.
15839         enddo
15840 #ifndef CLUST
15841 #ifndef WHAM
15842         if (.not.found.and.fg_rank.eq.0) &
15843             write(iout,'(a15,f12.2,f8.1,2i5)') &
15844              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
15845 #endif
15846 #endif
15847       enddo
15848
15849       nss=newnss
15850       do i=1,nss
15851         idssb(i)=newihpb(i)
15852         jdssb(i)=newjhpb(i)
15853       enddo
15854
15855       return
15856       end subroutine dyn_set_nss
15857 !-----------------------------------------------------------------------------
15858 #ifdef WHAM
15859       subroutine read_ssHist
15860 !      implicit none
15861 !      Includes
15862 !      include 'DIMENSIONS'
15863 !      include "DIMENSIONS.FREE"
15864 !      include 'COMMON.FREE'
15865 !     Local variables
15866       integer :: i,j
15867       character(len=80) :: controlcard
15868
15869       do i=1,dyn_nssHist
15870         call card_concat(controlcard,.true.)
15871         read(controlcard,*) &
15872              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
15873       enddo
15874
15875       return
15876       end subroutine read_ssHist
15877 #endif
15878 !-----------------------------------------------------------------------------
15879       integer function indmat(i,j)
15880 !el
15881 ! get the position of the jth ijth fragment of the chain coordinate system
15882 ! in the fromto array.
15883         integer :: i,j
15884
15885         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
15886       return
15887       end function indmat
15888 !-----------------------------------------------------------------------------
15889       real(kind=8) function sigm(x)
15890 !el
15891        real(kind=8) :: x
15892         sigm=0.25d0*x
15893       return
15894       end function sigm
15895 !-----------------------------------------------------------------------------
15896 !-----------------------------------------------------------------------------
15897       subroutine alloc_ener_arrays
15898 !EL Allocation of arrays used by module energy
15899
15900 !el local variables
15901       integer :: i,j
15902
15903       if(nres.lt.100) then
15904         maxconts=nres
15905       elseif(nres.lt.200) then
15906         maxconts=0.8*nres       ! Max. number of contacts per residue
15907       else
15908         maxconts=0.6*nres ! (maxconts=maxres/4)
15909       endif
15910       maxcont=12*nres   ! Max. number of SC contacts
15911       maxvar=6*nres     ! Max. number of variables
15912 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15913       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15914 !----------------------
15915 ! arrays in subroutine init_int_table
15916 !el#ifdef MPI
15917 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
15918 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
15919 !el#endif
15920       allocate(nint_gr(nres))
15921       allocate(nscp_gr(nres))
15922       allocate(ielstart(nres))
15923       allocate(ielend(nres))
15924 !(maxres)
15925       allocate(istart(nres,maxint_gr))
15926       allocate(iend(nres,maxint_gr))
15927 !(maxres,maxint_gr)
15928       allocate(iscpstart(nres,maxint_gr))
15929       allocate(iscpend(nres,maxint_gr))
15930 !(maxres,maxint_gr)
15931       allocate(ielstart_vdw(nres))
15932       allocate(ielend_vdw(nres))
15933 !(maxres)
15934
15935       allocate(lentyp(0:nfgtasks-1))
15936 !(0:maxprocs-1)
15937 !----------------------
15938 ! commom.contacts
15939 !      common /contacts/
15940       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
15941       allocate(icont(2,maxcont))
15942 !(2,maxcont)
15943 !      common /contacts1/
15944       allocate(num_cont(0:nres+4))
15945 !(maxres)
15946       allocate(jcont(maxconts,nres))
15947 !(maxconts,maxres)
15948       allocate(facont(maxconts,nres))
15949 !(maxconts,maxres)
15950       allocate(gacont(3,maxconts,nres))
15951 !(3,maxconts,maxres)
15952 !      common /contacts_hb/
15953       allocate(gacontp_hb1(3,maxconts,nres))
15954       allocate(gacontp_hb2(3,maxconts,nres))
15955       allocate(gacontp_hb3(3,maxconts,nres))
15956       allocate(gacontm_hb1(3,maxconts,nres))
15957       allocate(gacontm_hb2(3,maxconts,nres))
15958       allocate(gacontm_hb3(3,maxconts,nres))
15959       allocate(gacont_hbr(3,maxconts,nres))
15960       allocate(grij_hb_cont(3,maxconts,nres))
15961 !(3,maxconts,maxres)
15962       allocate(facont_hb(maxconts,nres))
15963       allocate(ees0p(maxconts,nres))
15964       allocate(ees0m(maxconts,nres))
15965       allocate(d_cont(maxconts,nres))
15966 !(maxconts,maxres)
15967       allocate(num_cont_hb(nres))
15968 !(maxres)
15969       allocate(jcont_hb(maxconts,nres))
15970 !(maxconts,maxres)
15971 !      common /rotat/
15972       allocate(Ug(2,2,nres))
15973       allocate(Ugder(2,2,nres))
15974       allocate(Ug2(2,2,nres))
15975       allocate(Ug2der(2,2,nres))
15976 !(2,2,maxres)
15977       allocate(obrot(2,nres))
15978       allocate(obrot2(2,nres))
15979       allocate(obrot_der(2,nres))
15980       allocate(obrot2_der(2,nres))
15981 !(2,maxres)
15982 !      common /precomp1/
15983       allocate(mu(2,nres))
15984       allocate(muder(2,nres))
15985       allocate(Ub2(2,nres))
15986         do i=1,nres
15987           Ub2(1,i)=0.0d0
15988           Ub2(2,i)=0.0d0
15989         enddo
15990       allocate(Ub2der(2,nres))
15991       allocate(Ctobr(2,nres))
15992       allocate(Ctobrder(2,nres))
15993       allocate(Dtobr2(2,nres))
15994       allocate(Dtobr2der(2,nres))
15995 !(2,maxres)
15996       allocate(EUg(2,2,nres))
15997       allocate(EUgder(2,2,nres))
15998       allocate(CUg(2,2,nres))
15999       allocate(CUgder(2,2,nres))
16000       allocate(DUg(2,2,nres))
16001       allocate(Dugder(2,2,nres))
16002       allocate(DtUg2(2,2,nres))
16003       allocate(DtUg2der(2,2,nres))
16004 !(2,2,maxres)
16005 !      common /precomp2/
16006       allocate(Ug2Db1t(2,nres))
16007       allocate(Ug2Db1tder(2,nres))
16008       allocate(CUgb2(2,nres))
16009       allocate(CUgb2der(2,nres))
16010 !(2,maxres)
16011       allocate(EUgC(2,2,nres))
16012       allocate(EUgCder(2,2,nres))
16013       allocate(EUgD(2,2,nres))
16014       allocate(EUgDder(2,2,nres))
16015       allocate(DtUg2EUg(2,2,nres))
16016       allocate(Ug2DtEUg(2,2,nres))
16017 !(2,2,maxres)
16018       allocate(Ug2DtEUgder(2,2,2,nres))
16019       allocate(DtUg2EUgder(2,2,2,nres))
16020 !(2,2,2,maxres)
16021 !      common /rotat_old/
16022       allocate(costab(nres))
16023       allocate(sintab(nres))
16024       allocate(costab2(nres))
16025       allocate(sintab2(nres))
16026 !(maxres)
16027 !      common /dipmat/
16028       allocate(a_chuj(2,2,maxconts,nres))
16029 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16030       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16031 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16032 !      common /contdistrib/
16033       allocate(ncont_sent(nres))
16034       allocate(ncont_recv(nres))
16035
16036       allocate(iat_sent(nres))
16037 !(maxres)
16038       allocate(iint_sent(4,nres,nres))
16039       allocate(iint_sent_local(4,nres,nres))
16040 !(4,maxres,maxres)
16041       allocate(iturn3_sent(4,0:nres+4))
16042       allocate(iturn4_sent(4,0:nres+4))
16043       allocate(iturn3_sent_local(4,nres))
16044       allocate(iturn4_sent_local(4,nres))
16045 !(4,maxres)
16046       allocate(itask_cont_from(0:nfgtasks-1))
16047       allocate(itask_cont_to(0:nfgtasks-1))
16048 !(0:max_fg_procs-1)
16049
16050
16051
16052 !----------------------
16053 ! commom.deriv;
16054 !      common /derivat/
16055       allocate(dcdv(6,maxdim))
16056       allocate(dxdv(6,maxdim))
16057 !(6,maxdim)
16058       allocate(dxds(6,nres))
16059 !(6,maxres)
16060       allocate(gradx(3,nres,0:2))
16061       allocate(gradc(3,nres,0:2))
16062 !(3,maxres,2)
16063       allocate(gvdwx(3,nres))
16064       allocate(gvdwc(3,nres))
16065       allocate(gelc(3,nres))
16066       allocate(gelc_long(3,nres))
16067       allocate(gvdwpp(3,nres))
16068       allocate(gvdwc_scpp(3,nres))
16069       allocate(gradx_scp(3,nres))
16070       allocate(gvdwc_scp(3,nres))
16071       allocate(ghpbx(3,nres))
16072       allocate(ghpbc(3,nres))
16073       allocate(gradcorr(3,nres))
16074       allocate(gradcorr_long(3,nres))
16075       allocate(gradcorr5_long(3,nres))
16076       allocate(gradcorr6_long(3,nres))
16077       allocate(gcorr6_turn_long(3,nres))
16078       allocate(gradxorr(3,nres))
16079       allocate(gradcorr5(3,nres))
16080       allocate(gradcorr6(3,nres))
16081 !(3,maxres)
16082       allocate(gloc(0:maxvar,0:2))
16083       allocate(gloc_x(0:maxvar,2))
16084 !(maxvar,2)
16085       allocate(gel_loc(3,nres))
16086       allocate(gel_loc_long(3,nres))
16087       allocate(gcorr3_turn(3,nres))
16088       allocate(gcorr4_turn(3,nres))
16089       allocate(gcorr6_turn(3,nres))
16090       allocate(gradb(3,nres))
16091       allocate(gradbx(3,nres))
16092 !(3,maxres)
16093       allocate(gel_loc_loc(maxvar))
16094       allocate(gel_loc_turn3(maxvar))
16095       allocate(gel_loc_turn4(maxvar))
16096       allocate(gel_loc_turn6(maxvar))
16097       allocate(gcorr_loc(maxvar))
16098       allocate(g_corr5_loc(maxvar))
16099       allocate(g_corr6_loc(maxvar))
16100 !(maxvar)
16101       allocate(gsccorc(3,nres))
16102       allocate(gsccorx(3,nres))
16103 !(3,maxres)
16104       allocate(gsccor_loc(nres))
16105 !(maxres)
16106       allocate(dtheta(3,2,nres))
16107 !(3,2,maxres)
16108       allocate(gscloc(3,nres))
16109       allocate(gsclocx(3,nres))
16110 !(3,maxres)
16111       allocate(dphi(3,3,nres))
16112       allocate(dalpha(3,3,nres))
16113       allocate(domega(3,3,nres))
16114 !(3,3,maxres)
16115 !      common /deriv_scloc/
16116       allocate(dXX_C1tab(3,nres))
16117       allocate(dYY_C1tab(3,nres))
16118       allocate(dZZ_C1tab(3,nres))
16119       allocate(dXX_Ctab(3,nres))
16120       allocate(dYY_Ctab(3,nres))
16121       allocate(dZZ_Ctab(3,nres))
16122       allocate(dXX_XYZtab(3,nres))
16123       allocate(dYY_XYZtab(3,nres))
16124       allocate(dZZ_XYZtab(3,nres))
16125 !(3,maxres)
16126 !      common /mpgrad/
16127       allocate(jgrad_start(nres))
16128       allocate(jgrad_end(nres))
16129 !(maxres)
16130 !----------------------
16131
16132 !      common /indices/
16133       allocate(ibond_displ(0:nfgtasks-1))
16134       allocate(ibond_count(0:nfgtasks-1))
16135       allocate(ithet_displ(0:nfgtasks-1))
16136       allocate(ithet_count(0:nfgtasks-1))
16137       allocate(iphi_displ(0:nfgtasks-1))
16138       allocate(iphi_count(0:nfgtasks-1))
16139       allocate(iphi1_displ(0:nfgtasks-1))
16140       allocate(iphi1_count(0:nfgtasks-1))
16141       allocate(ivec_displ(0:nfgtasks-1))
16142       allocate(ivec_count(0:nfgtasks-1))
16143       allocate(iset_displ(0:nfgtasks-1))
16144       allocate(iset_count(0:nfgtasks-1))
16145       allocate(iint_count(0:nfgtasks-1))
16146       allocate(iint_displ(0:nfgtasks-1))
16147 !(0:max_fg_procs-1)
16148 !----------------------
16149 ! common.MD
16150 !      common /mdgrad/
16151       allocate(gcart(3,0:nres))
16152       allocate(gxcart(3,0:nres))
16153 !(3,0:MAXRES)
16154       allocate(gradcag(3,nres))
16155       allocate(gradxag(3,nres))
16156 !(3,MAXRES)
16157 !      common /back_constr/
16158 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16159       allocate(dutheta(nres))
16160       allocate(dugamma(nres))
16161 !(maxres)
16162       allocate(duscdiff(3,nres))
16163       allocate(duscdiffx(3,nres))
16164 !(3,maxres)
16165 !el i io:read_fragments
16166 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16167 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16168 !      common /qmeas/
16169 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16170 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16171       allocate(mset(0:nprocs))  !(maxprocs/20)
16172       do i=0,nprocs
16173         mset(i)=0
16174       enddo
16175 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16176 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16177       allocate(dUdconst(3,0:nres))
16178       allocate(dUdxconst(3,0:nres))
16179       allocate(dqwol(3,0:nres))
16180       allocate(dxqwol(3,0:nres))
16181 !(3,0:MAXRES)
16182 !----------------------
16183 ! common.sbridge
16184 !      common /sbridge/ in io_common: read_bridge
16185 !el    allocate((:),allocatable :: iss  !(maxss)
16186 !      common /links/  in io_common: read_bridge
16187 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16188 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16189 !      common /dyn_ssbond/
16190 ! and side-chain vectors in theta or phi.
16191       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16192 !(maxres,maxres)
16193       do i=1,nres
16194         do j=i+1,nres
16195           dyn_ssbond_ij(i,j)=1.0d300
16196         enddo
16197       enddo
16198
16199       if (nss.gt.0) then
16200         allocate(idssb(nss),jdssb(nss))
16201 !(maxdim)
16202       endif
16203       allocate(dyn_ss_mask(nres))
16204 !(maxres)
16205       do i=1,nres
16206         dyn_ss_mask(i)=.false.
16207       enddo
16208 !----------------------
16209 ! common.sccor
16210 ! Parameters of the SCCOR term
16211 !      common/sccor/
16212 !el in io_conf: parmread
16213 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16214 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16215 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16216 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16217 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16218 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16219 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16220 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16221 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16222 !----------------
16223       allocate(gloc_sc(3,0:2*nres,0:10))
16224 !(3,0:maxres2,10)maxres2=2*maxres
16225       allocate(dcostau(3,3,3,2*nres))
16226       allocate(dsintau(3,3,3,2*nres))
16227       allocate(dtauangle(3,3,3,2*nres))
16228       allocate(dcosomicron(3,3,3,2*nres))
16229       allocate(domicron(3,3,3,2*nres))
16230 !(3,3,3,maxres2)maxres2=2*maxres
16231 !----------------------
16232 ! common.var
16233 !      common /restr/
16234       allocate(varall(maxvar))
16235 !(maxvar)(maxvar=6*maxres)
16236       allocate(mask_theta(nres))
16237       allocate(mask_phi(nres))
16238       allocate(mask_side(nres))
16239 !(maxres)
16240 !----------------------
16241 ! common.vectors
16242 !      common /vectors/
16243       allocate(uy(3,nres))
16244       allocate(uz(3,nres))
16245 !(3,maxres)
16246       allocate(uygrad(3,3,2,nres))
16247       allocate(uzgrad(3,3,2,nres))
16248 !(3,3,2,maxres)
16249
16250       return
16251       end subroutine alloc_ener_arrays
16252 !-----------------------------------------------------------------------------
16253 !-----------------------------------------------------------------------------
16254       end module energy