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 ! Maximum number of local shielding effectors
  33 !      integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der,gUb2      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(4) :: gmuij,gmuij1,gmuij2,gmuji1,gmuji2
  91       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  92        costab2,sintab2      !(maxres)
  93 ! This common block contains dipole-interaction matrices and their
  94 ! Cartesian derivatives.
  95 !      common /dipmat/
  96       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  97       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  98 !      common /diploc/
  99       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
 100        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 101       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 102        ADtEA1derg,AEAb2derg
 103       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 104        AECAderx,ADtEAderx,ADtEA1derx
 105       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 106       real(kind=8),dimension(3,2) :: g_contij
 107       real(kind=8) :: ekont
 108 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 109 !   RE: Parallelization of 4th and higher order loc-el correlations
 110 !      common /contdistrib/
 111       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 112 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 113 !-----------------------------------------------------------------------------
 114 ! commom.deriv;
 115 !      common /derivat/
 116 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 117 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 118 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 119       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 120         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 121         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 122         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 123         gliptranx, &
 124         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 125         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 126         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 127         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 128         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 129 !-----------------------------NUCLEIC GRADIENT
 130       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 131         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 132         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 133         gvdwpp_nucl
 134 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 135       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 136          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 137          gvdwc_peppho
 138 !------------------------------IONS GRADIENT
 139         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 140           gradpepcat,gradpepcatx
 141 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 142
 143
 144       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 145         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 146       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 147         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 148         g_corr6_loc      !(maxvar)
 149       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 150       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 151 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 152       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 153 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 154       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 155          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 156 !      integer :: nfl,icg
 157 !      common /deriv_loc/
 158       real(kind=8), dimension(:),allocatable :: fac_shield
 159       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 160 !      common /deriv_scloc/
 161       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 162        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 163        dZZ_XYZtab      !(3,maxres)
 164 !-----------------------------------------------------------------------------
 165 ! common.maxgrad
 166 !      common /maxgrad/
 167       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 168        gradb_max,ghpbc_max,&
 169        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 170        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 171        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 172        gsccorx_max,gsclocx_max
 173 !-----------------------------------------------------------------------------
 174 ! common.MD
 175 !      common /back_constr/
 176       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 177       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 178 !      common /qmeas/
 179       real(kind=8) :: Ucdfrag,Ucdpair
 180       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 181        dqwol,dxqwol      !(3,0:MAXRES)
 182 !-----------------------------------------------------------------------------
 183 ! common.sbridge
 184 !      common /dyn_ssbond/
 185       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 186 !-----------------------------------------------------------------------------
 187 ! common.sccor
 188 ! Parameters of the SCCOR term
 189 !      common/sccor/
 190       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 191        dcosomicron,domicron      !(3,3,3,maxres2)
 192 !-----------------------------------------------------------------------------
 193 ! common.vectors
 194 !      common /vectors/
 195       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 196       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 197 !-----------------------------------------------------------------------------
 198 ! common /przechowalnia/
 199       real(kind=8),dimension(:,:,:),allocatable :: zapas
 200       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 201       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 202 !-----------------------------------------------------------------------------
 203 !-----------------------------------------------------------------------------
 204 !
 205 !
 206 !-----------------------------------------------------------------------------
 207       contains
 208 !-----------------------------------------------------------------------------
 209 ! energy_p_new_barrier.F
 210 !-----------------------------------------------------------------------------
 211       subroutine etotal(energia)
 212 !      implicit real*8 (a-h,o-z)
 213 !      include 'DIMENSIONS'
 214       use MD_data
 215 #ifndef ISNAN
 216       external proc_proc
 217 #ifdef WINPGI
 218 !MS$ATTRIBUTES C ::  proc_proc
 219 #endif
 220 #endif
 221 #ifdef MPI
 222       include "mpif.h"
 223 #endif
 224 !      include 'COMMON.SETUP'
 225 !      include 'COMMON.IOUNITS'
 226       real(kind=8),dimension(0:n_ene) :: energia
 227 !      include 'COMMON.LOCAL'
 228 !      include 'COMMON.FFIELD'
 229 !      include 'COMMON.DERIV'
 230 !      include 'COMMON.INTERACT'
 231 !      include 'COMMON.SBRIDGE'
 232 !      include 'COMMON.CHAIN'
 233 !      include 'COMMON.VAR'
 234 !      include 'COMMON.MD'
 235 !      include 'COMMON.CONTROL'
 236 !      include 'COMMON.TIME1'
 237       real(kind=8) :: time00
 238 !el local variables
 239       integer :: n_corr,n_corr1,ierror
 240       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 241       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 242       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 243                       Eafmforce,ethetacnstr
 244       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 245 ! now energies for nulceic alone parameters
 246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 248                       ecorr3_nucl
 249 ! energies for ions
 250       real(kind=8) :: ecation_prot,ecationcation
 251 ! energies for protein nucleic acid interaction
 252       real(kind=8) :: escbase,epepbase,escpho,epeppho
 253
 254 #ifdef MPI
 255       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 256 ! shielding effect varibles for MPI
 257       real(kind=8) ::  fac_shieldbuf(nres), &
 258       grad_shield_locbuf1(3*maxcontsshi*nres), &
 259       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 260       grad_shield_locbuf2(3*maxcontsshi*nres), &
 261       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 262       grad_shieldbuf1(3*nres), &
 263       grad_shieldbuf2(3*nres)
 264
 265        integer ishield_listbuf(-1:nres), &
 266        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 267
 268
 269 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 270 !      real(kind=8), dimension(:,:,:),allocatable:: &
 271 !       grad_shield_locbuf,grad_shield_sidebuf
 272 !      real(kind=8), dimension(:,:),allocatable:: &
 273 !        grad_shieldbuf
 274 !       integer, dimension(:),allocatable:: &
 275 !       ishield_listbuf
 276 !       integer, dimension(:,:),allocatable::  shield_listbuf
 277 !       integer :: k,j,i
 278 !      if (.not.allocated(fac_shieldbuf)) then
 279 !          allocate(fac_shieldbuf(nres))
 280 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 281 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 282 !          allocate(grad_shieldbuf(3,-1:nres))
 283 !          allocate(ishield_listbuf(nres))
 284 !          allocate(shield_listbuf(maxcontsshi,nres))
 285 !       endif
 286
 287 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 288 !     & " nfgtasks",nfgtasks
 289       if (nfgtasks.gt.1) then
 290         time00=MPI_Wtime()
 291 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 292         if (fg_rank.eq.0) then
 293           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 294 !          print *,"Processor",myrank," BROADCAST iorder"
 295 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 296 ! FG slaves as WEIGHTS array.
 297           weights_(1)=wsc
 298           weights_(2)=wscp
 299           weights_(3)=welec
 300           weights_(4)=wcorr
 301           weights_(5)=wcorr5
 302           weights_(6)=wcorr6
 303           weights_(7)=wel_loc
 304           weights_(8)=wturn3
 305           weights_(9)=wturn4
 306           weights_(10)=wturn6
 307           weights_(11)=wang
 308           weights_(12)=wscloc
 309           weights_(13)=wtor
 310           weights_(14)=wtor_d
 311           weights_(15)=wstrain
 312           weights_(16)=wvdwpp
 313           weights_(17)=wbond
 314           weights_(18)=scal14
 315           weights_(21)=wsccor
 316           weights_(26)=wvdwpp_nucl
 317           weights_(27)=welpp
 318           weights_(28)=wvdwpsb
 319           weights_(29)=welpsb
 320           weights_(30)=wvdwsb
 321           weights_(31)=welsb
 322           weights_(32)=wbond_nucl
 323           weights_(33)=wang_nucl
 324           weights_(34)=wsbloc
 325           weights_(35)=wtor_nucl
 326           weights_(36)=wtor_d_nucl
 327           weights_(37)=wcorr_nucl
 328           weights_(38)=wcorr3_nucl
 329           weights_(41)=wcatcat
 330           weights_(42)=wcatprot
 331           weights_(46)=wscbase
 332           weights_(47)=wpepbase
 333           weights_(48)=wscpho
 334           weights_(49)=wpeppho
 335 !          wcatcat= weights(41)
 336 !          wcatprot=weights(42)
 337
 338 ! FG Master broadcasts the WEIGHTS_ array
 339           call MPI_Bcast(weights_(1),n_ene,&
 340              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 341         else
 342 ! FG slaves receive the WEIGHTS array
 343           call MPI_Bcast(weights(1),n_ene,&
 344               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 345           wsc=weights(1)
 346           wscp=weights(2)
 347           welec=weights(3)
 348           wcorr=weights(4)
 349           wcorr5=weights(5)
 350           wcorr6=weights(6)
 351           wel_loc=weights(7)
 352           wturn3=weights(8)
 353           wturn4=weights(9)
 354           wturn6=weights(10)
 355           wang=weights(11)
 356           wscloc=weights(12)
 357           wtor=weights(13)
 358           wtor_d=weights(14)
 359           wstrain=weights(15)
 360           wvdwpp=weights(16)
 361           wbond=weights(17)
 362           scal14=weights(18)
 363           wsccor=weights(21)
 364           wvdwpp_nucl =weights(26)
 365           welpp  =weights(27)
 366           wvdwpsb=weights(28)
 367           welpsb =weights(29)
 368           wvdwsb =weights(30)
 369           welsb  =weights(31)
 370           wbond_nucl  =weights(32)
 371           wang_nucl   =weights(33)
 372           wsbloc =weights(34)
 373           wtor_nucl   =weights(35)
 374           wtor_d_nucl =weights(36)
 375           wcorr_nucl  =weights(37)
 376           wcorr3_nucl =weights(38)
 377           wcatcat= weights(41)
 378           wcatprot=weights(42)
 379           wscbase=weights(46)
 380           wpepbase=weights(47)
 381           wscpho=weights(48)
 382           wpeppho=weights(49)
 383 !      welpsb=weights(28)*fact(1)
 384 !
 385 !      wcorr_nucl= weights(37)*fact(1)
 386 !     wcorr3_nucl=weights(38)*fact(2)
 387 !     wtor_nucl=  weights(35)*fact(1)
 388 !     wtor_d_nucl=weights(36)*fact(2)
 389
 390         endif
 391         time_Bcast=time_Bcast+MPI_Wtime()-time00
 392         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 393 !        call chainbuild_cart
 394       endif
 395 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 396 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 397 #else
 398 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 399 !        call int_from_cart1(.false.)
 400 !      endif
 401 #endif
 402 #ifdef TIMING
 403       time00=MPI_Wtime()
 404 #endif
 405 !
 406 ! Compute the side-chain and electrostatic interaction energy
 407 !        print *, "Before EVDW"
 408 !      goto (101,102,103,104,105,106) ipot
 409       select case(ipot)
 410 ! Lennard-Jones potential.
 411 !  101 call elj(evdw)
 412        case (1)
 413          call elj(evdw)
 414 !d    print '(a)','Exit ELJcall el'
 415 !      goto 107
 416 ! Lennard-Jones-Kihara potential (shifted).
 417 !  102 call eljk(evdw)
 418        case (2)
 419          call eljk(evdw)
 420 !      goto 107
 421 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 422 !  103 call ebp(evdw)
 423        case (3)
 424          call ebp(evdw)
 425 !      goto 107
 426 ! Gay-Berne potential (shifted LJ, angular dependence).
 427 !  104 call egb(evdw)
 428        case (4)
 429 !       print *,"MOMO",scelemode
 430         if (scelemode.eq.0) then
 431          call egb(evdw)
 432         else
 433          call emomo(evdw)
 434         endif
 435 !      goto 107
 436 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 437 !  105 call egbv(evdw)
 438        case (5)
 439          call egbv(evdw)
 440 !      goto 107
 441 ! Soft-sphere potential
 442 !  106 call e_softsphere(evdw)
 443        case (6)
 444          call e_softsphere(evdw)
 445 !
 446 ! Calculate electrostatic (H-bonding) energy of the main chain.
 447 !
 448 !  107 continue
 449        case default
 450          write(iout,*)"Wrong ipot"
 451 !         return
 452 !   50 continue
 453       end select
 454 !      continue
 455 !        print *,"after EGB"
 456 ! shielding effect
 457        if (shield_mode.eq.2) then
 458                  call set_shield_fac2
 459
 460       if (nfgtasks.gt.1) then
 461       grad_shield_sidebuf1(:)=0.0d0
 462       grad_shield_locbuf1(:)=0.0d0
 463       grad_shield_sidebuf2(:)=0.0d0
 464       grad_shield_locbuf2(:)=0.0d0
 465       grad_shieldbuf1(:)=0.0d0
 466       grad_shieldbuf2(:)=0.0d0
 467 !#define DEBUG
 468 #ifdef DEBUG
 469        write(iout,*) "befor reduce fac_shield reduce"
 470        do i=1,nres
 471         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 472         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 473        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 474        enddo
 475 #endif
 476         iii=0
 477         jjj=0
 478         do i=1,nres
 479         ishield_listbuf(i)=0
 480         do k=1,3
 481         iii=iii+1
 482         grad_shieldbuf1(iii)=grad_shield(k,i)
 483         enddo
 484         enddo
 485         do i=1,nres
 486          do j=1,maxcontsshi
 487           do k=1,3
 488               jjj=jjj+1
 489               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 490               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 491            enddo
 492           enddo
 493          enddo
 494         call MPI_Allgatherv(fac_shield(ivec_start), &
 495         ivec_count(fg_rank1), &
 496         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 497         ivec_displ(0), &
 498         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 499         call MPI_Allgatherv(shield_list(1,ivec_start), &
 500         ivec_count(fg_rank1), &
 501         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 502         ivec_displ(0), &
 503         MPI_I50,FG_COMM,IERROR)
 504 !        write(2,*) "After I50"
 505 !        call flush(iout)
 506         call MPI_Allgatherv(ishield_list(ivec_start), &
 507         ivec_count(fg_rank1), &
 508         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 509         ivec_displ(0), &
 510         MPI_INTEGER,FG_COMM,IERROR)
 511 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 512
 513 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 514 !        write (2,*) "before"
 515 !        write(2,*) grad_shieldbuf1
 516 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 517 !        ivec_count(fg_rank1)*3, &
 518 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 519 !        ivec_count(0), &
 520 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 521         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 522         nres*3, &
 523         MPI_DOUBLE_PRECISION, &
 524         MPI_SUM, &
 525         FG_COMM,IERROR)
 526         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 527         nres*3*maxcontsshi, &
 528         MPI_DOUBLE_PRECISION, &
 529         MPI_SUM, &
 530         FG_COMM,IERROR)
 531
 532         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 533         nres*3*maxcontsshi, &
 534         MPI_DOUBLE_PRECISION, &
 535         MPI_SUM, &
 536         FG_COMM,IERROR)
 537
 538 !        write(2,*) "after"
 539 !        write(2,*) grad_shieldbuf2
 540
 541 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 542 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 543 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 544 !        ivec_displ(0)*3*maxcontsshi, &
 545 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 546 !        write(2,*) "After grad_shield_side"
 547 !        call flush(iout)
 548 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 549 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 550 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 551 !        ivec_displ(0)*3*maxcontsshi, &
 552 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 553 !        write(2,*) "After MPI_SHI"
 554 !        call flush(iout)
 555         iii=0
 556         jjj=0
 557         do i=1,nres
 558          fac_shield(i)=fac_shieldbuf(i)
 559          ishield_list(i)=ishield_listbuf(i)
 560 !         write(iout,*) i,fac_shield(i)
 561          do j=1,3
 562          iii=iii+1
 563          grad_shield(j,i)=grad_shieldbuf2(iii)
 564          enddo !j
 565          do j=1,ishield_list(i)
 566 !          write (iout,*) "ishild", ishield_list(i),i
 567            shield_list(j,i)=shield_listbuf(j,i)
 568           enddo
 569           do j=1,maxcontsshi
 570           do k=1,3
 571            jjj=jjj+1
 572           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 573           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 574           enddo !k
 575         enddo !j
 576        enddo !i
 577        endif
 578 #ifdef DEBUG
 579        write(iout,*) "after reduce fac_shield reduce"
 580        do i=1,nres
 581         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 582         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 583         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 584        enddo
 585 #endif
 586 #undef DEBUG
 587        endif
 588
 589
 590
 591 !       print *,"AFTER EGB",ipot,evdw
 592 !mc
 593 !mc Sep-06: egb takes care of dynamic ss bonds too
 594 !mc
 595 !      if (dyn_ss) call dyn_set_nss
 596 !      print *,"Processor",myrank," computed USCSC"
 597 #ifdef TIMING
 598       time01=MPI_Wtime()
 599 #endif
 600       call vec_and_deriv
 601 #ifdef TIMING
 602       time_vec=time_vec+MPI_Wtime()-time01
 603 #endif
 604
 605
 606
 607
 608 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 609       if (ipot.lt.6) then
 610 #ifdef SPLITELE
 611 !         print *,"after ipot if", ipot
 612          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 613              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 614              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 615              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 616 #else
 617          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 618              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 619              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 620              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 621 #endif
 622 !            print *,"just befor eelec call"
 623             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 624 !            print *, "ELEC calc"
 625          else
 626             ees=0.0d0
 627             evdw1=0.0d0
 628             eel_loc=0.0d0
 629             eello_turn3=0.0d0
 630             eello_turn4=0.0d0
 631          endif
 632       else
 633 !        write (iout,*) "Soft-spheer ELEC potential"
 634         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 635          eello_turn4)
 636       endif
 637 !      print *,"Processor",myrank," computed UELEC"
 638 !
 639 ! Calculate excluded-volume interaction energy between peptide groups
 640 ! and side chains.
 641 !
 642 !       write(iout,*) "in etotal calc exc;luded",ipot
 643
 644       if (ipot.lt.6) then
 645        if(wscp.gt.0d0) then
 646         call escp(evdw2,evdw2_14)
 647        else
 648         evdw2=0
 649         evdw2_14=0
 650        endif
 651       else
 652 !        write (iout,*) "Soft-sphere SCP potential"
 653         call escp_soft_sphere(evdw2,evdw2_14)
 654       endif
 655 !        write(iout,*) "in etotal before ebond",ipot
 656
 657 !
 658 ! Calculate the bond-stretching energy
 659 !
 660       call ebond(estr)
 661 !       print *,"EBOND",estr
 662 !       write(iout,*) "in etotal afer ebond",ipot
 663
 664 !
 665 ! Calculate the disulfide-bridge and other energy and the contributions
 666 ! from other distance constraints.
 667 !      print *,'Calling EHPB'
 668       call edis(ehpb)
 669 !elwrite(iout,*) "in etotal afer edis",ipot
 670 !      print *,'EHPB exitted succesfully.'
 671 !
 672 ! Calculate the virtual-bond-angle energy.
 673 !       write(iout,*) "in etotal afer edis",ipot
 674
 675 !      if (wang.gt.0.0d0) then
 676 !        call ebend(ebe,ethetacnstr)
 677 !      else
 678 !        ebe=0
 679 !        ethetacnstr=0
 680 !      endif
 681       if (wang.gt.0d0) then
 682        if (tor_mode.eq.0) then
 683          call ebend(ebe)
 684        else
 685 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 686 !C energy function
 687          call ebend_kcc(ebe)
 688        endif
 689       else
 690         ebe=0.0d0
 691       endif
 692       ethetacnstr=0.0d0
 693       if (with_theta_constr) call etheta_constr(ethetacnstr)
 694
 695 !       write(iout,*) "in etotal afer ebe",ipot
 696
 697 !      print *,"Processor",myrank," computed UB"
 698 !
 699 ! Calculate the SC local energy.
 700 !
 701       call esc(escloc)
 702 !elwrite(iout,*) "in etotal afer esc",ipot
 703 !      print *,"Processor",myrank," computed USC"
 704 !
 705 ! Calculate the virtual-bond torsional energy.
 706 !
 707 !d    print *,'nterm=',nterm
 708 !      if (wtor.gt.0) then
 709 !       call etor(etors,edihcnstr)
 710 !      else
 711 !       etors=0
 712 !       edihcnstr=0
 713 !      endif
 714       if (wtor.gt.0.0d0) then
 715          if (tor_mode.eq.0) then
 716            call etor(etors)
 717          else
 718 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 719 !C energy function
 720            call etor_kcc(etors)
 721          endif
 722       else
 723         etors=0.0d0
 724       endif
 725       edihcnstr=0.0d0
 726       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 727 !c      print *,"Processor",myrank," computed Utor"
 728
 729 !      print *,"Processor",myrank," computed Utor"
 730
 731 !
 732 ! 6/23/01 Calculate double-torsional energy
 733 !
 734 !elwrite(iout,*) "in etotal",ipot
 735       if (wtor_d.gt.0) then
 736        call etor_d(etors_d)
 737       else
 738        etors_d=0
 739       endif
 740 !      print *,"Processor",myrank," computed Utord"
 741 !
 742 ! 21/5/07 Calculate local sicdechain correlation energy
 743 !
 744       if (wsccor.gt.0.0d0) then
 745         call eback_sc_corr(esccor)
 746       else
 747         esccor=0.0d0
 748       endif
 749
 750 !      write(iout,*) "before multibody"
 751       call flush(iout)
 752 !      print *,"Processor",myrank," computed Usccorr"
 753 !
 754 ! 12/1/95 Multi-body terms
 755 !
 756       n_corr=0
 757       n_corr1=0
 758       call flush(iout)
 759       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 760           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 761          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 762 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 763 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 764       else
 765          ecorr=0.0d0
 766          ecorr5=0.0d0
 767          ecorr6=0.0d0
 768          eturn6=0.0d0
 769       endif
 770 !elwrite(iout,*) "in etotal",ipot
 771       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 772          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 773 !d         write (iout,*) "multibody_hb ecorr",ecorr
 774       endif
 775 !      write(iout,*) "afeter  multibody hb"
 776
 777 !      print *,"Processor",myrank," computed Ucorr"
 778 !
 779 ! If performing constraint dynamics, call the constraint energy
 780 !  after the equilibration time
 781       if(usampl.and.totT.gt.eq_time) then
 782 !elwrite(iout,*) "afeter  multibody hb"
 783          call EconstrQ
 784 !elwrite(iout,*) "afeter  multibody hb"
 785          call Econstr_back
 786 !elwrite(iout,*) "afeter  multibody hb"
 787       else
 788          Uconst=0.0d0
 789          Uconst_back=0.0d0
 790       endif
 791       call flush(iout)
 792 !         write(iout,*) "after Econstr"
 793
 794       if (wliptran.gt.0) then
 795 !        print *,"PRZED WYWOLANIEM"
 796         call Eliptransfer(eliptran)
 797       else
 798        eliptran=0.0d0
 799       endif
 800       if (fg_rank.eq.0) then
 801       if (AFMlog.gt.0) then
 802         call AFMforce(Eafmforce)
 803       else if (selfguide.gt.0) then
 804         call AFMvel(Eafmforce)
 805       else
 806         Eafmforce=0.0d0
 807       endif
 808       endif
 809       if (tubemode.eq.1) then
 810        call calctube(etube)
 811       else if (tubemode.eq.2) then
 812        call calctube2(etube)
 813       elseif (tubemode.eq.3) then
 814        call calcnano(etube)
 815       else
 816        etube=0.0d0
 817       endif
 818 !--------------------------------------------------------
 819 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 820 !      print *,"before",ees,evdw1,ecorr
 821 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 822       if (nres_molec(2).gt.0) then
 823       call ebond_nucl(estr_nucl)
 824       call ebend_nucl(ebe_nucl)
 825       call etor_nucl(etors_nucl)
 826       call esb_gb(evdwsb,eelsb)
 827       call epp_nucl_sub(evdwpp,eespp)
 828       call epsb(evdwpsb,eelpsb)
 829       call esb(esbloc)
 830       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 831       else
 832        etors_nucl=0.0d0
 833        estr_nucl=0.0d0
 834        ecorr3_nucl=0.0d0
 835        ebe_nucl=0.0d0
 836        evdwsb=0.0d0
 837        eelsb=0.0d0
 838        esbloc=0.0d0
 839        evdwpsb=0.0d0
 840        eelpsb=0.0d0
 841        evdwpp=0.0d0
 842        eespp=0.0d0
 843       endif
 844 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 845 !      print *,"before ecatcat",wcatcat
 846       if (nfgtasks.gt.1) then
 847       if (fg_rank.eq.0) then
 848       call ecatcat(ecationcation)
 849       endif
 850       else
 851       call ecatcat(ecationcation)
 852       endif
 853       call ecat_prot(ecation_prot)
 854       if (nres_molec(2).gt.0) then
 855       call eprot_sc_base(escbase)
 856       call epep_sc_base(epepbase)
 857       call eprot_sc_phosphate(escpho)
 858       call eprot_pep_phosphate(epeppho)
 859       else
 860       epepbase=0.0
 861       escbase=0.0
 862       escpho=0.0
 863       epeppho=0.0
 864       endif
 865 !      call ecatcat(ecationcation)
 866 !      print *,"after ebend", wtor_nucl
 867 #ifdef TIMING
 868       time_enecalc=time_enecalc+MPI_Wtime()-time00
 869 #endif
 870 !      print *,"Processor",myrank," computed Uconstr"
 871 #ifdef TIMING
 872       time00=MPI_Wtime()
 873 #endif
 874 !
 875 ! Sum the energies
 876 !
 877       energia(1)=evdw
 878 #ifdef SCP14
 879       energia(2)=evdw2-evdw2_14
 880       energia(18)=evdw2_14
 881 #else
 882       energia(2)=evdw2
 883       energia(18)=0.0d0
 884 #endif
 885 #ifdef SPLITELE
 886       energia(3)=ees
 887       energia(16)=evdw1
 888 #else
 889       energia(3)=ees+evdw1
 890       energia(16)=0.0d0
 891 #endif
 892       energia(4)=ecorr
 893       energia(5)=ecorr5
 894       energia(6)=ecorr6
 895       energia(7)=eel_loc
 896       energia(8)=eello_turn3
 897       energia(9)=eello_turn4
 898       energia(10)=eturn6
 899       energia(11)=ebe
 900       energia(12)=escloc
 901       energia(13)=etors
 902       energia(14)=etors_d
 903       energia(15)=ehpb
 904       energia(19)=edihcnstr
 905       energia(17)=estr
 906       energia(20)=Uconst+Uconst_back
 907       energia(21)=esccor
 908       energia(22)=eliptran
 909       energia(23)=Eafmforce
 910       energia(24)=ethetacnstr
 911       energia(25)=etube
 912 !---------------------------------------------------------------
 913       energia(26)=evdwpp
 914       energia(27)=eespp
 915       energia(28)=evdwpsb
 916       energia(29)=eelpsb
 917       energia(30)=evdwsb
 918       energia(31)=eelsb
 919       energia(32)=estr_nucl
 920       energia(33)=ebe_nucl
 921       energia(34)=esbloc
 922       energia(35)=etors_nucl
 923       energia(36)=etors_d_nucl
 924       energia(37)=ecorr_nucl
 925       energia(38)=ecorr3_nucl
 926 !----------------------------------------------------------------------
 927 !    Here are the energies showed per procesor if the are more processors
 928 !    per molecule then we sum it up in sum_energy subroutine
 929 !      print *," Processor",myrank," calls SUM_ENERGY"
 930       energia(42)=ecation_prot
 931       energia(41)=ecationcation
 932       energia(46)=escbase
 933       energia(47)=epepbase
 934       energia(48)=escpho
 935       energia(49)=epeppho
 936       call sum_energy(energia,.true.)
 937       if (dyn_ss) call dyn_set_nss
 938 !      print *," Processor",myrank," left SUM_ENERGY"
 939 #ifdef TIMING
 940       time_sumene=time_sumene+MPI_Wtime()-time00
 941 #endif
 942 !        call enerprint(energia)
 943 !elwrite(iout,*)"finish etotal"
 944       return
 945       end subroutine etotal
 946 !-----------------------------------------------------------------------------
 947       subroutine sum_energy(energia,reduce)
 948 !      implicit real*8 (a-h,o-z)
 949 !      include 'DIMENSIONS'
 950 #ifndef ISNAN
 951       external proc_proc
 952 #ifdef WINPGI
 953 !MS$ATTRIBUTES C ::  proc_proc
 954 #endif
 955 #endif
 956 #ifdef MPI
 957       include "mpif.h"
 958 #endif
 959 !      include 'COMMON.SETUP'
 960 !      include 'COMMON.IOUNITS'
 961       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 962 !      include 'COMMON.FFIELD'
 963 !      include 'COMMON.DERIV'
 964 !      include 'COMMON.INTERACT'
 965 !      include 'COMMON.SBRIDGE'
 966 !      include 'COMMON.CHAIN'
 967 !      include 'COMMON.VAR'
 968 !      include 'COMMON.CONTROL'
 969 !      include 'COMMON.TIME1'
 970       logical :: reduce
 971       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 972       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 973       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 974         eliptran,etube, Eafmforce,ethetacnstr
 975       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 976                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 977                       ecorr3_nucl
 978       real(kind=8) :: ecation_prot,ecationcation
 979       real(kind=8) :: escbase,epepbase,escpho,epeppho
 980       integer :: i
 981 #ifdef MPI
 982       integer :: ierr
 983       real(kind=8) :: time00
 984       if (nfgtasks.gt.1 .and. reduce) then
 985
 986 #ifdef DEBUG
 987         write (iout,*) "energies before REDUCE"
 988         call enerprint(energia)
 989         call flush(iout)
 990 #endif
 991         do i=0,n_ene
 992           enebuff(i)=energia(i)
 993         enddo
 994         time00=MPI_Wtime()
 995         call MPI_Barrier(FG_COMM,IERR)
 996         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 997         time00=MPI_Wtime()
 998         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 999           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1000 #ifdef DEBUG
1001         write (iout,*) "energies after REDUCE"
1002         call enerprint(energia)
1003         call flush(iout)
1004 #endif
1005         time_Reduce=time_Reduce+MPI_Wtime()-time00
1006       endif
1007       if (fg_rank.eq.0) then
1008 #endif
1009       evdw=energia(1)
1010 #ifdef SCP14
1011       evdw2=energia(2)+energia(18)
1012       evdw2_14=energia(18)
1013 #else
1014       evdw2=energia(2)
1015 #endif
1016 #ifdef SPLITELE
1017       ees=energia(3)
1018       evdw1=energia(16)
1019 #else
1020       ees=energia(3)
1021       evdw1=0.0d0
1022 #endif
1023       ecorr=energia(4)
1024       ecorr5=energia(5)
1025       ecorr6=energia(6)
1026       eel_loc=energia(7)
1027       eello_turn3=energia(8)
1028       eello_turn4=energia(9)
1029       eturn6=energia(10)
1030       ebe=energia(11)
1031       escloc=energia(12)
1032       etors=energia(13)
1033       etors_d=energia(14)
1034       ehpb=energia(15)
1035       edihcnstr=energia(19)
1036       estr=energia(17)
1037       Uconst=energia(20)
1038       esccor=energia(21)
1039       eliptran=energia(22)
1040       Eafmforce=energia(23)
1041       ethetacnstr=energia(24)
1042       etube=energia(25)
1043       evdwpp=energia(26)
1044       eespp=energia(27)
1045       evdwpsb=energia(28)
1046       eelpsb=energia(29)
1047       evdwsb=energia(30)
1048       eelsb=energia(31)
1049       estr_nucl=energia(32)
1050       ebe_nucl=energia(33)
1051       esbloc=energia(34)
1052       etors_nucl=energia(35)
1053       etors_d_nucl=energia(36)
1054       ecorr_nucl=energia(37)
1055       ecorr3_nucl=energia(38)
1056       ecation_prot=energia(42)
1057       ecationcation=energia(41)
1058       escbase=energia(46)
1059       epepbase=energia(47)
1060       escpho=energia(48)
1061       epeppho=energia(49)
1062 !      energia(41)=ecation_prot
1063 !      energia(42)=ecationcation
1064
1065
1066 #ifdef SPLITELE
1067       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1068        +wang*ebe+wtor*etors+wscloc*escloc &
1069        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1070        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1071        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1072        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1073        +Eafmforce+ethetacnstr  &
1074        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1075        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1076        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1077        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1078        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1079        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1080 #else
1081       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1082        +wang*ebe+wtor*etors+wscloc*escloc &
1083        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1084        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1085        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1086        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1087        +Eafmforce+ethetacnstr &
1088        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1089        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1090        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1091        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1092        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1093        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1094 #endif
1095       energia(0)=etot
1096 ! detecting NaNQ
1097 #ifdef ISNAN
1098 #ifdef AIX
1099       if (isnan(etot).ne.0) energia(0)=1.0d+99
1100 #else
1101       if (isnan(etot)) energia(0)=1.0d+99
1102 #endif
1103 #else
1104       i=0
1105 #ifdef WINPGI
1106       idumm=proc_proc(etot,i)
1107 #else
1108       call proc_proc(etot,i)
1109 #endif
1110       if(i.eq.1)energia(0)=1.0d+99
1111 #endif
1112 #ifdef MPI
1113       endif
1114 #endif
1115 !      call enerprint(energia)
1116       call flush(iout)
1117       return
1118       end subroutine sum_energy
1119 !-----------------------------------------------------------------------------
1120       subroutine rescale_weights(t_bath)
1121 !      implicit real*8 (a-h,o-z)
1122 #ifdef MPI
1123       include 'mpif.h'
1124 #endif
1125 !      include 'DIMENSIONS'
1126 !      include 'COMMON.IOUNITS'
1127 !      include 'COMMON.FFIELD'
1128 !      include 'COMMON.SBRIDGE'
1129       real(kind=8) :: kfac=2.4d0
1130       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1131 !el local variables
1132       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1133       real(kind=8) :: T0=3.0d2
1134       integer :: ierror
1135 !      facT=temp0/t_bath
1136 !      facT=2*temp0/(t_bath+temp0)
1137       if (rescale_mode.eq.0) then
1138         facT(1)=1.0d0
1139         facT(2)=1.0d0
1140         facT(3)=1.0d0
1141         facT(4)=1.0d0
1142         facT(5)=1.0d0
1143         facT(6)=1.0d0
1144       else if (rescale_mode.eq.1) then
1145         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1146         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1147         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1148         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1149         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1150 #ifdef WHAM_RUN
1151 !#if defined(WHAM_RUN) || defined(CLUSTER)
1152 #if defined(FUNCTH)
1153 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1154         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1155 #elif defined(FUNCT)
1156         facT(6)=t_bath/T0
1157 #else
1158         facT(6)=1.0d0
1159 #endif
1160 #endif
1161       else if (rescale_mode.eq.2) then
1162         x=t_bath/temp0
1163         x2=x*x
1164         x3=x2*x
1165         x4=x3*x
1166         x5=x4*x
1167         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1168         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1169         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1170         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1171         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1172 #ifdef WHAM_RUN
1173 !#if defined(WHAM_RUN) || defined(CLUSTER)
1174 #if defined(FUNCTH)
1175         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1176 #elif defined(FUNCT)
1177         facT(6)=t_bath/T0
1178 #else
1179         facT(6)=1.0d0
1180 #endif
1181 #endif
1182       else
1183         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1184         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1185 #ifdef MPI
1186        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1187 #endif
1188        stop 555
1189       endif
1190       welec=weights(3)*fact(1)
1191       wcorr=weights(4)*fact(3)
1192       wcorr5=weights(5)*fact(4)
1193       wcorr6=weights(6)*fact(5)
1194       wel_loc=weights(7)*fact(2)
1195       wturn3=weights(8)*fact(2)
1196       wturn4=weights(9)*fact(3)
1197       wturn6=weights(10)*fact(5)
1198       wtor=weights(13)*fact(1)
1199       wtor_d=weights(14)*fact(2)
1200       wsccor=weights(21)*fact(1)
1201       welpsb=weights(28)*fact(1)
1202       wcorr_nucl= weights(37)*fact(1)
1203       wcorr3_nucl=weights(38)*fact(2)
1204       wtor_nucl=  weights(35)*fact(1)
1205       wtor_d_nucl=weights(36)*fact(2)
1206       wpepbase=weights(47)*fact(1)
1207       return
1208       end subroutine rescale_weights
1209 !-----------------------------------------------------------------------------
1210       subroutine enerprint(energia)
1211 !      implicit real*8 (a-h,o-z)
1212 !      include 'DIMENSIONS'
1213 !      include 'COMMON.IOUNITS'
1214 !      include 'COMMON.FFIELD'
1215 !      include 'COMMON.SBRIDGE'
1216 !      include 'COMMON.MD'
1217       real(kind=8) :: energia(0:n_ene)
1218 !el local variables
1219       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1220       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1221       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1222        etube,ethetacnstr,Eafmforce
1223       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1224                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1225                       ecorr3_nucl
1226       real(kind=8) :: ecation_prot,ecationcation
1227       real(kind=8) :: escbase,epepbase,escpho,epeppho
1228
1229       etot=energia(0)
1230       evdw=energia(1)
1231       evdw2=energia(2)
1232 #ifdef SCP14
1233       evdw2=energia(2)+energia(18)
1234 #else
1235       evdw2=energia(2)
1236 #endif
1237       ees=energia(3)
1238 #ifdef SPLITELE
1239       evdw1=energia(16)
1240 #endif
1241       ecorr=energia(4)
1242       ecorr5=energia(5)
1243       ecorr6=energia(6)
1244       eel_loc=energia(7)
1245       eello_turn3=energia(8)
1246       eello_turn4=energia(9)
1247       eello_turn6=energia(10)
1248       ebe=energia(11)
1249       escloc=energia(12)
1250       etors=energia(13)
1251       etors_d=energia(14)
1252       ehpb=energia(15)
1253       edihcnstr=energia(19)
1254       estr=energia(17)
1255       Uconst=energia(20)
1256       esccor=energia(21)
1257       eliptran=energia(22)
1258       Eafmforce=energia(23)
1259       ethetacnstr=energia(24)
1260       etube=energia(25)
1261       evdwpp=energia(26)
1262       eespp=energia(27)
1263       evdwpsb=energia(28)
1264       eelpsb=energia(29)
1265       evdwsb=energia(30)
1266       eelsb=energia(31)
1267       estr_nucl=energia(32)
1268       ebe_nucl=energia(33)
1269       esbloc=energia(34)
1270       etors_nucl=energia(35)
1271       etors_d_nucl=energia(36)
1272       ecorr_nucl=energia(37)
1273       ecorr3_nucl=energia(38)
1274       ecation_prot=energia(42)
1275       ecationcation=energia(41)
1276       escbase=energia(46)
1277       epepbase=energia(47)
1278       escpho=energia(48)
1279       epeppho=energia(49)
1280 #ifdef SPLITELE
1281       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1282         estr,wbond,ebe,wang,&
1283         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1284         ecorr,wcorr,&
1285         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1286         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1287         edihcnstr,ethetacnstr,ebr*nss,&
1288         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1289         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1290         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1291         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1292         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1293         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1294         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1295         etot
1296    10 format (/'Virtual-chain energies:'// &
1297        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1298        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1299        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1300        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1301        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1302        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1303        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1304        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1305        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1306        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1307        ' (SS bridges & dist. cnstr.)'/ &
1308        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1309        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1310        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1311        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1312        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1313        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1314        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1315        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1316        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1317        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1318        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1319        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1320        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1321        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1322        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1323        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1324        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1325        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1326        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1327        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1328        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1329        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1330        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1331        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1332        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1333        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1334        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1335        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1336        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1337        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1338        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1339        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1340        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1341        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1342        'ETOT=  ',1pE16.6,' (total)')
1343 #else
1344       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1345         estr,wbond,ebe,wang,&
1346         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1347         ecorr,wcorr,&
1348         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1349         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1350         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1351         etube,wtube, &
1352         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1353         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1354         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1355         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1356         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1357         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1358         etot
1359    10 format (/'Virtual-chain energies:'// &
1360        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1361        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1362        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1363        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1364        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1365        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1366        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1367        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1368        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1369        ' (SS bridges & dist. cnstr.)'/ &
1370        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1371        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1372        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1373        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1374        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1375        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1376        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1377        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1378        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1379        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1380        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1381        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1382        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1383        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1384        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1385        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1386        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1387        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1388        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1389        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1390        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1391        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1392        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1393        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1394        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1395        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1396        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1397        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1398        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1399        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1400        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1401        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1402        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1403        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1404        'ETOT=  ',1pE16.6,' (total)')
1405 #endif
1406       return
1407       end subroutine enerprint
1408 !-----------------------------------------------------------------------------
1409       subroutine elj(evdw)
1410 !
1411 ! This subroutine calculates the interaction energy of nonbonded side chains
1412 ! assuming the LJ potential of interaction.
1413 !
1414 !      implicit real*8 (a-h,o-z)
1415 !      include 'DIMENSIONS'
1416       real(kind=8),parameter :: accur=1.0d-10
1417 !      include 'COMMON.GEO'
1418 !      include 'COMMON.VAR'
1419 !      include 'COMMON.LOCAL'
1420 !      include 'COMMON.CHAIN'
1421 !      include 'COMMON.DERIV'
1422 !      include 'COMMON.INTERACT'
1423 !      include 'COMMON.TORSION'
1424 !      include 'COMMON.SBRIDGE'
1425 !      include 'COMMON.NAMES'
1426 !      include 'COMMON.IOUNITS'
1427 !      include 'COMMON.CONTACTS'
1428       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1429       integer :: num_conti
1430 !el local variables
1431       integer :: i,itypi,iint,j,itypi1,itypj,k
1432       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1433       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1434       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1435
1436 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1437       evdw=0.0D0
1438 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1439 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1440 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1441 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1442
1443       do i=iatsc_s,iatsc_e
1444         itypi=iabs(itype(i,1))
1445         if (itypi.eq.ntyp1) cycle
1446         itypi1=iabs(itype(i+1,1))
1447         xi=c(1,nres+i)
1448         yi=c(2,nres+i)
1449         zi=c(3,nres+i)
1450 ! Change 12/1/95
1451         num_conti=0
1452 !
1453 ! Calculate SC interaction energy.
1454 !
1455         do iint=1,nint_gr(i)
1456 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1457 !d   &                  'iend=',iend(i,iint)
1458           do j=istart(i,iint),iend(i,iint)
1459             itypj=iabs(itype(j,1))
1460             if (itypj.eq.ntyp1) cycle
1461             xj=c(1,nres+j)-xi
1462             yj=c(2,nres+j)-yi
1463             zj=c(3,nres+j)-zi
1464 ! Change 12/1/95 to calculate four-body interactions
1465             rij=xj*xj+yj*yj+zj*zj
1466             rrij=1.0D0/rij
1467 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1468             eps0ij=eps(itypi,itypj)
1469             fac=rrij**expon2
1470             e1=fac*fac*aa_aq(itypi,itypj)
1471             e2=fac*bb_aq(itypi,itypj)
1472             evdwij=e1+e2
1473 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1474 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1475 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1476 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1477 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1478 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1479             evdw=evdw+evdwij
1480 !
1481 ! Calculate the components of the gradient in DC and X
1482 !
1483             fac=-rrij*(e1+evdwij)
1484             gg(1)=xj*fac
1485             gg(2)=yj*fac
1486             gg(3)=zj*fac
1487             do k=1,3
1488               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1489               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1490               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1491               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1492             enddo
1493 !grad            do k=i,j-1
1494 !grad              do l=1,3
1495 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1496 !grad              enddo
1497 !grad            enddo
1498 !
1499 ! 12/1/95, revised on 5/20/97
1500 !
1501 ! Calculate the contact function. The ith column of the array JCONT will
1502 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1503 ! greater than I). The arrays FACONT and GACONT will contain the values of
1504 ! the contact function and its derivative.
1505 !
1506 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1507 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1508 ! Uncomment next line, if the correlation interactions are contact function only
1509             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1510               rij=dsqrt(rij)
1511               sigij=sigma(itypi,itypj)
1512               r0ij=rs0(itypi,itypj)
1513 !
1514 ! Check whether the SC's are not too far to make a contact.
1515 !
1516               rcut=1.5d0*r0ij
1517               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1518 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1519 !
1520               if (fcont.gt.0.0D0) then
1521 ! If the SC-SC distance if close to sigma, apply spline.
1522 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1523 !Adam &             fcont1,fprimcont1)
1524 !Adam           fcont1=1.0d0-fcont1
1525 !Adam           if (fcont1.gt.0.0d0) then
1526 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1527 !Adam             fcont=fcont*fcont1
1528 !Adam           endif
1529 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1530 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1531 !ga             do k=1,3
1532 !ga               gg(k)=gg(k)*eps0ij
1533 !ga             enddo
1534 !ga             eps0ij=-evdwij*eps0ij
1535 ! Uncomment for AL's type of SC correlation interactions.
1536 !adam           eps0ij=-evdwij
1537                 num_conti=num_conti+1
1538                 jcont(num_conti,i)=j
1539                 facont(num_conti,i)=fcont*eps0ij
1540                 fprimcont=eps0ij*fprimcont/rij
1541                 fcont=expon*fcont
1542 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1543 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1544 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1545 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1546                 gacont(1,num_conti,i)=-fprimcont*xj
1547                 gacont(2,num_conti,i)=-fprimcont*yj
1548                 gacont(3,num_conti,i)=-fprimcont*zj
1549 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1550 !d              write (iout,'(2i3,3f10.5)')
1551 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1552               endif
1553             endif
1554           enddo      ! j
1555         enddo        ! iint
1556 ! Change 12/1/95
1557         num_cont(i)=num_conti
1558       enddo          ! i
1559       do i=1,nct
1560         do j=1,3
1561           gvdwc(j,i)=expon*gvdwc(j,i)
1562           gvdwx(j,i)=expon*gvdwx(j,i)
1563         enddo
1564       enddo
1565 !******************************************************************************
1566 !
1567 !                              N O T E !!!
1568 !
1569 ! To save time, the factor of EXPON has been extracted from ALL components
1570 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1571 ! use!
1572 !
1573 !******************************************************************************
1574       return
1575       end subroutine elj
1576 !-----------------------------------------------------------------------------
1577       subroutine eljk(evdw)
1578 !
1579 ! This subroutine calculates the interaction energy of nonbonded side chains
1580 ! assuming the LJK potential of interaction.
1581 !
1582 !      implicit real*8 (a-h,o-z)
1583 !      include 'DIMENSIONS'
1584 !      include 'COMMON.GEO'
1585 !      include 'COMMON.VAR'
1586 !      include 'COMMON.LOCAL'
1587 !      include 'COMMON.CHAIN'
1588 !      include 'COMMON.DERIV'
1589 !      include 'COMMON.INTERACT'
1590 !      include 'COMMON.IOUNITS'
1591 !      include 'COMMON.NAMES'
1592       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1593       logical :: scheck
1594 !el local variables
1595       integer :: i,iint,j,itypi,itypi1,k,itypj
1596       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1597       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1598
1599 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1600       evdw=0.0D0
1601       do i=iatsc_s,iatsc_e
1602         itypi=iabs(itype(i,1))
1603         if (itypi.eq.ntyp1) cycle
1604         itypi1=iabs(itype(i+1,1))
1605         xi=c(1,nres+i)
1606         yi=c(2,nres+i)
1607         zi=c(3,nres+i)
1608 !
1609 ! Calculate SC interaction energy.
1610 !
1611         do iint=1,nint_gr(i)
1612           do j=istart(i,iint),iend(i,iint)
1613             itypj=iabs(itype(j,1))
1614             if (itypj.eq.ntyp1) cycle
1615             xj=c(1,nres+j)-xi
1616             yj=c(2,nres+j)-yi
1617             zj=c(3,nres+j)-zi
1618             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1619             fac_augm=rrij**expon
1620             e_augm=augm(itypi,itypj)*fac_augm
1621             r_inv_ij=dsqrt(rrij)
1622             rij=1.0D0/r_inv_ij
1623             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1624             fac=r_shift_inv**expon
1625             e1=fac*fac*aa_aq(itypi,itypj)
1626             e2=fac*bb_aq(itypi,itypj)
1627             evdwij=e_augm+e1+e2
1628 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1629 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1630 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1631 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1632 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1633 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1634 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1635             evdw=evdw+evdwij
1636 !
1637 ! Calculate the components of the gradient in DC and X
1638 !
1639             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1640             gg(1)=xj*fac
1641             gg(2)=yj*fac
1642             gg(3)=zj*fac
1643             do k=1,3
1644               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1645               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1646               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1647               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1648             enddo
1649 !grad            do k=i,j-1
1650 !grad              do l=1,3
1651 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1652 !grad              enddo
1653 !grad            enddo
1654           enddo      ! j
1655         enddo        ! iint
1656       enddo          ! i
1657       do i=1,nct
1658         do j=1,3
1659           gvdwc(j,i)=expon*gvdwc(j,i)
1660           gvdwx(j,i)=expon*gvdwx(j,i)
1661         enddo
1662       enddo
1663       return
1664       end subroutine eljk
1665 !-----------------------------------------------------------------------------
1666       subroutine ebp(evdw)
1667 !
1668 ! This subroutine calculates the interaction energy of nonbonded side chains
1669 ! assuming the Berne-Pechukas potential of interaction.
1670 !
1671       use comm_srutu
1672       use calc_data
1673 !      implicit real*8 (a-h,o-z)
1674 !      include 'DIMENSIONS'
1675 !      include 'COMMON.GEO'
1676 !      include 'COMMON.VAR'
1677 !      include 'COMMON.LOCAL'
1678 !      include 'COMMON.CHAIN'
1679 !      include 'COMMON.DERIV'
1680 !      include 'COMMON.NAMES'
1681 !      include 'COMMON.INTERACT'
1682 !      include 'COMMON.IOUNITS'
1683 !      include 'COMMON.CALC'
1684       use comm_srutu
1685 !el      integer :: icall
1686 !el      common /srutu/ icall
1687 !     double precision rrsave(maxdim)
1688       logical :: lprn
1689 !el local variables
1690       integer :: iint,itypi,itypi1,itypj
1691       real(kind=8) :: rrij,xi,yi,zi
1692       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1693
1694 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1695       evdw=0.0D0
1696 !     if (icall.eq.0) then
1697 !       lprn=.true.
1698 !     else
1699         lprn=.false.
1700 !     endif
1701 !el      ind=0
1702       do i=iatsc_s,iatsc_e
1703         itypi=iabs(itype(i,1))
1704         if (itypi.eq.ntyp1) cycle
1705         itypi1=iabs(itype(i+1,1))
1706         xi=c(1,nres+i)
1707         yi=c(2,nres+i)
1708         zi=c(3,nres+i)
1709         dxi=dc_norm(1,nres+i)
1710         dyi=dc_norm(2,nres+i)
1711         dzi=dc_norm(3,nres+i)
1712 !        dsci_inv=dsc_inv(itypi)
1713         dsci_inv=vbld_inv(i+nres)
1714 !
1715 ! Calculate SC interaction energy.
1716 !
1717         do iint=1,nint_gr(i)
1718           do j=istart(i,iint),iend(i,iint)
1719 !el            ind=ind+1
1720             itypj=iabs(itype(j,1))
1721             if (itypj.eq.ntyp1) cycle
1722 !            dscj_inv=dsc_inv(itypj)
1723             dscj_inv=vbld_inv(j+nres)
1724             chi1=chi(itypi,itypj)
1725             chi2=chi(itypj,itypi)
1726             chi12=chi1*chi2
1727             chip1=chip(itypi)
1728             chip2=chip(itypj)
1729             chip12=chip1*chip2
1730             alf1=alp(itypi)
1731             alf2=alp(itypj)
1732             alf12=0.5D0*(alf1+alf2)
1733 ! For diagnostics only!!!
1734 !           chi1=0.0D0
1735 !           chi2=0.0D0
1736 !           chi12=0.0D0
1737 !           chip1=0.0D0
1738 !           chip2=0.0D0
1739 !           chip12=0.0D0
1740 !           alf1=0.0D0
1741 !           alf2=0.0D0
1742 !           alf12=0.0D0
1743             xj=c(1,nres+j)-xi
1744             yj=c(2,nres+j)-yi
1745             zj=c(3,nres+j)-zi
1746             dxj=dc_norm(1,nres+j)
1747             dyj=dc_norm(2,nres+j)
1748             dzj=dc_norm(3,nres+j)
1749             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1750 !d          if (icall.eq.0) then
1751 !d            rrsave(ind)=rrij
1752 !d          else
1753 !d            rrij=rrsave(ind)
1754 !d          endif
1755             rij=dsqrt(rrij)
1756 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1757             call sc_angular
1758 ! Calculate whole angle-dependent part of epsilon and contributions
1759 ! to its derivatives
1760             fac=(rrij*sigsq)**expon2
1761             e1=fac*fac*aa_aq(itypi,itypj)
1762             e2=fac*bb_aq(itypi,itypj)
1763             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1764             eps2der=evdwij*eps3rt
1765             eps3der=evdwij*eps2rt
1766             evdwij=evdwij*eps2rt*eps3rt
1767             evdw=evdw+evdwij
1768             if (lprn) then
1769             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1770             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1771 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1772 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1773 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1774 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1775 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1776 !d     &        evdwij
1777             endif
1778 ! Calculate gradient components.
1779             e1=e1*eps1*eps2rt**2*eps3rt**2
1780             fac=-expon*(e1+evdwij)
1781             sigder=fac/sigsq
1782             fac=rrij*fac
1783 ! Calculate radial part of the gradient
1784             gg(1)=xj*fac
1785             gg(2)=yj*fac
1786             gg(3)=zj*fac
1787 ! Calculate the angular part of the gradient and sum add the contributions
1788 ! to the appropriate components of the Cartesian gradient.
1789             call sc_grad
1790           enddo      ! j
1791         enddo        ! iint
1792       enddo          ! i
1793 !     stop
1794       return
1795       end subroutine ebp
1796 !-----------------------------------------------------------------------------
1797       subroutine egb(evdw)
1798 !
1799 ! This subroutine calculates the interaction energy of nonbonded side chains
1800 ! assuming the Gay-Berne potential of interaction.
1801 !
1802       use calc_data
1803 !      implicit real*8 (a-h,o-z)
1804 !      include 'DIMENSIONS'
1805 !      include 'COMMON.GEO'
1806 !      include 'COMMON.VAR'
1807 !      include 'COMMON.LOCAL'
1808 !      include 'COMMON.CHAIN'
1809 !      include 'COMMON.DERIV'
1810 !      include 'COMMON.NAMES'
1811 !      include 'COMMON.INTERACT'
1812 !      include 'COMMON.IOUNITS'
1813 !      include 'COMMON.CALC'
1814 !      include 'COMMON.CONTROL'
1815 !      include 'COMMON.SBRIDGE'
1816       logical :: lprn
1817 !el local variables
1818       integer :: iint,itypi,itypi1,itypj,subchap
1819       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1820       real(kind=8) :: evdw,sig0ij
1821       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1822                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1823                     sslipi,sslipj,faclip
1824       integer :: ii
1825       real(kind=8) :: fracinbuf
1826
1827 !cccc      energy_dec=.false.
1828 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1829       evdw=0.0D0
1830       lprn=.false.
1831 !     if (icall.eq.0) lprn=.false.
1832 !el      ind=0
1833       dCAVdOM2=0.0d0
1834       dGCLdOM2=0.0d0
1835       dPOLdOM2=0.0d0
1836       dCAVdOM1=0.0d0
1837       dGCLdOM1=0.0d0
1838       dPOLdOM1=0.0d0
1839
1840
1841       do i=iatsc_s,iatsc_e
1842 !C        print *,"I am in EVDW",i
1843         itypi=iabs(itype(i,1))
1844 !        if (i.ne.47) cycle
1845         if (itypi.eq.ntyp1) cycle
1846         itypi1=iabs(itype(i+1,1))
1847         xi=c(1,nres+i)
1848         yi=c(2,nres+i)
1849         zi=c(3,nres+i)
1850           xi=dmod(xi,boxxsize)
1851           if (xi.lt.0) xi=xi+boxxsize
1852           yi=dmod(yi,boxysize)
1853           if (yi.lt.0) yi=yi+boxysize
1854           zi=dmod(zi,boxzsize)
1855           if (zi.lt.0) zi=zi+boxzsize
1856
1857        if ((zi.gt.bordlipbot)  &
1858         .and.(zi.lt.bordliptop)) then
1859 !C the energy transfer exist
1860         if (zi.lt.buflipbot) then
1861 !C what fraction I am in
1862          fracinbuf=1.0d0-  &
1863               ((zi-bordlipbot)/lipbufthick)
1864 !C lipbufthick is thickenes of lipid buffore
1865          sslipi=sscalelip(fracinbuf)
1866          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1867         elseif (zi.gt.bufliptop) then
1868          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1869          sslipi=sscalelip(fracinbuf)
1870          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1871         else
1872          sslipi=1.0d0
1873          ssgradlipi=0.0
1874         endif
1875        else
1876          sslipi=0.0d0
1877          ssgradlipi=0.0
1878        endif
1879 !       print *, sslipi,ssgradlipi
1880         dxi=dc_norm(1,nres+i)
1881         dyi=dc_norm(2,nres+i)
1882         dzi=dc_norm(3,nres+i)
1883 !        dsci_inv=dsc_inv(itypi)
1884         dsci_inv=vbld_inv(i+nres)
1885 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1886 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1887 !
1888 ! Calculate SC interaction energy.
1889 !
1890         do iint=1,nint_gr(i)
1891           do j=istart(i,iint),iend(i,iint)
1892             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1893               call dyn_ssbond_ene(i,j,evdwij)
1894               evdw=evdw+evdwij
1895               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1896                               'evdw',i,j,evdwij,' ss'
1897 !              if (energy_dec) write (iout,*) &
1898 !                              'evdw',i,j,evdwij,' ss'
1899              do k=j+1,iend(i,iint)
1900 !C search over all next residues
1901               if (dyn_ss_mask(k)) then
1902 !C check if they are cysteins
1903 !C              write(iout,*) 'k=',k
1904
1905 !c              write(iout,*) "PRZED TRI", evdwij
1906 !               evdwij_przed_tri=evdwij
1907               call triple_ssbond_ene(i,j,k,evdwij)
1908 !c               if(evdwij_przed_tri.ne.evdwij) then
1909 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1910 !c               endif
1911
1912 !c              write(iout,*) "PO TRI", evdwij
1913 !C call the energy function that removes the artifical triple disulfide
1914 !C bond the soubroutine is located in ssMD.F
1915               evdw=evdw+evdwij
1916               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1917                             'evdw',i,j,evdwij,'tss'
1918               endif!dyn_ss_mask(k)
1919              enddo! k
1920             ELSE
1921 !el            ind=ind+1
1922             itypj=iabs(itype(j,1))
1923             if (itypj.eq.ntyp1) cycle
1924 !             if (j.ne.78) cycle
1925 !            dscj_inv=dsc_inv(itypj)
1926             dscj_inv=vbld_inv(j+nres)
1927 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1928 !              1.0d0/vbld(j+nres) !d
1929 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1930             sig0ij=sigma(itypi,itypj)
1931             chi1=chi(itypi,itypj)
1932             chi2=chi(itypj,itypi)
1933             chi12=chi1*chi2
1934             chip1=chip(itypi)
1935             chip2=chip(itypj)
1936             chip12=chip1*chip2
1937             alf1=alp(itypi)
1938             alf2=alp(itypj)
1939             alf12=0.5D0*(alf1+alf2)
1940 ! For diagnostics only!!!
1941 !           chi1=0.0D0
1942 !           chi2=0.0D0
1943 !           chi12=0.0D0
1944 !           chip1=0.0D0
1945 !           chip2=0.0D0
1946 !           chip12=0.0D0
1947 !           alf1=0.0D0
1948 !           alf2=0.0D0
1949 !           alf12=0.0D0
1950            xj=c(1,nres+j)
1951            yj=c(2,nres+j)
1952            zj=c(3,nres+j)
1953           xj=dmod(xj,boxxsize)
1954           if (xj.lt.0) xj=xj+boxxsize
1955           yj=dmod(yj,boxysize)
1956           if (yj.lt.0) yj=yj+boxysize
1957           zj=dmod(zj,boxzsize)
1958           if (zj.lt.0) zj=zj+boxzsize
1959 !          print *,"tu",xi,yi,zi,xj,yj,zj
1960 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1961 ! this fragment set correct epsilon for lipid phase
1962        if ((zj.gt.bordlipbot)  &
1963        .and.(zj.lt.bordliptop)) then
1964 !C the energy transfer exist
1965         if (zj.lt.buflipbot) then
1966 !C what fraction I am in
1967          fracinbuf=1.0d0-     &
1968              ((zj-bordlipbot)/lipbufthick)
1969 !C lipbufthick is thickenes of lipid buffore
1970          sslipj=sscalelip(fracinbuf)
1971          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1972         elseif (zj.gt.bufliptop) then
1973          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1974          sslipj=sscalelip(fracinbuf)
1975          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1976         else
1977          sslipj=1.0d0
1978          ssgradlipj=0.0
1979         endif
1980        else
1981          sslipj=0.0d0
1982          ssgradlipj=0.0
1983        endif
1984       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1985        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1986       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1987        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1988 !------------------------------------------------
1989       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1990       xj_safe=xj
1991       yj_safe=yj
1992       zj_safe=zj
1993       subchap=0
1994       do xshift=-1,1
1995       do yshift=-1,1
1996       do zshift=-1,1
1997           xj=xj_safe+xshift*boxxsize
1998           yj=yj_safe+yshift*boxysize
1999           zj=zj_safe+zshift*boxzsize
2000           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2001           if(dist_temp.lt.dist_init) then
2002             dist_init=dist_temp
2003             xj_temp=xj
2004             yj_temp=yj
2005             zj_temp=zj
2006             subchap=1
2007           endif
2008        enddo
2009        enddo
2010        enddo
2011        if (subchap.eq.1) then
2012           xj=xj_temp-xi
2013           yj=yj_temp-yi
2014           zj=zj_temp-zi
2015        else
2016           xj=xj_safe-xi
2017           yj=yj_safe-yi
2018           zj=zj_safe-zi
2019        endif
2020             dxj=dc_norm(1,nres+j)
2021             dyj=dc_norm(2,nres+j)
2022             dzj=dc_norm(3,nres+j)
2023 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2024 !            write (iout,*) "j",j," dc_norm",& !d
2025 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2026 !          write(iout,*)"rrij ",rrij
2027 !          write(iout,*)"xj yj zj ", xj, yj, zj
2028 !          write(iout,*)"xi yi zi ", xi, yi, zi
2029 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2030             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2031             rij=dsqrt(rrij)
2032             sss_ele_cut=sscale_ele(1.0d0/(rij))
2033             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2034 !            print *,sss_ele_cut,sss_ele_grad,&
2035 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2036             if (sss_ele_cut.le.0.0) cycle
2037 ! Calculate angle-dependent terms of energy and contributions to their
2038 ! derivatives.
2039             call sc_angular
2040             sigsq=1.0D0/sigsq
2041             sig=sig0ij*dsqrt(sigsq)
2042             rij_shift=1.0D0/rij-sig+sig0ij
2043 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2044 !            "sig0ij",sig0ij
2045 ! for diagnostics; uncomment
2046 !            rij_shift=1.2*sig0ij
2047 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2048             if (rij_shift.le.0.0D0) then
2049               evdw=1.0D20
2050 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2051 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2052 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2053               return
2054             endif
2055             sigder=-sig*sigsq
2056 !---------------------------------------------------------------
2057             rij_shift=1.0D0/rij_shift
2058             fac=rij_shift**expon
2059             faclip=fac
2060             e1=fac*fac*aa!(itypi,itypj)
2061             e2=fac*bb!(itypi,itypj)
2062             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2063             eps2der=evdwij*eps3rt
2064             eps3der=evdwij*eps2rt
2065 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2066 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2067 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2068             evdwij=evdwij*eps2rt*eps3rt
2069             evdw=evdw+evdwij*sss_ele_cut
2070             if (lprn) then
2071             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2072             epsi=bb**2/aa!(itypi,itypj)
2073             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2074               restyp(itypi,1),i,restyp(itypj,1),j, &
2075               epsi,sigm,chi1,chi2,chip1,chip2, &
2076               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2077               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2078               evdwij
2079             endif
2080
2081             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2082                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2083 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2084 !            if (energy_dec) write (iout,*) &
2085 !                             'evdw',i,j,evdwij
2086 !                       print *,"ZALAMKA", evdw
2087
2088 ! Calculate gradient components.
2089             e1=e1*eps1*eps2rt**2*eps3rt**2
2090             fac=-expon*(e1+evdwij)*rij_shift
2091             sigder=fac*sigder
2092             fac=rij*fac
2093 !            print *,'before fac',fac,rij,evdwij
2094             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2095             *rij
2096 !            print *,'grad part scale',fac,   &
2097 !             evdwij*sss_ele_grad/sss_ele_cut &
2098 !            /sigma(itypi,itypj)*rij
2099 !            fac=0.0d0
2100 ! Calculate the radial part of the gradient
2101             gg(1)=xj*fac
2102             gg(2)=yj*fac
2103             gg(3)=zj*fac
2104 !C Calculate the radial part of the gradient
2105             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2106        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2107         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2108        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2109             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2110             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2111
2112 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2113 ! Calculate angular part of the gradient.
2114             call sc_grad
2115             ENDIF    ! dyn_ss
2116           enddo      ! j
2117         enddo        ! iint
2118       enddo          ! i
2119 !       print *,"ZALAMKA", evdw
2120 !      write (iout,*) "Number of loop steps in EGB:",ind
2121 !ccc      energy_dec=.false.
2122       return
2123       end subroutine egb
2124 !-----------------------------------------------------------------------------
2125       subroutine egbv(evdw)
2126 !
2127 ! This subroutine calculates the interaction energy of nonbonded side chains
2128 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2129 !
2130       use comm_srutu
2131       use calc_data
2132 !      implicit real*8 (a-h,o-z)
2133 !      include 'DIMENSIONS'
2134 !      include 'COMMON.GEO'
2135 !      include 'COMMON.VAR'
2136 !      include 'COMMON.LOCAL'
2137 !      include 'COMMON.CHAIN'
2138 !      include 'COMMON.DERIV'
2139 !      include 'COMMON.NAMES'
2140 !      include 'COMMON.INTERACT'
2141 !      include 'COMMON.IOUNITS'
2142 !      include 'COMMON.CALC'
2143       use comm_srutu
2144 !el      integer :: icall
2145 !el      common /srutu/ icall
2146       logical :: lprn
2147 !el local variables
2148       integer :: iint,itypi,itypi1,itypj
2149       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2150       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2151
2152 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2153       evdw=0.0D0
2154       lprn=.false.
2155 !     if (icall.eq.0) lprn=.true.
2156 !el      ind=0
2157       do i=iatsc_s,iatsc_e
2158         itypi=iabs(itype(i,1))
2159         if (itypi.eq.ntyp1) cycle
2160         itypi1=iabs(itype(i+1,1))
2161         xi=c(1,nres+i)
2162         yi=c(2,nres+i)
2163         zi=c(3,nres+i)
2164         dxi=dc_norm(1,nres+i)
2165         dyi=dc_norm(2,nres+i)
2166         dzi=dc_norm(3,nres+i)
2167 !        dsci_inv=dsc_inv(itypi)
2168         dsci_inv=vbld_inv(i+nres)
2169 !
2170 ! Calculate SC interaction energy.
2171 !
2172         do iint=1,nint_gr(i)
2173           do j=istart(i,iint),iend(i,iint)
2174 !el            ind=ind+1
2175             itypj=iabs(itype(j,1))
2176             if (itypj.eq.ntyp1) cycle
2177 !            dscj_inv=dsc_inv(itypj)
2178             dscj_inv=vbld_inv(j+nres)
2179             sig0ij=sigma(itypi,itypj)
2180             r0ij=r0(itypi,itypj)
2181             chi1=chi(itypi,itypj)
2182             chi2=chi(itypj,itypi)
2183             chi12=chi1*chi2
2184             chip1=chip(itypi)
2185             chip2=chip(itypj)
2186             chip12=chip1*chip2
2187             alf1=alp(itypi)
2188             alf2=alp(itypj)
2189             alf12=0.5D0*(alf1+alf2)
2190 ! For diagnostics only!!!
2191 !           chi1=0.0D0
2192 !           chi2=0.0D0
2193 !           chi12=0.0D0
2194 !           chip1=0.0D0
2195 !           chip2=0.0D0
2196 !           chip12=0.0D0
2197 !           alf1=0.0D0
2198 !           alf2=0.0D0
2199 !           alf12=0.0D0
2200             xj=c(1,nres+j)-xi
2201             yj=c(2,nres+j)-yi
2202             zj=c(3,nres+j)-zi
2203             dxj=dc_norm(1,nres+j)
2204             dyj=dc_norm(2,nres+j)
2205             dzj=dc_norm(3,nres+j)
2206             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2207             rij=dsqrt(rrij)
2208 ! Calculate angle-dependent terms of energy and contributions to their
2209 ! derivatives.
2210             call sc_angular
2211             sigsq=1.0D0/sigsq
2212             sig=sig0ij*dsqrt(sigsq)
2213             rij_shift=1.0D0/rij-sig+r0ij
2214 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2215             if (rij_shift.le.0.0D0) then
2216               evdw=1.0D20
2217               return
2218             endif
2219             sigder=-sig*sigsq
2220 !---------------------------------------------------------------
2221             rij_shift=1.0D0/rij_shift
2222             fac=rij_shift**expon
2223             e1=fac*fac*aa_aq(itypi,itypj)
2224             e2=fac*bb_aq(itypi,itypj)
2225             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2226             eps2der=evdwij*eps3rt
2227             eps3der=evdwij*eps2rt
2228             fac_augm=rrij**expon
2229             e_augm=augm(itypi,itypj)*fac_augm
2230             evdwij=evdwij*eps2rt*eps3rt
2231             evdw=evdw+evdwij+e_augm
2232             if (lprn) then
2233             sigm=dabs(aa_aq(itypi,itypj)/&
2234             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2235             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2236             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2237               restyp(itypi,1),i,restyp(itypj,1),j,&
2238               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2239               chi1,chi2,chip1,chip2,&
2240               eps1,eps2rt**2,eps3rt**2,&
2241               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2242               evdwij+e_augm
2243             endif
2244 ! Calculate gradient components.
2245             e1=e1*eps1*eps2rt**2*eps3rt**2
2246             fac=-expon*(e1+evdwij)*rij_shift
2247             sigder=fac*sigder
2248             fac=rij*fac-2*expon*rrij*e_augm
2249 ! Calculate the radial part of the gradient
2250             gg(1)=xj*fac
2251             gg(2)=yj*fac
2252             gg(3)=zj*fac
2253 ! Calculate angular part of the gradient.
2254             call sc_grad
2255           enddo      ! j
2256         enddo        ! iint
2257       enddo          ! i
2258       end subroutine egbv
2259 !-----------------------------------------------------------------------------
2260 !el      subroutine sc_angular in module geometry
2261 !-----------------------------------------------------------------------------
2262       subroutine e_softsphere(evdw)
2263 !
2264 ! This subroutine calculates the interaction energy of nonbonded side chains
2265 ! assuming the LJ potential of interaction.
2266 !
2267 !      implicit real*8 (a-h,o-z)
2268 !      include 'DIMENSIONS'
2269       real(kind=8),parameter :: accur=1.0d-10
2270 !      include 'COMMON.GEO'
2271 !      include 'COMMON.VAR'
2272 !      include 'COMMON.LOCAL'
2273 !      include 'COMMON.CHAIN'
2274 !      include 'COMMON.DERIV'
2275 !      include 'COMMON.INTERACT'
2276 !      include 'COMMON.TORSION'
2277 !      include 'COMMON.SBRIDGE'
2278 !      include 'COMMON.NAMES'
2279 !      include 'COMMON.IOUNITS'
2280 !      include 'COMMON.CONTACTS'
2281       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2282 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2283 !el local variables
2284       integer :: i,iint,j,itypi,itypi1,itypj,k
2285       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2286       real(kind=8) :: fac
2287
2288       evdw=0.0D0
2289       do i=iatsc_s,iatsc_e
2290         itypi=iabs(itype(i,1))
2291         if (itypi.eq.ntyp1) cycle
2292         itypi1=iabs(itype(i+1,1))
2293         xi=c(1,nres+i)
2294         yi=c(2,nres+i)
2295         zi=c(3,nres+i)
2296 !
2297 ! Calculate SC interaction energy.
2298 !
2299         do iint=1,nint_gr(i)
2300 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2301 !d   &                  'iend=',iend(i,iint)
2302           do j=istart(i,iint),iend(i,iint)
2303             itypj=iabs(itype(j,1))
2304             if (itypj.eq.ntyp1) cycle
2305             xj=c(1,nres+j)-xi
2306             yj=c(2,nres+j)-yi
2307             zj=c(3,nres+j)-zi
2308             rij=xj*xj+yj*yj+zj*zj
2309 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2310             r0ij=r0(itypi,itypj)
2311             r0ijsq=r0ij*r0ij
2312 !            print *,i,j,r0ij,dsqrt(rij)
2313             if (rij.lt.r0ijsq) then
2314               evdwij=0.25d0*(rij-r0ijsq)**2
2315               fac=rij-r0ijsq
2316             else
2317               evdwij=0.0d0
2318               fac=0.0d0
2319             endif
2320             evdw=evdw+evdwij
2321 !
2322 ! Calculate the components of the gradient in DC and X
2323 !
2324             gg(1)=xj*fac
2325             gg(2)=yj*fac
2326             gg(3)=zj*fac
2327             do k=1,3
2328               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2329               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2330               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2331               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2332             enddo
2333 !grad            do k=i,j-1
2334 !grad              do l=1,3
2335 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2336 !grad              enddo
2337 !grad            enddo
2338           enddo ! j
2339         enddo ! iint
2340       enddo ! i
2341       return
2342       end subroutine e_softsphere
2343 !-----------------------------------------------------------------------------
2344       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2345 !
2346 ! Soft-sphere potential of p-p interaction
2347 !
2348 !      implicit real*8 (a-h,o-z)
2349 !      include 'DIMENSIONS'
2350 !      include 'COMMON.CONTROL'
2351 !      include 'COMMON.IOUNITS'
2352 !      include 'COMMON.GEO'
2353 !      include 'COMMON.VAR'
2354 !      include 'COMMON.LOCAL'
2355 !      include 'COMMON.CHAIN'
2356 !      include 'COMMON.DERIV'
2357 !      include 'COMMON.INTERACT'
2358 !      include 'COMMON.CONTACTS'
2359 !      include 'COMMON.TORSION'
2360 !      include 'COMMON.VECTORS'
2361 !      include 'COMMON.FFIELD'
2362       real(kind=8),dimension(3) :: ggg
2363 !d      write(iout,*) 'In EELEC_soft_sphere'
2364 !el local variables
2365       integer :: i,j,k,num_conti,iteli,itelj
2366       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2367       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2368       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2369
2370       ees=0.0D0
2371       evdw1=0.0D0
2372       eel_loc=0.0d0
2373       eello_turn3=0.0d0
2374       eello_turn4=0.0d0
2375 !el      ind=0
2376       do i=iatel_s,iatel_e
2377         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2378         dxi=dc(1,i)
2379         dyi=dc(2,i)
2380         dzi=dc(3,i)
2381         xmedi=c(1,i)+0.5d0*dxi
2382         ymedi=c(2,i)+0.5d0*dyi
2383         zmedi=c(3,i)+0.5d0*dzi
2384         num_conti=0
2385 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2386         do j=ielstart(i),ielend(i)
2387           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2388 !el          ind=ind+1
2389           iteli=itel(i)
2390           itelj=itel(j)
2391           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2392           r0ij=rpp(iteli,itelj)
2393           r0ijsq=r0ij*r0ij
2394           dxj=dc(1,j)
2395           dyj=dc(2,j)
2396           dzj=dc(3,j)
2397           xj=c(1,j)+0.5D0*dxj-xmedi
2398           yj=c(2,j)+0.5D0*dyj-ymedi
2399           zj=c(3,j)+0.5D0*dzj-zmedi
2400           rij=xj*xj+yj*yj+zj*zj
2401           if (rij.lt.r0ijsq) then
2402             evdw1ij=0.25d0*(rij-r0ijsq)**2
2403             fac=rij-r0ijsq
2404           else
2405             evdw1ij=0.0d0
2406             fac=0.0d0
2407           endif
2408           evdw1=evdw1+evdw1ij
2409 !
2410 ! Calculate contributions to the Cartesian gradient.
2411 !
2412           ggg(1)=fac*xj
2413           ggg(2)=fac*yj
2414           ggg(3)=fac*zj
2415           do k=1,3
2416             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2417             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2418           enddo
2419 !
2420 ! Loop over residues i+1 thru j-1.
2421 !
2422 !grad          do k=i+1,j-1
2423 !grad            do l=1,3
2424 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2425 !grad            enddo
2426 !grad          enddo
2427         enddo ! j
2428       enddo   ! i
2429 !grad      do i=nnt,nct-1
2430 !grad        do k=1,3
2431 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2432 !grad        enddo
2433 !grad        do j=i+1,nct-1
2434 !grad          do k=1,3
2435 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2436 !grad          enddo
2437 !grad        enddo
2438 !grad      enddo
2439       return
2440       end subroutine eelec_soft_sphere
2441 !-----------------------------------------------------------------------------
2442       subroutine vec_and_deriv
2443 !      implicit real*8 (a-h,o-z)
2444 !      include 'DIMENSIONS'
2445 #ifdef MPI
2446       include 'mpif.h'
2447 #endif
2448 !      include 'COMMON.IOUNITS'
2449 !      include 'COMMON.GEO'
2450 !      include 'COMMON.VAR'
2451 !      include 'COMMON.LOCAL'
2452 !      include 'COMMON.CHAIN'
2453 !      include 'COMMON.VECTORS'
2454 !      include 'COMMON.SETUP'
2455 !      include 'COMMON.TIME1'
2456       real(kind=8),dimension(3,3,2) :: uyder,uzder
2457       real(kind=8),dimension(2) :: vbld_inv_temp
2458 ! Compute the local reference systems. For reference system (i), the
2459 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2460 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2461 !el local variables
2462       integer :: i,j,k,l
2463       real(kind=8) :: facy,fac,costh
2464
2465 #ifdef PARVEC
2466       do i=ivec_start,ivec_end
2467 #else
2468       do i=1,nres-1
2469 #endif
2470           if (i.eq.nres-1) then
2471 ! Case of the last full residue
2472 ! Compute the Z-axis
2473             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2474             costh=dcos(pi-theta(nres))
2475             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2476             do k=1,3
2477               uz(k,i)=fac*uz(k,i)
2478             enddo
2479 ! Compute the derivatives of uz
2480             uzder(1,1,1)= 0.0d0
2481             uzder(2,1,1)=-dc_norm(3,i-1)
2482             uzder(3,1,1)= dc_norm(2,i-1)
2483             uzder(1,2,1)= dc_norm(3,i-1)
2484             uzder(2,2,1)= 0.0d0
2485             uzder(3,2,1)=-dc_norm(1,i-1)
2486             uzder(1,3,1)=-dc_norm(2,i-1)
2487             uzder(2,3,1)= dc_norm(1,i-1)
2488             uzder(3,3,1)= 0.0d0
2489             uzder(1,1,2)= 0.0d0
2490             uzder(2,1,2)= dc_norm(3,i)
2491             uzder(3,1,2)=-dc_norm(2,i)
2492             uzder(1,2,2)=-dc_norm(3,i)
2493             uzder(2,2,2)= 0.0d0
2494             uzder(3,2,2)= dc_norm(1,i)
2495             uzder(1,3,2)= dc_norm(2,i)
2496             uzder(2,3,2)=-dc_norm(1,i)
2497             uzder(3,3,2)= 0.0d0
2498 ! Compute the Y-axis
2499             facy=fac
2500             do k=1,3
2501               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2502             enddo
2503 ! Compute the derivatives of uy
2504             do j=1,3
2505               do k=1,3
2506                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2507                               -dc_norm(k,i)*dc_norm(j,i-1)
2508                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2509               enddo
2510               uyder(j,j,1)=uyder(j,j,1)-costh
2511               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2512             enddo
2513             do j=1,2
2514               do k=1,3
2515                 do l=1,3
2516                   uygrad(l,k,j,i)=uyder(l,k,j)
2517                   uzgrad(l,k,j,i)=uzder(l,k,j)
2518                 enddo
2519               enddo
2520             enddo
2521             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2522             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2523             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2524             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2525           else
2526 ! Other residues
2527 ! Compute the Z-axis
2528             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2529             costh=dcos(pi-theta(i+2))
2530             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2531             do k=1,3
2532               uz(k,i)=fac*uz(k,i)
2533             enddo
2534 ! Compute the derivatives of uz
2535             uzder(1,1,1)= 0.0d0
2536             uzder(2,1,1)=-dc_norm(3,i+1)
2537             uzder(3,1,1)= dc_norm(2,i+1)
2538             uzder(1,2,1)= dc_norm(3,i+1)
2539             uzder(2,2,1)= 0.0d0
2540             uzder(3,2,1)=-dc_norm(1,i+1)
2541             uzder(1,3,1)=-dc_norm(2,i+1)
2542             uzder(2,3,1)= dc_norm(1,i+1)
2543             uzder(3,3,1)= 0.0d0
2544             uzder(1,1,2)= 0.0d0
2545             uzder(2,1,2)= dc_norm(3,i)
2546             uzder(3,1,2)=-dc_norm(2,i)
2547             uzder(1,2,2)=-dc_norm(3,i)
2548             uzder(2,2,2)= 0.0d0
2549             uzder(3,2,2)= dc_norm(1,i)
2550             uzder(1,3,2)= dc_norm(2,i)
2551             uzder(2,3,2)=-dc_norm(1,i)
2552             uzder(3,3,2)= 0.0d0
2553 ! Compute the Y-axis
2554             facy=fac
2555             do k=1,3
2556               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2557             enddo
2558 ! Compute the derivatives of uy
2559             do j=1,3
2560               do k=1,3
2561                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2562                               -dc_norm(k,i)*dc_norm(j,i+1)
2563                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2564               enddo
2565               uyder(j,j,1)=uyder(j,j,1)-costh
2566               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2567             enddo
2568             do j=1,2
2569               do k=1,3
2570                 do l=1,3
2571                   uygrad(l,k,j,i)=uyder(l,k,j)
2572                   uzgrad(l,k,j,i)=uzder(l,k,j)
2573                 enddo
2574               enddo
2575             enddo
2576             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2577             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2578             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2579             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2580           endif
2581       enddo
2582       do i=1,nres-1
2583         vbld_inv_temp(1)=vbld_inv(i+1)
2584         if (i.lt.nres-1) then
2585           vbld_inv_temp(2)=vbld_inv(i+2)
2586           else
2587           vbld_inv_temp(2)=vbld_inv(i)
2588           endif
2589         do j=1,2
2590           do k=1,3
2591             do l=1,3
2592               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2593               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2594             enddo
2595           enddo
2596         enddo
2597       enddo
2598 #if defined(PARVEC) && defined(MPI)
2599       if (nfgtasks1.gt.1) then
2600         time00=MPI_Wtime()
2601 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2602 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2603 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2604         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2605          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2606          FG_COMM1,IERR)
2607         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2608          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2609          FG_COMM1,IERR)
2610         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2611          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2612          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2613         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2614          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2615          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2616         time_gather=time_gather+MPI_Wtime()-time00
2617       endif
2618 !      if (fg_rank.eq.0) then
2619 !        write (iout,*) "Arrays UY and UZ"
2620 !        do i=1,nres-1
2621 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2622 !     &     (uz(k,i),k=1,3)
2623 !        enddo
2624 !      endif
2625 #endif
2626       return
2627       end subroutine vec_and_deriv
2628 !-----------------------------------------------------------------------------
2629       subroutine check_vecgrad
2630 !      implicit real*8 (a-h,o-z)
2631 !      include 'DIMENSIONS'
2632 !      include 'COMMON.IOUNITS'
2633 !      include 'COMMON.GEO'
2634 !      include 'COMMON.VAR'
2635 !      include 'COMMON.LOCAL'
2636 !      include 'COMMON.CHAIN'
2637 !      include 'COMMON.VECTORS'
2638       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2639       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2640       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2641       real(kind=8),dimension(3) :: erij
2642       real(kind=8) :: delta=1.0d-7
2643 !el local variables
2644       integer :: i,j,k,l
2645
2646       call vec_and_deriv
2647 !d      do i=1,nres
2648 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2649 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2650 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2651 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2652 !d     &     (dc_norm(if90,i),if90=1,3)
2653 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2654 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2655 !d          write(iout,'(a)')
2656 !d      enddo
2657       do i=1,nres
2658         do j=1,2
2659           do k=1,3
2660             do l=1,3
2661               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2662               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2663             enddo
2664           enddo
2665         enddo
2666       enddo
2667       call vec_and_deriv
2668       do i=1,nres
2669         do j=1,3
2670           uyt(j,i)=uy(j,i)
2671           uzt(j,i)=uz(j,i)
2672         enddo
2673       enddo
2674       do i=1,nres
2675 !d        write (iout,*) 'i=',i
2676         do k=1,3
2677           erij(k)=dc_norm(k,i)
2678         enddo
2679         do j=1,3
2680           do k=1,3
2681             dc_norm(k,i)=erij(k)
2682           enddo
2683           dc_norm(j,i)=dc_norm(j,i)+delta
2684 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2685 !          do k=1,3
2686 !            dc_norm(k,i)=dc_norm(k,i)/fac
2687 !          enddo
2688 !          write (iout,*) (dc_norm(k,i),k=1,3)
2689 !          write (iout,*) (erij(k),k=1,3)
2690           call vec_and_deriv
2691           do k=1,3
2692             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2693             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2694             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2695             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2696           enddo
2697 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2698 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2699 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2700         enddo
2701         do k=1,3
2702           dc_norm(k,i)=erij(k)
2703         enddo
2704 !d        do k=1,3
2705 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2706 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2707 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2708 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2709 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2710 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2711 !d          write (iout,'(a)')
2712 !d        enddo
2713       enddo
2714       return
2715       end subroutine check_vecgrad
2716 !-----------------------------------------------------------------------------
2717       subroutine set_matrices
2718 !      implicit real*8 (a-h,o-z)
2719 !      include 'DIMENSIONS'
2720 #ifdef MPI
2721       include "mpif.h"
2722 !      include "COMMON.SETUP"
2723       integer :: IERR
2724       integer :: status(MPI_STATUS_SIZE)
2725 #endif
2726 !      include 'COMMON.IOUNITS'
2727 !      include 'COMMON.GEO'
2728 !      include 'COMMON.VAR'
2729 !      include 'COMMON.LOCAL'
2730 !      include 'COMMON.CHAIN'
2731 !      include 'COMMON.DERIV'
2732 !      include 'COMMON.INTERACT'
2733 !      include 'COMMON.CONTACTS'
2734 !      include 'COMMON.TORSION'
2735 !      include 'COMMON.VECTORS'
2736 !      include 'COMMON.FFIELD'
2737       real(kind=8) :: auxvec(2),auxmat(2,2)
2738       integer :: i,iti1,iti,k,l
2739       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2740        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2741 !       print *,"in set matrices"
2742 !
2743 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2744 ! to calculate the el-loc multibody terms of various order.
2745 !
2746 !AL el      mu=0.0d0
2747
2748 #ifdef PARMAT
2749       do i=ivec_start+2,ivec_end+2
2750 #else
2751       do i=3,nres+1
2752 #endif
2753         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2754           if (itype(i-2,1).eq.0) then
2755           iti = nloctyp
2756           else
2757           iti = itype2loc(itype(i-2,1))
2758           endif
2759         else
2760           iti=nloctyp
2761         endif
2762 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2763         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2764           iti1 = itype2loc(itype(i-1,1))
2765         else
2766           iti1=nloctyp
2767         endif
2768 !        print *,i,itype(i-2,1),iti
2769 #ifdef NEWCORR
2770         cost1=dcos(theta(i-1))
2771         sint1=dsin(theta(i-1))
2772         sint1sq=sint1*sint1
2773         sint1cub=sint1sq*sint1
2774         sint1cost1=2*sint1*cost1
2775 !        print *,"cost1",cost1,theta(i-1)
2776 !c        write (iout,*) "bnew1",i,iti
2777 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2778 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2779 !c        write (iout,*) "bnew2",i,iti
2780 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2781 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2782         k=1
2783 !        print *,bnew1(1,k,iti),"bnew1"
2784         do k=1,2
2785           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2786 !          print *,b1k
2787 !          write(*,*) shape(b1)
2788 !          if(.not.allocated(b1)) print *, "WTF?"
2789           b1(k,i-2)=sint1*b1k
2790 !
2791 !             print *,b1(k,i-2)
2792
2793           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2794                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2795 !             print *,gtb1(k,i-2)
2796
2797           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2798           b2(k,i-2)=sint1*b2k
2799 !             print *,b2(k,i-2)
2800
2801           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2802                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2803 !             print *,gtb2(k,i-2)
2804
2805         enddo
2806 !        print *,b1k,b2k
2807         do k=1,2
2808           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2809           cc(1,k,i-2)=sint1sq*aux
2810           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2811                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2812           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2813           dd(1,k,i-2)=sint1sq*aux
2814           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2815                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2816         enddo
2817 !        print *,"after cc"
2818         cc(2,1,i-2)=cc(1,2,i-2)
2819         cc(2,2,i-2)=-cc(1,1,i-2)
2820         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2821         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2822         dd(2,1,i-2)=dd(1,2,i-2)
2823         dd(2,2,i-2)=-dd(1,1,i-2)
2824         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2825         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2826 !        print *,"after dd"
2827
2828         do k=1,2
2829           do l=1,2
2830             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2831             EE(l,k,i-2)=sint1sq*aux
2832             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2833           enddo
2834         enddo
2835         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2836         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2837         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2838         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2839         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2840         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2841         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2842 !        print *,"after ee"
2843
2844 !c        b1tilde(1,i-2)=b1(1,i-2)
2845 !c        b1tilde(2,i-2)=-b1(2,i-2)
2846 !c        b2tilde(1,i-2)=b2(1,i-2)
2847 !c        b2tilde(2,i-2)=-b2(2,i-2)
2848 #ifdef DEBUG
2849         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2850         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2851         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2852         write (iout,*) 'theta=', theta(i-1)
2853 #endif
2854 #else
2855         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2856 !         write(iout,*) "i,",molnum(i)
2857 !         print *, "i,",molnum(i),i,itype(i-2,1)
2858         if (molnum(i).eq.1) then
2859           iti = itype2loc(itype(i-2,1))
2860         else
2861           iti=nloctyp
2862         endif
2863         else
2864           iti=nloctyp
2865         endif
2866 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2867 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2868         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2869           iti1 = itype2loc(itype(i-1,1))
2870         else
2871           iti1=nloctyp
2872         endif
2873 !        print *,i,iti
2874         b1(1,i-2)=b(3,iti)
2875         b1(2,i-2)=b(5,iti)
2876         b2(1,i-2)=b(2,iti)
2877         b2(2,i-2)=b(4,iti)
2878         do k=1,2
2879           do l=1,2
2880            CC(k,l,i-2)=ccold(k,l,iti)
2881            DD(k,l,i-2)=ddold(k,l,iti)
2882            EE(k,l,i-2)=eeold(k,l,iti)
2883           enddo
2884         enddo
2885 #endif
2886         b1tilde(1,i-2)= b1(1,i-2)
2887         b1tilde(2,i-2)=-b1(2,i-2)
2888         b2tilde(1,i-2)= b2(1,i-2)
2889         b2tilde(2,i-2)=-b2(2,i-2)
2890 !c
2891         Ctilde(1,1,i-2)= CC(1,1,i-2)
2892         Ctilde(1,2,i-2)= CC(1,2,i-2)
2893         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2894         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2895 !c
2896         Dtilde(1,1,i-2)= DD(1,1,i-2)
2897         Dtilde(1,2,i-2)= DD(1,2,i-2)
2898         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2899         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2900       enddo
2901 #ifdef PARMAT
2902       do i=ivec_start+2,ivec_end+2
2903 #else
2904       do i=3,nres+1
2905 #endif
2906
2907 !      print *,i,"i"
2908         if (i .lt. nres+1) then
2909           sin1=dsin(phi(i))
2910           cos1=dcos(phi(i))
2911           sintab(i-2)=sin1
2912           costab(i-2)=cos1
2913           obrot(1,i-2)=cos1
2914           obrot(2,i-2)=sin1
2915           sin2=dsin(2*phi(i))
2916           cos2=dcos(2*phi(i))
2917           sintab2(i-2)=sin2
2918           costab2(i-2)=cos2
2919           obrot2(1,i-2)=cos2
2920           obrot2(2,i-2)=sin2
2921           Ug(1,1,i-2)=-cos1
2922           Ug(1,2,i-2)=-sin1
2923           Ug(2,1,i-2)=-sin1
2924           Ug(2,2,i-2)= cos1
2925           Ug2(1,1,i-2)=-cos2
2926           Ug2(1,2,i-2)=-sin2
2927           Ug2(2,1,i-2)=-sin2
2928           Ug2(2,2,i-2)= cos2
2929         else
2930           costab(i-2)=1.0d0
2931           sintab(i-2)=0.0d0
2932           obrot(1,i-2)=1.0d0
2933           obrot(2,i-2)=0.0d0
2934           obrot2(1,i-2)=0.0d0
2935           obrot2(2,i-2)=0.0d0
2936           Ug(1,1,i-2)=1.0d0
2937           Ug(1,2,i-2)=0.0d0
2938           Ug(2,1,i-2)=0.0d0
2939           Ug(2,2,i-2)=1.0d0
2940           Ug2(1,1,i-2)=0.0d0
2941           Ug2(1,2,i-2)=0.0d0
2942           Ug2(2,1,i-2)=0.0d0
2943           Ug2(2,2,i-2)=0.0d0
2944         endif
2945         if (i .gt. 3 .and. i .lt. nres+1) then
2946           obrot_der(1,i-2)=-sin1
2947           obrot_der(2,i-2)= cos1
2948           Ugder(1,1,i-2)= sin1
2949           Ugder(1,2,i-2)=-cos1
2950           Ugder(2,1,i-2)=-cos1
2951           Ugder(2,2,i-2)=-sin1
2952           dwacos2=cos2+cos2
2953           dwasin2=sin2+sin2
2954           obrot2_der(1,i-2)=-dwasin2
2955           obrot2_der(2,i-2)= dwacos2
2956           Ug2der(1,1,i-2)= dwasin2
2957           Ug2der(1,2,i-2)=-dwacos2
2958           Ug2der(2,1,i-2)=-dwacos2
2959           Ug2der(2,2,i-2)=-dwasin2
2960         else
2961           obrot_der(1,i-2)=0.0d0
2962           obrot_der(2,i-2)=0.0d0
2963           Ugder(1,1,i-2)=0.0d0
2964           Ugder(1,2,i-2)=0.0d0
2965           Ugder(2,1,i-2)=0.0d0
2966           Ugder(2,2,i-2)=0.0d0
2967           obrot2_der(1,i-2)=0.0d0
2968           obrot2_der(2,i-2)=0.0d0
2969           Ug2der(1,1,i-2)=0.0d0
2970           Ug2der(1,2,i-2)=0.0d0
2971           Ug2der(2,1,i-2)=0.0d0
2972           Ug2der(2,2,i-2)=0.0d0
2973         endif
2974 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2975         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2976            if (itype(i-2,1).eq.0) then
2977           iti=ntortyp+1
2978            else
2979           iti = itype2loc(itype(i-2,1))
2980            endif
2981         else
2982           iti=nloctyp
2983         endif
2984 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2985         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2986            if (itype(i-1,1).eq.0) then
2987           iti1=nloctyp
2988            else
2989           iti1 = itype2loc(itype(i-1,1))
2990            endif
2991         else
2992           iti1=nloctyp
2993         endif
2994 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2995 !d        write (iout,*) '*******i',i,' iti1',iti
2996 !        write (iout,*) 'b1',b1(:,iti)
2997 !        write (iout,*) 'b2',b2(:,i-2)
2998 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2999 !        if (i .gt. iatel_s+2) then
3000         if (i .gt. nnt+2) then
3001           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3002 #ifdef NEWCORR
3003           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3004 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3005 #endif
3006
3007           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3008           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3009           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3010           then
3011           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3012           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3013           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3014           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3015           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3016           endif
3017         else
3018           do k=1,2
3019             Ub2(k,i-2)=0.0d0
3020             Ctobr(k,i-2)=0.0d0
3021             Dtobr2(k,i-2)=0.0d0
3022             do l=1,2
3023               EUg(l,k,i-2)=0.0d0
3024               CUg(l,k,i-2)=0.0d0
3025               DUg(l,k,i-2)=0.0d0
3026               DtUg2(l,k,i-2)=0.0d0
3027             enddo
3028           enddo
3029         endif
3030         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3031         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3032         do k=1,2
3033           muder(k,i-2)=Ub2der(k,i-2)
3034         enddo
3035 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3036         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3037           if (itype(i-1,1).eq.0) then
3038            iti1=nloctyp
3039           elseif (itype(i-1,1).le.ntyp) then
3040             iti1 = itype2loc(itype(i-1,1))
3041           else
3042             iti1=nloctyp
3043           endif
3044         else
3045           iti1=nloctyp
3046         endif
3047         do k=1,2
3048           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3049         enddo
3050         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3051         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3052         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3053 !d        write (iout,*) 'mu1',mu1(:,i-2)
3054 !d        write (iout,*) 'mu2',mu2(:,i-2)
3055         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3056         then
3057         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3058         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3059         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3060         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3061         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3062 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3063         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3064         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3065         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3066         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3067         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3068         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3069         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3070         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3071         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3072         endif
3073       enddo
3074 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3075 ! The order of matrices is from left to right.
3076       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3077       then
3078 !      do i=max0(ivec_start,2),ivec_end
3079       do i=2,nres-1
3080         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3081         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3082         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3083         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3084         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3085         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3086         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3087         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3088       enddo
3089       endif
3090 #if defined(MPI) && defined(PARMAT)
3091 #ifdef DEBUG
3092 !      if (fg_rank.eq.0) then
3093         write (iout,*) "Arrays UG and UGDER before GATHER"
3094         do i=1,nres-1
3095           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3096            ((ug(l,k,i),l=1,2),k=1,2),&
3097            ((ugder(l,k,i),l=1,2),k=1,2)
3098         enddo
3099         write (iout,*) "Arrays UG2 and UG2DER"
3100         do i=1,nres-1
3101           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3102            ((ug2(l,k,i),l=1,2),k=1,2),&
3103            ((ug2der(l,k,i),l=1,2),k=1,2)
3104         enddo
3105         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3106         do i=1,nres-1
3107           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3108            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3109            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3110         enddo
3111         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3112         do i=1,nres-1
3113           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3114            costab(i),sintab(i),costab2(i),sintab2(i)
3115         enddo
3116         write (iout,*) "Array MUDER"
3117         do i=1,nres-1
3118           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3119         enddo
3120 !      endif
3121 #endif
3122       if (nfgtasks.gt.1) then
3123         time00=MPI_Wtime()
3124 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3125 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3126 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3127 #ifdef MATGATHER
3128         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3129          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3130          FG_COMM1,IERR)
3131         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3132          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3133          FG_COMM1,IERR)
3134         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3135          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3136          FG_COMM1,IERR)
3137         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3138          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3139          FG_COMM1,IERR)
3140         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3141          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3142          FG_COMM1,IERR)
3143         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3144          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3145          FG_COMM1,IERR)
3146         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3147          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3148          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3149         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3150          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3151          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3152         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3153          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3154          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3155         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3156          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3157          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3158         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3159         then
3160         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3161          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3162          FG_COMM1,IERR)
3163         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3164          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3165          FG_COMM1,IERR)
3166         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3167          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3168          FG_COMM1,IERR)
3169        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3170          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3171          FG_COMM1,IERR)
3172         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3173          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3174          FG_COMM1,IERR)
3175         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3176          ivec_count(fg_rank1),&
3177          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3178          FG_COMM1,IERR)
3179         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3180          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3181          FG_COMM1,IERR)
3182         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3183          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3184          FG_COMM1,IERR)
3185         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3186          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3187          FG_COMM1,IERR)
3188         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3189          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3190          FG_COMM1,IERR)
3191         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3192          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3193          FG_COMM1,IERR)
3194         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3195          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3196          FG_COMM1,IERR)
3197         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3198          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3199          FG_COMM1,IERR)
3200         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3201          ivec_count(fg_rank1),&
3202          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3203          FG_COMM1,IERR)
3204         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3205          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3206          FG_COMM1,IERR)
3207        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3208          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3209          FG_COMM1,IERR)
3210         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3211          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3212          FG_COMM1,IERR)
3213        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3214          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3215          FG_COMM1,IERR)
3216         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3217          ivec_count(fg_rank1),&
3218          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3221          ivec_count(fg_rank1),&
3222          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3223          FG_COMM1,IERR)
3224         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3225          ivec_count(fg_rank1),&
3226          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3227          MPI_MAT2,FG_COMM1,IERR)
3228         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3229          ivec_count(fg_rank1),&
3230          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3231          MPI_MAT2,FG_COMM1,IERR)
3232         endif
3233 #else
3234 ! Passes matrix info through the ring
3235       isend=fg_rank1
3236       irecv=fg_rank1-1
3237       if (irecv.lt.0) irecv=nfgtasks1-1
3238       iprev=irecv
3239       inext=fg_rank1+1
3240       if (inext.ge.nfgtasks1) inext=0
3241       do i=1,nfgtasks1-1
3242 !        write (iout,*) "isend",isend," irecv",irecv
3243 !        call flush(iout)
3244         lensend=lentyp(isend)
3245         lenrecv=lentyp(irecv)
3246 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3247 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3248 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3249 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3250 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3251 !        write (iout,*) "Gather ROTAT1"
3252 !        call flush(iout)
3253 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3254 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3255 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3256 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3257 !        write (iout,*) "Gather ROTAT2"
3258 !        call flush(iout)
3259         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3260          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3261          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3262          iprev,4400+irecv,FG_COMM,status,IERR)
3263 !        write (iout,*) "Gather ROTAT_OLD"
3264 !        call flush(iout)
3265         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3266          MPI_PRECOMP11(lensend),inext,5500+isend,&
3267          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3268          iprev,5500+irecv,FG_COMM,status,IERR)
3269 !        write (iout,*) "Gather PRECOMP11"
3270 !        call flush(iout)
3271         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3272          MPI_PRECOMP12(lensend),inext,6600+isend,&
3273          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3274          iprev,6600+irecv,FG_COMM,status,IERR)
3275 !        write (iout,*) "Gather PRECOMP12"
3276 !        call flush(iout)
3277         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3278         then
3279         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3280          MPI_ROTAT2(lensend),inext,7700+isend,&
3281          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3282          iprev,7700+irecv,FG_COMM,status,IERR)
3283 !        write (iout,*) "Gather PRECOMP21"
3284 !        call flush(iout)
3285         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3286          MPI_PRECOMP22(lensend),inext,8800+isend,&
3287          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3288          iprev,8800+irecv,FG_COMM,status,IERR)
3289 !        write (iout,*) "Gather PRECOMP22"
3290 !        call flush(iout)
3291         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3292          MPI_PRECOMP23(lensend),inext,9900+isend,&
3293          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3294          MPI_PRECOMP23(lenrecv),&
3295          iprev,9900+irecv,FG_COMM,status,IERR)
3296 !        write (iout,*) "Gather PRECOMP23"
3297 !        call flush(iout)
3298         endif
3299         isend=irecv
3300         irecv=irecv-1
3301         if (irecv.lt.0) irecv=nfgtasks1-1
3302       enddo
3303 #endif
3304         time_gather=time_gather+MPI_Wtime()-time00
3305       endif
3306 #ifdef DEBUG
3307 !      if (fg_rank.eq.0) then
3308         write (iout,*) "Arrays UG and UGDER"
3309         do i=1,nres-1
3310           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3311            ((ug(l,k,i),l=1,2),k=1,2),&
3312            ((ugder(l,k,i),l=1,2),k=1,2)
3313         enddo
3314         write (iout,*) "Arrays UG2 and UG2DER"
3315         do i=1,nres-1
3316           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3317            ((ug2(l,k,i),l=1,2),k=1,2),&
3318            ((ug2der(l,k,i),l=1,2),k=1,2)
3319         enddo
3320         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3321         do i=1,nres-1
3322           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3323            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3324            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3325         enddo
3326         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3327         do i=1,nres-1
3328           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3329            costab(i),sintab(i),costab2(i),sintab2(i)
3330         enddo
3331         write (iout,*) "Array MUDER"
3332         do i=1,nres-1
3333           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3334         enddo
3335 !      endif
3336 #endif
3337 #endif
3338 !d      do i=1,nres
3339 !d        iti = itortyp(itype(i,1))
3340 !d        write (iout,*) i
3341 !d        do j=1,2
3342 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3343 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3344 !d        enddo
3345 !d      enddo
3346       return
3347       end subroutine set_matrices
3348 !-----------------------------------------------------------------------------
3349       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3350 !
3351 ! This subroutine calculates the average interaction energy and its gradient
3352 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3353 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3354 ! The potential depends both on the distance of peptide-group centers and on
3355 ! the orientation of the CA-CA virtual bonds.
3356 !
3357       use comm_locel
3358 !      implicit real*8 (a-h,o-z)
3359 #ifdef MPI
3360       include 'mpif.h'
3361 #endif
3362 !      include 'DIMENSIONS'
3363 !      include 'COMMON.CONTROL'
3364 !      include 'COMMON.SETUP'
3365 !      include 'COMMON.IOUNITS'
3366 !      include 'COMMON.GEO'
3367 !      include 'COMMON.VAR'
3368 !      include 'COMMON.LOCAL'
3369 !      include 'COMMON.CHAIN'
3370 !      include 'COMMON.DERIV'
3371 !      include 'COMMON.INTERACT'
3372 !      include 'COMMON.CONTACTS'
3373 !      include 'COMMON.TORSION'
3374 !      include 'COMMON.VECTORS'
3375 !      include 'COMMON.FFIELD'
3376 !      include 'COMMON.TIME1'
3377       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3378       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3379       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3380 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3381       real(kind=8),dimension(4) :: muij
3382 !el      integer :: num_conti,j1,j2
3383 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3384 !el        dz_normi,xmedi,ymedi,zmedi
3385
3386 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3387 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3388 !el          num_conti,j1,j2
3389
3390 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3391 #ifdef MOMENT
3392       real(kind=8) :: scal_el=1.0d0
3393 #else
3394       real(kind=8) :: scal_el=0.5d0
3395 #endif
3396 ! 12/13/98
3397 ! 13-go grudnia roku pamietnego...
3398       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3399                                              0.0d0,1.0d0,0.0d0,&
3400                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3401 !el local variables
3402       integer :: i,k,j
3403       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3404       real(kind=8) :: fac,t_eelecij,fracinbuf
3405
3406
3407 !d      write(iout,*) 'In EELEC'
3408 !        print *,"IN EELEC"
3409 !d      do i=1,nloctyp
3410 !d        write(iout,*) 'Type',i
3411 !d        write(iout,*) 'B1',B1(:,i)
3412 !d        write(iout,*) 'B2',B2(:,i)
3413 !d        write(iout,*) 'CC',CC(:,:,i)
3414 !d        write(iout,*) 'DD',DD(:,:,i)
3415 !d        write(iout,*) 'EE',EE(:,:,i)
3416 !d      enddo
3417 !d      call check_vecgrad
3418 !d      stop
3419 !      ees=0.0d0  !AS
3420 !      evdw1=0.0d0
3421 !      eel_loc=0.0d0
3422 !      eello_turn3=0.0d0
3423 !      eello_turn4=0.0d0
3424       t_eelecij=0.0d0
3425       ees=0.0D0
3426       evdw1=0.0D0
3427       eel_loc=0.0d0
3428       eello_turn3=0.0d0
3429       eello_turn4=0.0d0
3430 !
3431
3432       if (icheckgrad.eq.1) then
3433 !el
3434 !        do i=0,2*nres+2
3435 !          dc_norm(1,i)=0.0d0
3436 !          dc_norm(2,i)=0.0d0
3437 !          dc_norm(3,i)=0.0d0
3438 !        enddo
3439         do i=1,nres-1
3440           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3441           do k=1,3
3442             dc_norm(k,i)=dc(k,i)*fac
3443           enddo
3444 !          write (iout,*) 'i',i,' fac',fac
3445         enddo
3446       endif
3447 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3448 !        wturn6
3449       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3450           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3451           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3452 !        call vec_and_deriv
3453 #ifdef TIMING
3454         time01=MPI_Wtime()
3455 #endif
3456 !        print *, "before set matrices"
3457         call set_matrices
3458 !        print *, "after set matrices"
3459
3460 #ifdef TIMING
3461         time_mat=time_mat+MPI_Wtime()-time01
3462 #endif
3463       endif
3464 !       print *, "after set matrices"
3465 !d      do i=1,nres-1
3466 !d        write (iout,*) 'i=',i
3467 !d        do k=1,3
3468 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3469 !d        enddo
3470 !d        do k=1,3
3471 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3472 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3473 !d        enddo
3474 !d      enddo
3475       t_eelecij=0.0d0
3476       ees=0.0D0
3477       evdw1=0.0D0
3478       eel_loc=0.0d0
3479       eello_turn3=0.0d0
3480       eello_turn4=0.0d0
3481 !el      ind=0
3482       do i=1,nres
3483         num_cont_hb(i)=0
3484       enddo
3485 !d      print '(a)','Enter EELEC'
3486 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3487 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3488 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3489       do i=1,nres
3490         gel_loc_loc(i)=0.0d0
3491         gcorr_loc(i)=0.0d0
3492       enddo
3493 !
3494 !
3495 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3496 !
3497 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3498 !
3499
3500
3501 !        print *,"before iturn3 loop"
3502       do i=iturn3_start,iturn3_end
3503         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3504         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3505         dxi=dc(1,i)
3506         dyi=dc(2,i)
3507         dzi=dc(3,i)
3508         dx_normi=dc_norm(1,i)
3509         dy_normi=dc_norm(2,i)
3510         dz_normi=dc_norm(3,i)
3511         xmedi=c(1,i)+0.5d0*dxi
3512         ymedi=c(2,i)+0.5d0*dyi
3513         zmedi=c(3,i)+0.5d0*dzi
3514           xmedi=dmod(xmedi,boxxsize)
3515           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3516           ymedi=dmod(ymedi,boxysize)
3517           if (ymedi.lt.0) ymedi=ymedi+boxysize
3518           zmedi=dmod(zmedi,boxzsize)
3519           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3520         num_conti=0
3521        if ((zmedi.gt.bordlipbot) &
3522         .and.(zmedi.lt.bordliptop)) then
3523 !C the energy transfer exist
3524         if (zmedi.lt.buflipbot) then
3525 !C what fraction I am in
3526          fracinbuf=1.0d0- &
3527                ((zmedi-bordlipbot)/lipbufthick)
3528 !C lipbufthick is thickenes of lipid buffore
3529          sslipi=sscalelip(fracinbuf)
3530          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3531         elseif (zmedi.gt.bufliptop) then
3532          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3533          sslipi=sscalelip(fracinbuf)
3534          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3535         else
3536          sslipi=1.0d0
3537          ssgradlipi=0.0
3538         endif
3539        else
3540          sslipi=0.0d0
3541          ssgradlipi=0.0
3542        endif
3543 !       print *,i,sslipi,ssgradlipi
3544        call eelecij(i,i+2,ees,evdw1,eel_loc)
3545         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3546         num_cont_hb(i)=num_conti
3547       enddo
3548       do i=iturn4_start,iturn4_end
3549         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3550           .or. itype(i+3,1).eq.ntyp1 &
3551           .or. itype(i+4,1).eq.ntyp1) cycle
3552 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3553         dxi=dc(1,i)
3554         dyi=dc(2,i)
3555         dzi=dc(3,i)
3556         dx_normi=dc_norm(1,i)
3557         dy_normi=dc_norm(2,i)
3558         dz_normi=dc_norm(3,i)
3559         xmedi=c(1,i)+0.5d0*dxi
3560         ymedi=c(2,i)+0.5d0*dyi
3561         zmedi=c(3,i)+0.5d0*dzi
3562           xmedi=dmod(xmedi,boxxsize)
3563           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3564           ymedi=dmod(ymedi,boxysize)
3565           if (ymedi.lt.0) ymedi=ymedi+boxysize
3566           zmedi=dmod(zmedi,boxzsize)
3567           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3568        if ((zmedi.gt.bordlipbot)  &
3569        .and.(zmedi.lt.bordliptop)) then
3570 !C the energy transfer exist
3571         if (zmedi.lt.buflipbot) then
3572 !C what fraction I am in
3573          fracinbuf=1.0d0- &
3574              ((zmedi-bordlipbot)/lipbufthick)
3575 !C lipbufthick is thickenes of lipid buffore
3576          sslipi=sscalelip(fracinbuf)
3577          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3578         elseif (zmedi.gt.bufliptop) then
3579          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3580          sslipi=sscalelip(fracinbuf)
3581          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3582         else
3583          sslipi=1.0d0
3584          ssgradlipi=0.0
3585         endif
3586        else
3587          sslipi=0.0d0
3588          ssgradlipi=0.0
3589        endif
3590
3591         num_conti=num_cont_hb(i)
3592         call eelecij(i,i+3,ees,evdw1,eel_loc)
3593         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3594          call eturn4(i,eello_turn4)
3595 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3596         num_cont_hb(i)=num_conti
3597       enddo   ! i
3598 !
3599 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3600 !
3601 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3602       do i=iatel_s,iatel_e
3603         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3604         dxi=dc(1,i)
3605         dyi=dc(2,i)
3606         dzi=dc(3,i)
3607         dx_normi=dc_norm(1,i)
3608         dy_normi=dc_norm(2,i)
3609         dz_normi=dc_norm(3,i)
3610         xmedi=c(1,i)+0.5d0*dxi
3611         ymedi=c(2,i)+0.5d0*dyi
3612         zmedi=c(3,i)+0.5d0*dzi
3613           xmedi=dmod(xmedi,boxxsize)
3614           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3615           ymedi=dmod(ymedi,boxysize)
3616           if (ymedi.lt.0) ymedi=ymedi+boxysize
3617           zmedi=dmod(zmedi,boxzsize)
3618           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3619        if ((zmedi.gt.bordlipbot)  &
3620         .and.(zmedi.lt.bordliptop)) then
3621 !C the energy transfer exist
3622         if (zmedi.lt.buflipbot) then
3623 !C what fraction I am in
3624          fracinbuf=1.0d0- &
3625              ((zmedi-bordlipbot)/lipbufthick)
3626 !C lipbufthick is thickenes of lipid buffore
3627          sslipi=sscalelip(fracinbuf)
3628          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3629         elseif (zmedi.gt.bufliptop) then
3630          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3631          sslipi=sscalelip(fracinbuf)
3632          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3633         else
3634          sslipi=1.0d0
3635          ssgradlipi=0.0
3636         endif
3637        else
3638          sslipi=0.0d0
3639          ssgradlipi=0.0
3640        endif
3641
3642 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3643         num_conti=num_cont_hb(i)
3644         do j=ielstart(i),ielend(i)
3645 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3646           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3647           call eelecij(i,j,ees,evdw1,eel_loc)
3648         enddo ! j
3649         num_cont_hb(i)=num_conti
3650       enddo   ! i
3651 !      write (iout,*) "Number of loop steps in EELEC:",ind
3652 !d      do i=1,nres
3653 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3654 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3655 !d      enddo
3656 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3657 !cc      eel_loc=eel_loc+eello_turn3
3658 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3659       return
3660       end subroutine eelec
3661 !-----------------------------------------------------------------------------
3662       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3663
3664       use comm_locel
3665 !      implicit real*8 (a-h,o-z)
3666 !      include 'DIMENSIONS'
3667 #ifdef MPI
3668       include "mpif.h"
3669 #endif
3670 !      include 'COMMON.CONTROL'
3671 !      include 'COMMON.IOUNITS'
3672 !      include 'COMMON.GEO'
3673 !      include 'COMMON.VAR'
3674 !      include 'COMMON.LOCAL'
3675 !      include 'COMMON.CHAIN'
3676 !      include 'COMMON.DERIV'
3677 !      include 'COMMON.INTERACT'
3678 !      include 'COMMON.CONTACTS'
3679 !      include 'COMMON.TORSION'
3680 !      include 'COMMON.VECTORS'
3681 !      include 'COMMON.FFIELD'
3682 !      include 'COMMON.TIME1'
3683       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3684       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3685       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3686 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3687       real(kind=8),dimension(4) :: muij
3688       real(kind=8) :: geel_loc_ij,geel_loc_ji
3689       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3690                     dist_temp, dist_init,rlocshield,fracinbuf
3691       integer xshift,yshift,zshift,ilist,iresshield
3692 !el      integer :: num_conti,j1,j2
3693 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3694 !el        dz_normi,xmedi,ymedi,zmedi
3695
3696 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3697 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3698 !el          num_conti,j1,j2
3699
3700 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3701 #ifdef MOMENT
3702       real(kind=8) :: scal_el=1.0d0
3703 #else
3704       real(kind=8) :: scal_el=0.5d0
3705 #endif
3706 ! 12/13/98
3707 ! 13-go grudnia roku pamietnego...
3708       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3709                                              0.0d0,1.0d0,0.0d0,&
3710                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3711 !      integer :: maxconts=nres/4
3712 !el local variables
3713       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3714       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3715       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3716       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3717                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3718                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3719                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3720                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3721                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3722                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3723                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3724 !      maxconts=nres/4
3725 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3726 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3727
3728 !          time00=MPI_Wtime()
3729 !d      write (iout,*) "eelecij",i,j
3730 !          ind=ind+1
3731           iteli=itel(i)
3732           itelj=itel(j)
3733           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3734           aaa=app(iteli,itelj)
3735           bbb=bpp(iteli,itelj)
3736           ael6i=ael6(iteli,itelj)
3737           ael3i=ael3(iteli,itelj)
3738           dxj=dc(1,j)
3739           dyj=dc(2,j)
3740           dzj=dc(3,j)
3741           dx_normj=dc_norm(1,j)
3742           dy_normj=dc_norm(2,j)
3743           dz_normj=dc_norm(3,j)
3744 !          xj=c(1,j)+0.5D0*dxj-xmedi
3745 !          yj=c(2,j)+0.5D0*dyj-ymedi
3746 !          zj=c(3,j)+0.5D0*dzj-zmedi
3747           xj=c(1,j)+0.5D0*dxj
3748           yj=c(2,j)+0.5D0*dyj
3749           zj=c(3,j)+0.5D0*dzj
3750           xj=mod(xj,boxxsize)
3751           if (xj.lt.0) xj=xj+boxxsize
3752           yj=mod(yj,boxysize)
3753           if (yj.lt.0) yj=yj+boxysize
3754           zj=mod(zj,boxzsize)
3755           if (zj.lt.0) zj=zj+boxzsize
3756        if ((zj.gt.bordlipbot)  &
3757        .and.(zj.lt.bordliptop)) then
3758 !C the energy transfer exist
3759         if (zj.lt.buflipbot) then
3760 !C what fraction I am in
3761          fracinbuf=1.0d0-     &
3762              ((zj-bordlipbot)/lipbufthick)
3763 !C lipbufthick is thickenes of lipid buffore
3764          sslipj=sscalelip(fracinbuf)
3765          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3766         elseif (zj.gt.bufliptop) then
3767          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3768          sslipj=sscalelip(fracinbuf)
3769          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3770         else
3771          sslipj=1.0d0
3772          ssgradlipj=0.0
3773         endif
3774        else
3775          sslipj=0.0d0
3776          ssgradlipj=0.0
3777        endif
3778
3779       isubchap=0
3780       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3781       xj_safe=xj
3782       yj_safe=yj
3783       zj_safe=zj
3784       do xshift=-1,1
3785       do yshift=-1,1
3786       do zshift=-1,1
3787           xj=xj_safe+xshift*boxxsize
3788           yj=yj_safe+yshift*boxysize
3789           zj=zj_safe+zshift*boxzsize
3790           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3791           if(dist_temp.lt.dist_init) then
3792             dist_init=dist_temp
3793             xj_temp=xj
3794             yj_temp=yj
3795             zj_temp=zj
3796             isubchap=1
3797           endif
3798        enddo
3799        enddo
3800        enddo
3801        if (isubchap.eq.1) then
3802 !C          print *,i,j
3803           xj=xj_temp-xmedi
3804           yj=yj_temp-ymedi
3805           zj=zj_temp-zmedi
3806        else
3807           xj=xj_safe-xmedi
3808           yj=yj_safe-ymedi
3809           zj=zj_safe-zmedi
3810        endif
3811
3812           rij=xj*xj+yj*yj+zj*zj
3813           rrmij=1.0D0/rij
3814           rij=dsqrt(rij)
3815 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3816             sss_ele_cut=sscale_ele(rij)
3817             sss_ele_grad=sscagrad_ele(rij)
3818 !             sss_ele_cut=1.0d0
3819 !             sss_ele_grad=0.0d0
3820 !            print *,sss_ele_cut,sss_ele_grad,&
3821 !            (rij),r_cut_ele,rlamb_ele
3822 !            if (sss_ele_cut.le.0.0) go to 128
3823
3824           rmij=1.0D0/rij
3825           r3ij=rrmij*rmij
3826           r6ij=r3ij*r3ij
3827           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3828           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3829           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3830           fac=cosa-3.0D0*cosb*cosg
3831           ev1=aaa*r6ij*r6ij
3832 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3833           if (j.eq.i+2) ev1=scal_el*ev1
3834           ev2=bbb*r6ij
3835           fac3=ael6i*r6ij
3836           fac4=ael3i*r3ij
3837           evdwij=ev1+ev2
3838           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3839           el2=fac4*fac
3840 !          eesij=el1+el2
3841           if (shield_mode.gt.0) then
3842 !C          fac_shield(i)=0.4
3843 !C          fac_shield(j)=0.6
3844           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3845           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3846           eesij=(el1+el2)
3847           ees=ees+eesij*sss_ele_cut
3848 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3849 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3850           else
3851           fac_shield(i)=1.0
3852           fac_shield(j)=1.0
3853           eesij=(el1+el2)
3854           ees=ees+eesij   &
3855             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3856 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3857           endif
3858
3859 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3860           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3861 !          ees=ees+eesij*sss_ele_cut
3862           evdw1=evdw1+evdwij*sss_ele_cut  &
3863            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3864 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3865 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3866 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3867 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3868
3869           if (energy_dec) then
3870 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3871 !                  'evdw1',i,j,evdwij,&
3872 !                  iteli,itelj,aaa,evdw1
3873               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3874               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3875           endif
3876 !
3877 ! Calculate contributions to the Cartesian gradient.
3878 !
3879 #ifdef SPLITELE
3880           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3881               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3882           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3883              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3884           fac1=fac
3885           erij(1)=xj*rmij
3886           erij(2)=yj*rmij
3887           erij(3)=zj*rmij
3888 !
3889 ! Radial derivatives. First process both termini of the fragment (i,j)
3890 !
3891           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3892           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3893           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3894            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3895           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3896             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3897
3898           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3899           (shield_mode.gt.0)) then
3900 !C          print *,i,j
3901           do ilist=1,ishield_list(i)
3902            iresshield=shield_list(ilist,i)
3903            do k=1,3
3904            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3905            *2.0*sss_ele_cut
3906            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3907                    rlocshield &
3908             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3909             *sss_ele_cut
3910             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3911            enddo
3912           enddo
3913           do ilist=1,ishield_list(j)
3914            iresshield=shield_list(ilist,j)
3915            do k=1,3
3916            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3917           *2.0*sss_ele_cut
3918            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3919                    rlocshield &
3920            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3921            *sss_ele_cut
3922            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3923            enddo
3924           enddo
3925           do k=1,3
3926             gshieldc(k,i)=gshieldc(k,i)+ &
3927                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3928            *sss_ele_cut
3929
3930             gshieldc(k,j)=gshieldc(k,j)+ &
3931                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3932            *sss_ele_cut
3933
3934             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3935                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3936            *sss_ele_cut
3937
3938             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3939                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3940            *sss_ele_cut
3941
3942            enddo
3943            endif
3944
3945
3946 !          do k=1,3
3947 !            ghalf=0.5D0*ggg(k)
3948 !            gelc(k,i)=gelc(k,i)+ghalf
3949 !            gelc(k,j)=gelc(k,j)+ghalf
3950 !          enddo
3951 ! 9/28/08 AL Gradient compotents will be summed only at the end
3952           do k=1,3
3953             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3954             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3955           enddo
3956             gelc_long(3,j)=gelc_long(3,j)+  &
3957           ssgradlipj*eesij/2.0d0*lipscale**2&
3958            *sss_ele_cut
3959
3960             gelc_long(3,i)=gelc_long(3,i)+  &
3961           ssgradlipi*eesij/2.0d0*lipscale**2&
3962            *sss_ele_cut
3963
3964
3965 !
3966 ! Loop over residues i+1 thru j-1.
3967 !
3968 !grad          do k=i+1,j-1
3969 !grad            do l=1,3
3970 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3971 !grad            enddo
3972 !grad          enddo
3973           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3974            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3975           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3976            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3977           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3978            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3979
3980 !          do k=1,3
3981 !            ghalf=0.5D0*ggg(k)
3982 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3983 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3984 !          enddo
3985 ! 9/28/08 AL Gradient compotents will be summed only at the end
3986           do k=1,3
3987             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3988             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3989           enddo
3990
3991 !C Lipidic part for scaling weight
3992            gvdwpp(3,j)=gvdwpp(3,j)+ &
3993           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3994            gvdwpp(3,i)=gvdwpp(3,i)+ &
3995           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3996 !! Loop over residues i+1 thru j-1.
3997 !
3998 !grad          do k=i+1,j-1
3999 !grad            do l=1,3
4000 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4001 !grad            enddo
4002 !grad          enddo
4003 #else
4004           facvdw=(ev1+evdwij)*sss_ele_cut &
4005            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4006
4007           facel=(el1+eesij)*sss_ele_cut
4008           fac1=fac
4009           fac=-3*rrmij*(facvdw+facvdw+facel)
4010           erij(1)=xj*rmij
4011           erij(2)=yj*rmij
4012           erij(3)=zj*rmij
4013 !
4014 ! Radial derivatives. First process both termini of the fragment (i,j)
4015 !
4016           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4017           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4018           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4019 !          do k=1,3
4020 !            ghalf=0.5D0*ggg(k)
4021 !            gelc(k,i)=gelc(k,i)+ghalf
4022 !            gelc(k,j)=gelc(k,j)+ghalf
4023 !          enddo
4024 ! 9/28/08 AL Gradient compotents will be summed only at the end
4025           do k=1,3
4026             gelc_long(k,j)=gelc(k,j)+ggg(k)
4027             gelc_long(k,i)=gelc(k,i)-ggg(k)
4028           enddo
4029 !
4030 ! Loop over residues i+1 thru j-1.
4031 !
4032 !grad          do k=i+1,j-1
4033 !grad            do l=1,3
4034 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4035 !grad            enddo
4036 !grad          enddo
4037 ! 9/28/08 AL Gradient compotents will be summed only at the end
4038           ggg(1)=facvdw*xj &
4039            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4040           ggg(2)=facvdw*yj &
4041            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4042           ggg(3)=facvdw*zj &
4043            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4044
4045           do k=1,3
4046             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4047             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4048           enddo
4049            gvdwpp(3,j)=gvdwpp(3,j)+ &
4050           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4051            gvdwpp(3,i)=gvdwpp(3,i)+ &
4052           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4053
4054 #endif
4055 !
4056 ! Angular part
4057 !
4058           ecosa=2.0D0*fac3*fac1+fac4
4059           fac4=-3.0D0*fac4
4060           fac3=-6.0D0*fac3
4061           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4062           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4063           do k=1,3
4064             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4065             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4066           enddo
4067 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4068 !d   &          (dcosg(k),k=1,3)
4069           do k=1,3
4070             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4071              *fac_shield(i)**2*fac_shield(j)**2 &
4072              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4073
4074           enddo
4075 !          do k=1,3
4076 !            ghalf=0.5D0*ggg(k)
4077 !            gelc(k,i)=gelc(k,i)+ghalf
4078 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4079 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4080 !            gelc(k,j)=gelc(k,j)+ghalf
4081 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4082 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4083 !          enddo
4084 !grad          do k=i+1,j-1
4085 !grad            do l=1,3
4086 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4087 !grad            enddo
4088 !grad          enddo
4089           do k=1,3
4090             gelc(k,i)=gelc(k,i) &
4091                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4092                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4093                      *sss_ele_cut &
4094                      *fac_shield(i)**2*fac_shield(j)**2 &
4095                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4096
4097             gelc(k,j)=gelc(k,j) &
4098                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4099                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4100                      *sss_ele_cut  &
4101                      *fac_shield(i)**2*fac_shield(j)**2  &
4102                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4103
4104             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4105             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4106           enddo
4107
4108           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4109               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4110               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4111 !
4112 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4113 !   energy of a peptide unit is assumed in the form of a second-order
4114 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4115 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4116 !   are computed for EVERY pair of non-contiguous peptide groups.
4117 !
4118           if (j.lt.nres-1) then
4119             j1=j+1
4120             j2=j-1
4121           else
4122             j1=j-1
4123             j2=j-2
4124           endif
4125           kkk=0
4126           do k=1,2
4127             do l=1,2
4128               kkk=kkk+1
4129               muij(kkk)=mu(k,i)*mu(l,j)
4130 #ifdef NEWCORR
4131              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4132 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4133              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4134              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4135 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4136              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4137 #endif
4138
4139             enddo
4140           enddo
4141 !d         write (iout,*) 'EELEC: i',i,' j',j
4142 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4143 !d          write(iout,*) 'muij',muij
4144           ury=scalar(uy(1,i),erij)
4145           urz=scalar(uz(1,i),erij)
4146           vry=scalar(uy(1,j),erij)
4147           vrz=scalar(uz(1,j),erij)
4148           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4149           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4150           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4151           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4152           fac=dsqrt(-ael6i)*r3ij
4153           a22=a22*fac
4154           a23=a23*fac
4155           a32=a32*fac
4156           a33=a33*fac
4157 !d          write (iout,'(4i5,4f10.5)')
4158 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4159 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4160 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4161 !d     &      uy(:,j),uz(:,j)
4162 !d          write (iout,'(4f10.5)')
4163 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4164 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4165 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4166 !d           write (iout,'(9f10.5/)')
4167 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4168 ! Derivatives of the elements of A in virtual-bond vectors
4169           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4170           do k=1,3
4171             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4172             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4173             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4174             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4175             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4176             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4177             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4178             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4179             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4180             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4181             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4182             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4183           enddo
4184 ! Compute radial contributions to the gradient
4185           facr=-3.0d0*rrmij
4186           a22der=a22*facr
4187           a23der=a23*facr
4188           a32der=a32*facr
4189           a33der=a33*facr
4190           agg(1,1)=a22der*xj
4191           agg(2,1)=a22der*yj
4192           agg(3,1)=a22der*zj
4193           agg(1,2)=a23der*xj
4194           agg(2,2)=a23der*yj
4195           agg(3,2)=a23der*zj
4196           agg(1,3)=a32der*xj
4197           agg(2,3)=a32der*yj
4198           agg(3,3)=a32der*zj
4199           agg(1,4)=a33der*xj
4200           agg(2,4)=a33der*yj
4201           agg(3,4)=a33der*zj
4202 ! Add the contributions coming from er
4203           fac3=-3.0d0*fac
4204           do k=1,3
4205             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4206             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4207             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4208             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4209           enddo
4210           do k=1,3
4211 ! Derivatives in DC(i)
4212 !grad            ghalf1=0.5d0*agg(k,1)
4213 !grad            ghalf2=0.5d0*agg(k,2)
4214 !grad            ghalf3=0.5d0*agg(k,3)
4215 !grad            ghalf4=0.5d0*agg(k,4)
4216             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4217             -3.0d0*uryg(k,2)*vry)!+ghalf1
4218             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4219             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4220             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4221             -3.0d0*urzg(k,2)*vry)!+ghalf3
4222             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4223             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4224 ! Derivatives in DC(i+1)
4225             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4226             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4227             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4228             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4229             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4230             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4231             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4232             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4233 ! Derivatives in DC(j)
4234             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4235             -3.0d0*vryg(k,2)*ury)!+ghalf1
4236             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4237             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4238             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4239             -3.0d0*vryg(k,2)*urz)!+ghalf3
4240             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4241             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4242 ! Derivatives in DC(j+1) or DC(nres-1)
4243             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4244             -3.0d0*vryg(k,3)*ury)
4245             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4246             -3.0d0*vrzg(k,3)*ury)
4247             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4248             -3.0d0*vryg(k,3)*urz)
4249             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4250             -3.0d0*vrzg(k,3)*urz)
4251 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4252 !grad              do l=1,4
4253 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4254 !grad              enddo
4255 !grad            endif
4256           enddo
4257           acipa(1,1)=a22
4258           acipa(1,2)=a23
4259           acipa(2,1)=a32
4260           acipa(2,2)=a33
4261           a22=-a22
4262           a23=-a23
4263           do l=1,2
4264             do k=1,3
4265               agg(k,l)=-agg(k,l)
4266               aggi(k,l)=-aggi(k,l)
4267               aggi1(k,l)=-aggi1(k,l)
4268               aggj(k,l)=-aggj(k,l)
4269               aggj1(k,l)=-aggj1(k,l)
4270             enddo
4271           enddo
4272           if (j.lt.nres-1) then
4273             a22=-a22
4274             a32=-a32
4275             do l=1,3,2
4276               do k=1,3
4277                 agg(k,l)=-agg(k,l)
4278                 aggi(k,l)=-aggi(k,l)
4279                 aggi1(k,l)=-aggi1(k,l)
4280                 aggj(k,l)=-aggj(k,l)
4281                 aggj1(k,l)=-aggj1(k,l)
4282               enddo
4283             enddo
4284           else
4285             a22=-a22
4286             a23=-a23
4287             a32=-a32
4288             a33=-a33
4289             do l=1,4
4290               do k=1,3
4291                 agg(k,l)=-agg(k,l)
4292                 aggi(k,l)=-aggi(k,l)
4293                 aggi1(k,l)=-aggi1(k,l)
4294                 aggj(k,l)=-aggj(k,l)
4295                 aggj1(k,l)=-aggj1(k,l)
4296               enddo
4297             enddo
4298           endif
4299           ENDIF ! WCORR
4300           IF (wel_loc.gt.0.0d0) THEN
4301 ! Contribution to the local-electrostatic energy coming from the i-j pair
4302           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4303            +a33*muij(4)
4304           if (shield_mode.eq.0) then
4305            fac_shield(i)=1.0
4306            fac_shield(j)=1.0
4307           endif
4308           eel_loc_ij=eel_loc_ij &
4309          *fac_shield(i)*fac_shield(j) &
4310          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4311 !C Now derivative over eel_loc
4312           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4313          (shield_mode.gt.0)) then
4314 !C          print *,i,j
4315
4316           do ilist=1,ishield_list(i)
4317            iresshield=shield_list(ilist,i)
4318            do k=1,3
4319            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4320                                                 /fac_shield(i)&
4321            *sss_ele_cut
4322            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4323                    rlocshield  &
4324           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4325           *sss_ele_cut
4326
4327             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4328            +rlocshield
4329            enddo
4330           enddo
4331           do ilist=1,ishield_list(j)
4332            iresshield=shield_list(ilist,j)
4333            do k=1,3
4334            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4335                                             /fac_shield(j)   &
4336             *sss_ele_cut
4337            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4338                    rlocshield  &
4339       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4340        *sss_ele_cut
4341
4342            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4343                   +rlocshield
4344
4345            enddo
4346           enddo
4347
4348           do k=1,3
4349             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4350                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4351                     *sss_ele_cut
4352             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4353                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4354                     *sss_ele_cut
4355             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4356                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4357                     *sss_ele_cut
4358             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4359                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4360                     *sss_ele_cut
4361
4362            enddo
4363            endif
4364
4365 #ifdef NEWCORR
4366          geel_loc_ij=(a22*gmuij1(1)&
4367           +a23*gmuij1(2)&
4368           +a32*gmuij1(3)&
4369           +a33*gmuij1(4))&
4370          *fac_shield(i)*fac_shield(j)&
4371                     *sss_ele_cut
4372
4373 !c         write(iout,*) "derivative over thatai"
4374 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4375 !c     &   a33*gmuij1(4)
4376          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4377            geel_loc_ij*wel_loc
4378 !c         write(iout,*) "derivative over thatai-1"
4379 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4380 !c     &   a33*gmuij2(4)
4381          geel_loc_ij=&
4382           a22*gmuij2(1)&
4383           +a23*gmuij2(2)&
4384           +a32*gmuij2(3)&
4385           +a33*gmuij2(4)
4386          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4387            geel_loc_ij*wel_loc&
4388          *fac_shield(i)*fac_shield(j)&
4389                     *sss_ele_cut
4390
4391
4392 !c  Derivative over j residue
4393          geel_loc_ji=a22*gmuji1(1)&
4394           +a23*gmuji1(2)&
4395           +a32*gmuji1(3)&
4396           +a33*gmuji1(4)
4397 !c         write(iout,*) "derivative over thataj"
4398 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4399 !c     &   a33*gmuji1(4)
4400
4401         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4402            geel_loc_ji*wel_loc&
4403          *fac_shield(i)*fac_shield(j)&
4404                     *sss_ele_cut
4405
4406
4407          geel_loc_ji=&
4408           +a22*gmuji2(1)&
4409           +a23*gmuji2(2)&
4410           +a32*gmuji2(3)&
4411           +a33*gmuji2(4)
4412 !c         write(iout,*) "derivative over thataj-1"
4413 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4414 !c     &   a33*gmuji2(4)
4415          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4416            geel_loc_ji*wel_loc&
4417          *fac_shield(i)*fac_shield(j)&
4418                     *sss_ele_cut
4419 #endif
4420
4421 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4422 !           eel_loc_ij=0.0
4423 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4424 !                  'eelloc',i,j,eel_loc_ij
4425           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4426                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4427 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4428
4429 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4430 !          if (energy_dec) write (iout,*) "muij",muij
4431 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4432
4433           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4434 ! Partial derivatives in virtual-bond dihedral angles gamma
4435           if (i.gt.1) &
4436           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4437                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4438                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4439                  *sss_ele_cut  &
4440           *fac_shield(i)*fac_shield(j) &
4441           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4442
4443           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4444                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4445                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4446                  *sss_ele_cut &
4447           *fac_shield(i)*fac_shield(j) &
4448           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4449 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4450 !          do l=1,3
4451 !            ggg(1)=(agg(1,1)*muij(1)+ &
4452 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4453 !            *sss_ele_cut &
4454 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4455 !            ggg(2)=(agg(2,1)*muij(1)+ &
4456 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4457 !            *sss_ele_cut &
4458 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4459 !            ggg(3)=(agg(3,1)*muij(1)+ &
4460 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4461 !            *sss_ele_cut &
4462 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4463            xtemp(1)=xj
4464            xtemp(2)=yj
4465            xtemp(3)=zj
4466
4467            do l=1,3
4468             ggg(l)=(agg(l,1)*muij(1)+ &
4469                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4470             *sss_ele_cut &
4471           *fac_shield(i)*fac_shield(j) &
4472           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4473              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4474
4475
4476             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4477             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4478 !grad            ghalf=0.5d0*ggg(l)
4479 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4480 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4481           enddo
4482             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4483           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4484           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4485
4486             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4487           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4488           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4489
4490 !grad          do k=i+1,j2
4491 !grad            do l=1,3
4492 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4493 !grad            enddo
4494 !grad          enddo
4495 ! Remaining derivatives of eello
4496           do l=1,3
4497             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4498                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4499             *sss_ele_cut &
4500           *fac_shield(i)*fac_shield(j) &
4501           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4502
4503 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4504             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4505                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4506             +aggi1(l,4)*muij(4))&
4507             *sss_ele_cut &
4508           *fac_shield(i)*fac_shield(j) &
4509           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4510
4511 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4512             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4513                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4514             *sss_ele_cut &
4515           *fac_shield(i)*fac_shield(j) &
4516           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4517
4518 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4519             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4520                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4521             +aggj1(l,4)*muij(4))&
4522             *sss_ele_cut &
4523           *fac_shield(i)*fac_shield(j) &
4524          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4525
4526 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4527           enddo
4528           ENDIF
4529 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4530 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4531           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4532              .and. num_conti.le.maxconts) then
4533 !            write (iout,*) i,j," entered corr"
4534 !
4535 ! Calculate the contact function. The ith column of the array JCONT will
4536 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4537 ! greater than I). The arrays FACONT and GACONT will contain the values of
4538 ! the contact function and its derivative.
4539 !           r0ij=1.02D0*rpp(iteli,itelj)
4540 !           r0ij=1.11D0*rpp(iteli,itelj)
4541             r0ij=2.20D0*rpp(iteli,itelj)
4542 !           r0ij=1.55D0*rpp(iteli,itelj)
4543             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4544 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4545             if (fcont.gt.0.0D0) then
4546               num_conti=num_conti+1
4547               if (num_conti.gt.maxconts) then
4548 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4549 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4550                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4551                                ' will skip next contacts for this conf.', num_conti
4552               else
4553                 jcont_hb(num_conti,i)=j
4554 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4555 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4556                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4557                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4558 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4559 !  terms.
4560                 d_cont(num_conti,i)=rij
4561 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4562 !     --- Electrostatic-interaction matrix ---
4563                 a_chuj(1,1,num_conti,i)=a22
4564                 a_chuj(1,2,num_conti,i)=a23
4565                 a_chuj(2,1,num_conti,i)=a32
4566                 a_chuj(2,2,num_conti,i)=a33
4567 !     --- Gradient of rij
4568                 do kkk=1,3
4569                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4570                 enddo
4571                 kkll=0
4572                 do k=1,2
4573                   do l=1,2
4574                     kkll=kkll+1
4575                     do m=1,3
4576                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4577                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4578                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4579                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4580                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4581                     enddo
4582                   enddo
4583                 enddo
4584                 ENDIF
4585                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4586 ! Calculate contact energies
4587                 cosa4=4.0D0*cosa
4588                 wij=cosa-3.0D0*cosb*cosg
4589                 cosbg1=cosb+cosg
4590                 cosbg2=cosb-cosg
4591 !               fac3=dsqrt(-ael6i)/r0ij**3
4592                 fac3=dsqrt(-ael6i)*r3ij
4593 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4594                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4595                 if (ees0tmp.gt.0) then
4596                   ees0pij=dsqrt(ees0tmp)
4597                 else
4598                   ees0pij=0
4599                 endif
4600                 if (shield_mode.eq.0) then
4601                 fac_shield(i)=1.0d0
4602                 fac_shield(j)=1.0d0
4603                 else
4604                 ees0plist(num_conti,i)=j
4605                 endif
4606 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4607                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4608                 if (ees0tmp.gt.0) then
4609                   ees0mij=dsqrt(ees0tmp)
4610                 else
4611                   ees0mij=0
4612                 endif
4613 !               ees0mij=0.0D0
4614                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4615                      *sss_ele_cut &
4616                      *fac_shield(i)*fac_shield(j)
4617
4618                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4619                      *sss_ele_cut &
4620                      *fac_shield(i)*fac_shield(j)
4621
4622 ! Diagnostics. Comment out or remove after debugging!
4623 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4624 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4625 !               ees0m(num_conti,i)=0.0D0
4626 ! End diagnostics.
4627 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4628 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4629 ! Angular derivatives of the contact function
4630                 ees0pij1=fac3/ees0pij
4631                 ees0mij1=fac3/ees0mij
4632                 fac3p=-3.0D0*fac3*rrmij
4633                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4634                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4635 !               ees0mij1=0.0D0
4636                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4637                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4638                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4639                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4640                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4641                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4642                 ecosap=ecosa1+ecosa2
4643                 ecosbp=ecosb1+ecosb2
4644                 ecosgp=ecosg1+ecosg2
4645                 ecosam=ecosa1-ecosa2
4646                 ecosbm=ecosb1-ecosb2
4647                 ecosgm=ecosg1-ecosg2
4648 ! Diagnostics
4649 !               ecosap=ecosa1
4650 !               ecosbp=ecosb1
4651 !               ecosgp=ecosg1
4652 !               ecosam=0.0D0
4653 !               ecosbm=0.0D0
4654 !               ecosgm=0.0D0
4655 ! End diagnostics
4656                 facont_hb(num_conti,i)=fcont
4657                 fprimcont=fprimcont/rij
4658 !d              facont_hb(num_conti,i)=1.0D0
4659 ! Following line is for diagnostics.
4660 !d              fprimcont=0.0D0
4661                 do k=1,3
4662                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4663                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4664                 enddo
4665                 do k=1,3
4666                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4667                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4668                 enddo
4669                 gggp(1)=gggp(1)+ees0pijp*xj &
4670                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4671                 gggp(2)=gggp(2)+ees0pijp*yj &
4672                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4673                 gggp(3)=gggp(3)+ees0pijp*zj &
4674                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4675
4676                 gggm(1)=gggm(1)+ees0mijp*xj &
4677                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4678
4679                 gggm(2)=gggm(2)+ees0mijp*yj &
4680                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4681
4682                 gggm(3)=gggm(3)+ees0mijp*zj &
4683                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4684
4685 ! Derivatives due to the contact function
4686                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4687                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4688                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4689                 do k=1,3
4690 !
4691 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4692 !          following the change of gradient-summation algorithm.
4693 !
4694 !grad                  ghalfp=0.5D0*gggp(k)
4695 !grad                  ghalfm=0.5D0*gggm(k)
4696                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4697                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4698                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4699                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4700
4701                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4702                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4703                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4704                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4705
4706                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4707                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4708
4709                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4710                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4711                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4712                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4713
4714                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4715                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4716                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4717                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4718
4719                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4720                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4721
4722                 enddo
4723 ! Diagnostics. Comment out or remove after debugging!
4724 !diag           do k=1,3
4725 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4726 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4727 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4728 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4729 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4730 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4731 !diag           enddo
4732               ENDIF ! wcorr
4733               endif  ! num_conti.le.maxconts
4734             endif  ! fcont.gt.0
4735           endif    ! j.gt.i+1
4736           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4737             do k=1,4
4738               do l=1,3
4739                 ghalf=0.5d0*agg(l,k)
4740                 aggi(l,k)=aggi(l,k)+ghalf
4741                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4742                 aggj(l,k)=aggj(l,k)+ghalf
4743               enddo
4744             enddo
4745             if (j.eq.nres-1 .and. i.lt.j-2) then
4746               do k=1,4
4747                 do l=1,3
4748                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4749                 enddo
4750               enddo
4751             endif
4752           endif
4753  128  continue
4754 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4755       return
4756       end subroutine eelecij
4757 !-----------------------------------------------------------------------------
4758       subroutine eturn3(i,eello_turn3)
4759 ! Third- and fourth-order contributions from turns
4760
4761       use comm_locel
4762 !      implicit real*8 (a-h,o-z)
4763 !      include 'DIMENSIONS'
4764 !      include 'COMMON.IOUNITS'
4765 !      include 'COMMON.GEO'
4766 !      include 'COMMON.VAR'
4767 !      include 'COMMON.LOCAL'
4768 !      include 'COMMON.CHAIN'
4769 !      include 'COMMON.DERIV'
4770 !      include 'COMMON.INTERACT'
4771 !      include 'COMMON.CONTACTS'
4772 !      include 'COMMON.TORSION'
4773 !      include 'COMMON.VECTORS'
4774 !      include 'COMMON.FFIELD'
4775 !      include 'COMMON.CONTROL'
4776       real(kind=8),dimension(3) :: ggg
4777       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4778         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4779        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4780
4781       real(kind=8),dimension(2) :: auxvec,auxvec1
4782 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4783       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4784 !el      integer :: num_conti,j1,j2
4785 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4786 !el        dz_normi,xmedi,ymedi,zmedi
4787
4788 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4789 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4790 !el         num_conti,j1,j2
4791 !el local variables
4792       integer :: i,j,l,k,ilist,iresshield
4793       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4794
4795       j=i+2
4796 !      write (iout,*) "eturn3",i,j,j1,j2
4797           zj=(c(3,j)+c(3,j+1))/2.0d0
4798           zj=mod(zj,boxzsize)
4799           if (zj.lt.0) zj=zj+boxzsize
4800           if ((zj.lt.0)) write (*,*) "CHUJ"
4801        if ((zj.gt.bordlipbot)  &
4802         .and.(zj.lt.bordliptop)) then
4803 !C the energy transfer exist
4804         if (zj.lt.buflipbot) then
4805 !C what fraction I am in
4806          fracinbuf=1.0d0-     &
4807              ((zj-bordlipbot)/lipbufthick)
4808 !C lipbufthick is thickenes of lipid buffore
4809          sslipj=sscalelip(fracinbuf)
4810          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4811         elseif (zj.gt.bufliptop) then
4812          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4813          sslipj=sscalelip(fracinbuf)
4814          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4815         else
4816          sslipj=1.0d0
4817          ssgradlipj=0.0
4818         endif
4819        else
4820          sslipj=0.0d0
4821          ssgradlipj=0.0
4822        endif
4823
4824       a_temp(1,1)=a22
4825       a_temp(1,2)=a23
4826       a_temp(2,1)=a32
4827       a_temp(2,2)=a33
4828 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4829 !
4830 !               Third-order contributions
4831 !
4832 !                 (i+2)o----(i+3)
4833 !                      | |
4834 !                      | |
4835 !                 (i+1)o----i
4836 !
4837 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4838 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4839         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4840         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4841         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4842         call transpose2(auxmat(1,1),auxmat1(1,1))
4843         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4844         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4845         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4846         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4847         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4848
4849         if (shield_mode.eq.0) then
4850         fac_shield(i)=1.0d0
4851         fac_shield(j)=1.0d0
4852         endif
4853
4854         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4855          *fac_shield(i)*fac_shield(j)  &
4856          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4857         eello_t3= &
4858         0.5d0*(pizda(1,1)+pizda(2,2)) &
4859         *fac_shield(i)*fac_shield(j)
4860
4861         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4862                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4863 !C#ifdef NEWCORR
4864 !C Derivatives in theta
4865         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4866        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4867         *fac_shield(i)*fac_shield(j)
4868         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4869        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4870         *fac_shield(i)*fac_shield(j)
4871 !C#endif
4872
4873
4874
4875           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4876        (shield_mode.gt.0)) then
4877 !C          print *,i,j
4878
4879           do ilist=1,ishield_list(i)
4880            iresshield=shield_list(ilist,i)
4881            do k=1,3
4882            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4883            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4884                    rlocshield &
4885            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4886             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4887              +rlocshield
4888            enddo
4889           enddo
4890           do ilist=1,ishield_list(j)
4891            iresshield=shield_list(ilist,j)
4892            do k=1,3
4893            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4894            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4895                    rlocshield &
4896            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4897            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4898                   +rlocshield
4899
4900            enddo
4901           enddo
4902
4903           do k=1,3
4904             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4905                    grad_shield(k,i)*eello_t3/fac_shield(i)
4906             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4907                    grad_shield(k,j)*eello_t3/fac_shield(j)
4908             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4909                    grad_shield(k,i)*eello_t3/fac_shield(i)
4910             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4911                    grad_shield(k,j)*eello_t3/fac_shield(j)
4912            enddo
4913            endif
4914
4915 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4916 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4917 !d     &    ' eello_turn3_num',4*eello_turn3_num
4918 ! Derivatives in gamma(i)
4919         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4920         call transpose2(auxmat2(1,1),auxmat3(1,1))
4921         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4922         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4923           *fac_shield(i)*fac_shield(j)        &
4924           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4925 ! Derivatives in gamma(i+1)
4926         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4927         call transpose2(auxmat2(1,1),auxmat3(1,1))
4928         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4929         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4930           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4931           *fac_shield(i)*fac_shield(j)        &
4932           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4933
4934 ! Cartesian derivatives
4935         do l=1,3
4936 !            ghalf1=0.5d0*agg(l,1)
4937 !            ghalf2=0.5d0*agg(l,2)
4938 !            ghalf3=0.5d0*agg(l,3)
4939 !            ghalf4=0.5d0*agg(l,4)
4940           a_temp(1,1)=aggi(l,1)!+ghalf1
4941           a_temp(1,2)=aggi(l,2)!+ghalf2
4942           a_temp(2,1)=aggi(l,3)!+ghalf3
4943           a_temp(2,2)=aggi(l,4)!+ghalf4
4944           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4945           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4946             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4947           *fac_shield(i)*fac_shield(j)      &
4948           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4949
4950           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4951           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4952           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4953           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4954           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4955           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4956             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4957           *fac_shield(i)*fac_shield(j)        &
4958           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4959
4960           a_temp(1,1)=aggj(l,1)!+ghalf1
4961           a_temp(1,2)=aggj(l,2)!+ghalf2
4962           a_temp(2,1)=aggj(l,3)!+ghalf3
4963           a_temp(2,2)=aggj(l,4)!+ghalf4
4964           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4965           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4966             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4967           *fac_shield(i)*fac_shield(j)      &
4968           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4969
4970           a_temp(1,1)=aggj1(l,1)
4971           a_temp(1,2)=aggj1(l,2)
4972           a_temp(2,1)=aggj1(l,3)
4973           a_temp(2,2)=aggj1(l,4)
4974           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4975           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4976             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4977           *fac_shield(i)*fac_shield(j)        &
4978           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4979         enddo
4980          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4981           ssgradlipi*eello_t3/4.0d0*lipscale
4982          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4983           ssgradlipj*eello_t3/4.0d0*lipscale
4984          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4985           ssgradlipi*eello_t3/4.0d0*lipscale
4986          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4987           ssgradlipj*eello_t3/4.0d0*lipscale
4988
4989       return
4990       end subroutine eturn3
4991 !-----------------------------------------------------------------------------
4992       subroutine eturn4(i,eello_turn4)
4993 ! Third- and fourth-order contributions from turns
4994
4995       use comm_locel
4996 !      implicit real*8 (a-h,o-z)
4997 !      include 'DIMENSIONS'
4998 !      include 'COMMON.IOUNITS'
4999 !      include 'COMMON.GEO'
5000 !      include 'COMMON.VAR'
5001 !      include 'COMMON.LOCAL'
5002 !      include 'COMMON.CHAIN'
5003 !      include 'COMMON.DERIV'
5004 !      include 'COMMON.INTERACT'
5005 !      include 'COMMON.CONTACTS'
5006 !      include 'COMMON.TORSION'
5007 !      include 'COMMON.VECTORS'
5008 !      include 'COMMON.FFIELD'
5009 !      include 'COMMON.CONTROL'
5010       real(kind=8),dimension(3) :: ggg
5011       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5012         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5013         gte1t,gte2t,gte3t,&
5014         gte1a,gtae3,gtae3e2, ae3gte2,&
5015         gtEpizda1,gtEpizda2,gtEpizda3
5016
5017       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5018        auxgEvec3,auxgvec
5019
5020 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5021       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5022 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5023 !el        dz_normi,xmedi,ymedi,zmedi
5024 !el      integer :: num_conti,j1,j2
5025 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5026 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5027 !el          num_conti,j1,j2
5028 !el local variables
5029       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5030       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5031          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5032
5033       j=i+3
5034 !      if (j.ne.20) return
5035 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5036 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5037 !
5038 !               Fourth-order contributions
5039 !
5040 !                 (i+3)o----(i+4)
5041 !                     /  |
5042 !               (i+2)o   |
5043 !                     \  |
5044 !                 (i+1)o----i
5045 !
5046 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5047 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5048 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5049           zj=(c(3,j)+c(3,j+1))/2.0d0
5050           zj=mod(zj,boxzsize)
5051           if (zj.lt.0) zj=zj+boxzsize
5052        if ((zj.gt.bordlipbot)  &
5053         .and.(zj.lt.bordliptop)) then
5054 !C the energy transfer exist
5055         if (zj.lt.buflipbot) then
5056 !C what fraction I am in
5057          fracinbuf=1.0d0-     &
5058              ((zj-bordlipbot)/lipbufthick)
5059 !C lipbufthick is thickenes of lipid buffore
5060          sslipj=sscalelip(fracinbuf)
5061          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5062         elseif (zj.gt.bufliptop) then
5063          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5064          sslipj=sscalelip(fracinbuf)
5065          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5066         else
5067          sslipj=1.0d0
5068          ssgradlipj=0.0
5069         endif
5070        else
5071          sslipj=0.0d0
5072          ssgradlipj=0.0
5073        endif
5074
5075         a_temp(1,1)=a22
5076         a_temp(1,2)=a23
5077         a_temp(2,1)=a32
5078         a_temp(2,2)=a33
5079         iti1=i+1
5080         iti2=i+2
5081         iti3=i+3
5082 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5083         call transpose2(EUg(1,1,i+1),e1t(1,1))
5084         call transpose2(Eug(1,1,i+2),e2t(1,1))
5085         call transpose2(Eug(1,1,i+3),e3t(1,1))
5086 !C Ematrix derivative in theta
5087         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5088         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5089         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5090
5091         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5092         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5093         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5094         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5095 !c       auxalary matrix of E i+1
5096         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5097         s1=scalar2(b1(1,iti2),auxvec(1))
5098 !c derivative of theta i+2 with constant i+3
5099         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5100 !c derivative of theta i+2 with constant i+2
5101         gs32=scalar2(b1(1,i+2),auxgvec(1))
5102 !c derivative of E matix in theta of i+1
5103         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5104
5105         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5106         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5107         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5108 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5109         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5110 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5111         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5112         s2=scalar2(b1(1,i+1),auxvec(1))
5113 !c derivative of theta i+1 with constant i+3
5114         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5115 !c derivative of theta i+2 with constant i+1
5116         gs21=scalar2(b1(1,i+1),auxgvec(1))
5117 !c derivative of theta i+3 with constant i+1
5118         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5119
5120         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5121         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5122 !c ae3gte2 is derivative over i+2
5123         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5124
5125         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5126         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5127 !c i+2
5128         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5129 !c i+3
5130         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5131
5132         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5133         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5134         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5135         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5136         if (shield_mode.eq.0) then
5137         fac_shield(i)=1.0
5138         fac_shield(j)=1.0
5139         endif
5140
5141         eello_turn4=eello_turn4-(s1+s2+s3) &
5142         *fac_shield(i)*fac_shield(j)       &
5143         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5144         eello_t4=-(s1+s2+s3)  &
5145           *fac_shield(i)*fac_shield(j)
5146 !C Now derivative over shield:
5147           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5148          (shield_mode.gt.0)) then
5149 !C          print *,i,j
5150
5151           do ilist=1,ishield_list(i)
5152            iresshield=shield_list(ilist,i)
5153            do k=1,3
5154            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5155 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5156            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5157                    rlocshield &
5158             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5159             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5160            +rlocshield
5161            enddo
5162           enddo
5163           do ilist=1,ishield_list(j)
5164            iresshield=shield_list(ilist,j)
5165            do k=1,3
5166 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5167            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5168            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5169                    rlocshield  &
5170            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5171            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5172                   +rlocshield
5173 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5174
5175            enddo
5176           enddo
5177           do k=1,3
5178             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5179                    grad_shield(k,i)*eello_t4/fac_shield(i)
5180             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5181                    grad_shield(k,j)*eello_t4/fac_shield(j)
5182             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5183                    grad_shield(k,i)*eello_t4/fac_shield(i)
5184             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5185                    grad_shield(k,j)*eello_t4/fac_shield(j)
5186 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5187            enddo
5188            endif
5189 #ifdef NEWCORR
5190         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5191                        -(gs13+gsE13+gsEE1)*wturn4&
5192        *fac_shield(i)*fac_shield(j)
5193         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5194                          -(gs23+gs21+gsEE2)*wturn4&
5195        *fac_shield(i)*fac_shield(j)
5196
5197         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5198                          -(gs32+gsE31+gsEE3)*wturn4&
5199        *fac_shield(i)*fac_shield(j)
5200
5201 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5202 !c     &   gs2
5203 #endif
5204         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5205            'eturn4',i,j,-(s1+s2+s3)
5206 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5207 !d     &    ' eello_turn4_num',8*eello_turn4_num
5208 ! Derivatives in gamma(i)
5209         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5210         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5211         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5212         s1=scalar2(b1(1,i+1),auxvec(1))
5213         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5214         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5215         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5216        *fac_shield(i)*fac_shield(j)  &
5217        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5218
5219 ! Derivatives in gamma(i+1)
5220         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5221         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5222         s2=scalar2(b1(1,iti1),auxvec(1))
5223         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5224         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5225         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5226         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5227        *fac_shield(i)*fac_shield(j)  &
5228        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5229
5230 ! Derivatives in gamma(i+2)
5231         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5232         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5233         s1=scalar2(b1(1,iti2),auxvec(1))
5234         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5235         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5236         s2=scalar2(b1(1,iti1),auxvec(1))
5237         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5238         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5239         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5240         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5241        *fac_shield(i)*fac_shield(j)  &
5242        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5243
5244 ! Cartesian derivatives
5245 ! Derivatives of this turn contributions in DC(i+2)
5246         if (j.lt.nres-1) then
5247           do l=1,3
5248             a_temp(1,1)=agg(l,1)
5249             a_temp(1,2)=agg(l,2)
5250             a_temp(2,1)=agg(l,3)
5251             a_temp(2,2)=agg(l,4)
5252             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5253             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5254             s1=scalar2(b1(1,iti2),auxvec(1))
5255             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5256             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5257             s2=scalar2(b1(1,iti1),auxvec(1))
5258             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5259             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5261             ggg(l)=-(s1+s2+s3)
5262             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5263        *fac_shield(i)*fac_shield(j)  &
5264        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5265
5266           enddo
5267         endif
5268 ! Remaining derivatives of this turn contribution
5269         do l=1,3
5270           a_temp(1,1)=aggi(l,1)
5271           a_temp(1,2)=aggi(l,2)
5272           a_temp(2,1)=aggi(l,3)
5273           a_temp(2,2)=aggi(l,4)
5274           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5275           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5276           s1=scalar2(b1(1,iti2),auxvec(1))
5277           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5278           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5279           s2=scalar2(b1(1,iti1),auxvec(1))
5280           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5281           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5282           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5283           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5284          *fac_shield(i)*fac_shield(j)  &
5285          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5286
5287
5288           a_temp(1,1)=aggi1(l,1)
5289           a_temp(1,2)=aggi1(l,2)
5290           a_temp(2,1)=aggi1(l,3)
5291           a_temp(2,2)=aggi1(l,4)
5292           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5293           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5294           s1=scalar2(b1(1,iti2),auxvec(1))
5295           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5296           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5297           s2=scalar2(b1(1,iti1),auxvec(1))
5298           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5299           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5300           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5301           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5302          *fac_shield(i)*fac_shield(j)  &
5303          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5304
5305
5306           a_temp(1,1)=aggj(l,1)
5307           a_temp(1,2)=aggj(l,2)
5308           a_temp(2,1)=aggj(l,3)
5309           a_temp(2,2)=aggj(l,4)
5310           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5311           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5312           s1=scalar2(b1(1,iti2),auxvec(1))
5313           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5314           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5315           s2=scalar2(b1(1,iti1),auxvec(1))
5316           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5317           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5318           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5319 !        if (j.lt.nres-1) then
5320           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5321          *fac_shield(i)*fac_shield(j)  &
5322          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5323 !        endif
5324
5325           a_temp(1,1)=aggj1(l,1)
5326           a_temp(1,2)=aggj1(l,2)
5327           a_temp(2,1)=aggj1(l,3)
5328           a_temp(2,2)=aggj1(l,4)
5329           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5330           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5331           s1=scalar2(b1(1,iti2),auxvec(1))
5332           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5333           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5334           s2=scalar2(b1(1,iti1),auxvec(1))
5335           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5336           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5337           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5338 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5339 !        if (j.lt.nres-1) then
5340 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5341           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5342          *fac_shield(i)*fac_shield(j)  &
5343          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5344 !            if (shield_mode.gt.0) then
5345 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5346 !            else
5347 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5348 !            endif
5349 !         endif
5350         enddo
5351          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5352           ssgradlipi*eello_t4/4.0d0*lipscale
5353          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5354           ssgradlipj*eello_t4/4.0d0*lipscale
5355          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5356           ssgradlipi*eello_t4/4.0d0*lipscale
5357          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5358           ssgradlipj*eello_t4/4.0d0*lipscale
5359
5360       return
5361       end subroutine eturn4
5362 !-----------------------------------------------------------------------------
5363       subroutine unormderiv(u,ugrad,unorm,ungrad)
5364 ! This subroutine computes the derivatives of a normalized vector u, given
5365 ! the derivatives computed without normalization conditions, ugrad. Returns
5366 ! ungrad.
5367 !      implicit none
5368       real(kind=8),dimension(3) :: u,vec
5369       real(kind=8),dimension(3,3) ::ugrad,ungrad
5370       real(kind=8) :: unorm      !,scalar
5371       integer :: i,j
5372 !      write (2,*) 'ugrad',ugrad
5373 !      write (2,*) 'u',u
5374       do i=1,3
5375         vec(i)=scalar(ugrad(1,i),u(1))
5376       enddo
5377 !      write (2,*) 'vec',vec
5378       do i=1,3
5379         do j=1,3
5380           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5381         enddo
5382       enddo
5383 !      write (2,*) 'ungrad',ungrad
5384       return
5385       end subroutine unormderiv
5386 !-----------------------------------------------------------------------------
5387       subroutine escp_soft_sphere(evdw2,evdw2_14)
5388 !
5389 ! This subroutine calculates the excluded-volume interaction energy between
5390 ! peptide-group centers and side chains and its gradient in virtual-bond and
5391 ! side-chain vectors.
5392 !
5393 !      implicit real*8 (a-h,o-z)
5394 !      include 'DIMENSIONS'
5395 !      include 'COMMON.GEO'
5396 !      include 'COMMON.VAR'
5397 !      include 'COMMON.LOCAL'
5398 !      include 'COMMON.CHAIN'
5399 !      include 'COMMON.DERIV'
5400 !      include 'COMMON.INTERACT'
5401 !      include 'COMMON.FFIELD'
5402 !      include 'COMMON.IOUNITS'
5403 !      include 'COMMON.CONTROL'
5404       real(kind=8),dimension(3) :: ggg
5405 !el local variables
5406       integer :: i,iint,j,k,iteli,itypj
5407       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5408                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5409
5410       evdw2=0.0D0
5411       evdw2_14=0.0d0
5412       r0_scp=4.5d0
5413 !d    print '(a)','Enter ESCP'
5414 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5415       do i=iatscp_s,iatscp_e
5416         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5417         iteli=itel(i)
5418         xi=0.5D0*(c(1,i)+c(1,i+1))
5419         yi=0.5D0*(c(2,i)+c(2,i+1))
5420         zi=0.5D0*(c(3,i)+c(3,i+1))
5421
5422         do iint=1,nscp_gr(i)
5423
5424         do j=iscpstart(i,iint),iscpend(i,iint)
5425           if (itype(j,1).eq.ntyp1) cycle
5426           itypj=iabs(itype(j,1))
5427 ! Uncomment following three lines for SC-p interactions
5428 !         xj=c(1,nres+j)-xi
5429 !         yj=c(2,nres+j)-yi
5430 !         zj=c(3,nres+j)-zi
5431 ! Uncomment following three lines for Ca-p interactions
5432           xj=c(1,j)-xi
5433           yj=c(2,j)-yi
5434           zj=c(3,j)-zi
5435           rij=xj*xj+yj*yj+zj*zj
5436           r0ij=r0_scp
5437           r0ijsq=r0ij*r0ij
5438           if (rij.lt.r0ijsq) then
5439             evdwij=0.25d0*(rij-r0ijsq)**2
5440             fac=rij-r0ijsq
5441           else
5442             evdwij=0.0d0
5443             fac=0.0d0
5444           endif
5445           evdw2=evdw2+evdwij
5446 !
5447 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5448 !
5449           ggg(1)=xj*fac
5450           ggg(2)=yj*fac
5451           ggg(3)=zj*fac
5452 !grad          if (j.lt.i) then
5453 !d          write (iout,*) 'j<i'
5454 ! Uncomment following three lines for SC-p interactions
5455 !           do k=1,3
5456 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5457 !           enddo
5458 !grad          else
5459 !d          write (iout,*) 'j>i'
5460 !grad            do k=1,3
5461 !grad              ggg(k)=-ggg(k)
5462 ! Uncomment following line for SC-p interactions
5463 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5464 !grad            enddo
5465 !grad          endif
5466 !grad          do k=1,3
5467 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5468 !grad          enddo
5469 !grad          kstart=min0(i+1,j)
5470 !grad          kend=max0(i-1,j-1)
5471 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5472 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5473 !grad          do k=kstart,kend
5474 !grad            do l=1,3
5475 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5476 !grad            enddo
5477 !grad          enddo
5478           do k=1,3
5479             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5480             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5481           enddo
5482         enddo
5483
5484         enddo ! iint
5485       enddo ! i
5486       return
5487       end subroutine escp_soft_sphere
5488 !-----------------------------------------------------------------------------
5489       subroutine escp(evdw2,evdw2_14)
5490 !
5491 ! This subroutine calculates the excluded-volume interaction energy between
5492 ! peptide-group centers and side chains and its gradient in virtual-bond and
5493 ! side-chain vectors.
5494 !
5495 !      implicit real*8 (a-h,o-z)
5496 !      include 'DIMENSIONS'
5497 !      include 'COMMON.GEO'
5498 !      include 'COMMON.VAR'
5499 !      include 'COMMON.LOCAL'
5500 !      include 'COMMON.CHAIN'
5501 !      include 'COMMON.DERIV'
5502 !      include 'COMMON.INTERACT'
5503 !      include 'COMMON.FFIELD'
5504 !      include 'COMMON.IOUNITS'
5505 !      include 'COMMON.CONTROL'
5506       real(kind=8),dimension(3) :: ggg
5507 !el local variables
5508       integer :: i,iint,j,k,iteli,itypj,subchap
5509       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5510                    e1,e2,evdwij,rij
5511       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5512                     dist_temp, dist_init
5513       integer xshift,yshift,zshift
5514
5515       evdw2=0.0D0
5516       evdw2_14=0.0d0
5517 !d    print '(a)','Enter ESCP'
5518 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5519       do i=iatscp_s,iatscp_e
5520         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5521         iteli=itel(i)
5522         xi=0.5D0*(c(1,i)+c(1,i+1))
5523         yi=0.5D0*(c(2,i)+c(2,i+1))
5524         zi=0.5D0*(c(3,i)+c(3,i+1))
5525           xi=mod(xi,boxxsize)
5526           if (xi.lt.0) xi=xi+boxxsize
5527           yi=mod(yi,boxysize)
5528           if (yi.lt.0) yi=yi+boxysize
5529           zi=mod(zi,boxzsize)
5530           if (zi.lt.0) zi=zi+boxzsize
5531
5532         do iint=1,nscp_gr(i)
5533
5534         do j=iscpstart(i,iint),iscpend(i,iint)
5535           itypj=iabs(itype(j,1))
5536           if (itypj.eq.ntyp1) cycle
5537 ! Uncomment following three lines for SC-p interactions
5538 !         xj=c(1,nres+j)-xi
5539 !         yj=c(2,nres+j)-yi
5540 !         zj=c(3,nres+j)-zi
5541 ! Uncomment following three lines for Ca-p interactions
5542 !          xj=c(1,j)-xi
5543 !          yj=c(2,j)-yi
5544 !          zj=c(3,j)-zi
5545           xj=c(1,j)
5546           yj=c(2,j)
5547           zj=c(3,j)
5548           xj=mod(xj,boxxsize)
5549           if (xj.lt.0) xj=xj+boxxsize
5550           yj=mod(yj,boxysize)
5551           if (yj.lt.0) yj=yj+boxysize
5552           zj=mod(zj,boxzsize)
5553           if (zj.lt.0) zj=zj+boxzsize
5554       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5555       xj_safe=xj
5556       yj_safe=yj
5557       zj_safe=zj
5558       subchap=0
5559       do xshift=-1,1
5560       do yshift=-1,1
5561       do zshift=-1,1
5562           xj=xj_safe+xshift*boxxsize
5563           yj=yj_safe+yshift*boxysize
5564           zj=zj_safe+zshift*boxzsize
5565           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5566           if(dist_temp.lt.dist_init) then
5567             dist_init=dist_temp
5568             xj_temp=xj
5569             yj_temp=yj
5570             zj_temp=zj
5571             subchap=1
5572           endif
5573        enddo
5574        enddo
5575        enddo
5576        if (subchap.eq.1) then
5577           xj=xj_temp-xi
5578           yj=yj_temp-yi
5579           zj=zj_temp-zi
5580        else
5581           xj=xj_safe-xi
5582           yj=yj_safe-yi
5583           zj=zj_safe-zi
5584        endif
5585
5586           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5587           rij=dsqrt(1.0d0/rrij)
5588             sss_ele_cut=sscale_ele(rij)
5589             sss_ele_grad=sscagrad_ele(rij)
5590 !            print *,sss_ele_cut,sss_ele_grad,&
5591 !            (rij),r_cut_ele,rlamb_ele
5592             if (sss_ele_cut.le.0.0) cycle
5593           fac=rrij**expon2
5594           e1=fac*fac*aad(itypj,iteli)
5595           e2=fac*bad(itypj,iteli)
5596           if (iabs(j-i) .le. 2) then
5597             e1=scal14*e1
5598             e2=scal14*e2
5599             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5600           endif
5601           evdwij=e1+e2
5602           evdw2=evdw2+evdwij*sss_ele_cut
5603 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5604 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5605           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5606              'evdw2',i,j,evdwij
5607 !
5608 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5609 !
5610           fac=-(evdwij+e1)*rrij*sss_ele_cut
5611           fac=fac+evdwij*sss_ele_grad/rij/expon
5612           ggg(1)=xj*fac
5613           ggg(2)=yj*fac
5614           ggg(3)=zj*fac
5615 !grad          if (j.lt.i) then
5616 !d          write (iout,*) 'j<i'
5617 ! Uncomment following three lines for SC-p interactions
5618 !           do k=1,3
5619 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5620 !           enddo
5621 !grad          else
5622 !d          write (iout,*) 'j>i'
5623 !grad            do k=1,3
5624 !grad              ggg(k)=-ggg(k)
5625 ! Uncomment following line for SC-p interactions
5626 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5627 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5628 !grad            enddo
5629 !grad          endif
5630 !grad          do k=1,3
5631 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5632 !grad          enddo
5633 !grad          kstart=min0(i+1,j)
5634 !grad          kend=max0(i-1,j-1)
5635 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5636 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5637 !grad          do k=kstart,kend
5638 !grad            do l=1,3
5639 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5640 !grad            enddo
5641 !grad          enddo
5642           do k=1,3
5643             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5644             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5645           enddo
5646         enddo
5647
5648         enddo ! iint
5649       enddo ! i
5650       do i=1,nct
5651         do j=1,3
5652           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5653           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5654           gradx_scp(j,i)=expon*gradx_scp(j,i)
5655         enddo
5656       enddo
5657 !******************************************************************************
5658 !
5659 !                              N O T E !!!
5660 !
5661 ! To save time the factor EXPON has been extracted from ALL components
5662 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5663 ! use!
5664 !
5665 !******************************************************************************
5666       return
5667       end subroutine escp
5668 !-----------------------------------------------------------------------------
5669       subroutine edis(ehpb)
5670 !
5671 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5672 !
5673 !      implicit real*8 (a-h,o-z)
5674 !      include 'DIMENSIONS'
5675 !      include 'COMMON.SBRIDGE'
5676 !      include 'COMMON.CHAIN'
5677 !      include 'COMMON.DERIV'
5678 !      include 'COMMON.VAR'
5679 !      include 'COMMON.INTERACT'
5680 !      include 'COMMON.IOUNITS'
5681       real(kind=8),dimension(3) :: ggg
5682 !el local variables
5683       integer :: i,j,ii,jj,iii,jjj,k
5684       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5685
5686       ehpb=0.0D0
5687 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5688 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5689       if (link_end.eq.0) return
5690       do i=link_start,link_end
5691 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5692 ! CA-CA distance used in regularization of structure.
5693         ii=ihpb(i)
5694         jj=jhpb(i)
5695 ! iii and jjj point to the residues for which the distance is assigned.
5696         if (ii.gt.nres) then
5697           iii=ii-nres
5698           jjj=jj-nres
5699         else
5700           iii=ii
5701           jjj=jj
5702         endif
5703 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5704 !     &    dhpb(i),dhpb1(i),forcon(i)
5705 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5706 !    distance and angle dependent SS bond potential.
5707 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5708 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5709         if (.not.dyn_ss .and. i.le.nss) then
5710 ! 15/02/13 CC dynamic SSbond - additional check
5711          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5712         iabs(itype(jjj,1)).eq.1) then
5713           call ssbond_ene(iii,jjj,eij)
5714           ehpb=ehpb+2*eij
5715 !d          write (iout,*) "eij",eij
5716          endif
5717         else if (ii.gt.nres .and. jj.gt.nres) then
5718 !c Restraints from contact prediction
5719           dd=dist(ii,jj)
5720           if (constr_dist.eq.11) then
5721             ehpb=ehpb+fordepth(i)**4.0d0 &
5722                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5723             fac=fordepth(i)**4.0d0 &
5724                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5725           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5726             ehpb,fordepth(i),dd
5727            else
5728           if (dhpb1(i).gt.0.0d0) then
5729             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5730             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5731 !c            write (iout,*) "beta nmr",
5732 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5733           else
5734             dd=dist(ii,jj)
5735             rdis=dd-dhpb(i)
5736 !C Get the force constant corresponding to this distance.
5737             waga=forcon(i)
5738 !C Calculate the contribution to energy.
5739             ehpb=ehpb+waga*rdis*rdis
5740 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5741 !C
5742 !C Evaluate gradient.
5743 !C
5744             fac=waga*rdis/dd
5745           endif
5746           endif
5747           do j=1,3
5748             ggg(j)=fac*(c(j,jj)-c(j,ii))
5749           enddo
5750           do j=1,3
5751             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5752             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5753           enddo
5754           do k=1,3
5755             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5756             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5757           enddo
5758         else
5759           dd=dist(ii,jj)
5760           if (constr_dist.eq.11) then
5761             ehpb=ehpb+fordepth(i)**4.0d0 &
5762                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5763             fac=fordepth(i)**4.0d0 &
5764                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5765           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5766          ehpb,fordepth(i),dd
5767            else
5768           if (dhpb1(i).gt.0.0d0) then
5769             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5770             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5771 !c            write (iout,*) "alph nmr",
5772 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5773           else
5774             rdis=dd-dhpb(i)
5775 !C Get the force constant corresponding to this distance.
5776             waga=forcon(i)
5777 !C Calculate the contribution to energy.
5778             ehpb=ehpb+waga*rdis*rdis
5779 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5780 !C
5781 !C Evaluate gradient.
5782 !C
5783             fac=waga*rdis/dd
5784           endif
5785           endif
5786
5787             do j=1,3
5788               ggg(j)=fac*(c(j,jj)-c(j,ii))
5789             enddo
5790 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5791 !C If this is a SC-SC distance, we need to calculate the contributions to the
5792 !C Cartesian gradient in the SC vectors (ghpbx).
5793           if (iii.lt.ii) then
5794           do j=1,3
5795             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5796             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5797           enddo
5798           endif
5799 !cgrad        do j=iii,jjj-1
5800 !cgrad          do k=1,3
5801 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5802 !cgrad          enddo
5803 !cgrad        enddo
5804           do k=1,3
5805             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5806             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5807           enddo
5808         endif
5809       enddo
5810       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5811
5812       return
5813       end subroutine edis
5814 !-----------------------------------------------------------------------------
5815       subroutine ssbond_ene(i,j,eij)
5816 !
5817 ! Calculate the distance and angle dependent SS-bond potential energy
5818 ! using a free-energy function derived based on RHF/6-31G** ab initio
5819 ! calculations of diethyl disulfide.
5820 !
5821 ! A. Liwo and U. Kozlowska, 11/24/03
5822 !
5823 !      implicit real*8 (a-h,o-z)
5824 !      include 'DIMENSIONS'
5825 !      include 'COMMON.SBRIDGE'
5826 !      include 'COMMON.CHAIN'
5827 !      include 'COMMON.DERIV'
5828 !      include 'COMMON.LOCAL'
5829 !      include 'COMMON.INTERACT'
5830 !      include 'COMMON.VAR'
5831 !      include 'COMMON.IOUNITS'
5832       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5833 !el local variables
5834       integer :: i,j,itypi,itypj,k
5835       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5836                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5837                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5838                    cosphi,ggk
5839
5840       itypi=iabs(itype(i,1))
5841       xi=c(1,nres+i)
5842       yi=c(2,nres+i)
5843       zi=c(3,nres+i)
5844       dxi=dc_norm(1,nres+i)
5845       dyi=dc_norm(2,nres+i)
5846       dzi=dc_norm(3,nres+i)
5847 !      dsci_inv=dsc_inv(itypi)
5848       dsci_inv=vbld_inv(nres+i)
5849       itypj=iabs(itype(j,1))
5850 !      dscj_inv=dsc_inv(itypj)
5851       dscj_inv=vbld_inv(nres+j)
5852       xj=c(1,nres+j)-xi
5853       yj=c(2,nres+j)-yi
5854       zj=c(3,nres+j)-zi
5855       dxj=dc_norm(1,nres+j)
5856       dyj=dc_norm(2,nres+j)
5857       dzj=dc_norm(3,nres+j)
5858       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5859       rij=dsqrt(rrij)
5860       erij(1)=xj*rij
5861       erij(2)=yj*rij
5862       erij(3)=zj*rij
5863       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5864       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5865       om12=dxi*dxj+dyi*dyj+dzi*dzj
5866       do k=1,3
5867         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5868         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5869       enddo
5870       rij=1.0d0/rij
5871       deltad=rij-d0cm
5872       deltat1=1.0d0-om1
5873       deltat2=1.0d0+om2
5874       deltat12=om2-om1+2.0d0
5875       cosphi=om12-om1*om2
5876       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5877         +akct*deltad*deltat12 &
5878         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5879 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5880 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5881 !     &  " deltat12",deltat12," eij",eij
5882       ed=2*akcm*deltad+akct*deltat12
5883       pom1=akct*deltad
5884       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5885       eom1=-2*akth*deltat1-pom1-om2*pom2
5886       eom2= 2*akth*deltat2+pom1-om1*pom2
5887       eom12=pom2
5888       do k=1,3
5889         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5890         ghpbx(k,i)=ghpbx(k,i)-ggk &
5891                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5892                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5893         ghpbx(k,j)=ghpbx(k,j)+ggk &
5894                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5895                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5896         ghpbc(k,i)=ghpbc(k,i)-ggk
5897         ghpbc(k,j)=ghpbc(k,j)+ggk
5898       enddo
5899 !
5900 ! Calculate the components of the gradient in DC and X
5901 !
5902 !grad      do k=i,j-1
5903 !grad        do l=1,3
5904 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5905 !grad        enddo
5906 !grad      enddo
5907       return
5908       end subroutine ssbond_ene
5909 !-----------------------------------------------------------------------------
5910       subroutine ebond(estr)
5911 !
5912 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5913 !
5914 !      implicit real*8 (a-h,o-z)
5915 !      include 'DIMENSIONS'
5916 !      include 'COMMON.LOCAL'
5917 !      include 'COMMON.GEO'
5918 !      include 'COMMON.INTERACT'
5919 !      include 'COMMON.DERIV'
5920 !      include 'COMMON.VAR'
5921 !      include 'COMMON.CHAIN'
5922 !      include 'COMMON.IOUNITS'
5923 !      include 'COMMON.NAMES'
5924 !      include 'COMMON.FFIELD'
5925 !      include 'COMMON.CONTROL'
5926 !      include 'COMMON.SETUP'
5927       real(kind=8),dimension(3) :: u,ud
5928 !el local variables
5929       integer :: i,j,iti,nbi,k
5930       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5931                    uprod1,uprod2
5932
5933       estr=0.0d0
5934       estr1=0.0d0
5935 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5936 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5937
5938       do i=ibondp_start,ibondp_end
5939         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5940         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5941 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5942 !C          do j=1,3
5943 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5944 !C            *dc(j,i-1)/vbld(i)
5945 !C          enddo
5946 !C          if (energy_dec) write(iout,*) &
5947 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5948         diff = vbld(i)-vbldpDUM
5949         else
5950         diff = vbld(i)-vbldp0
5951         endif
5952         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5953            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5954         estr=estr+diff*diff
5955         do j=1,3
5956           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5957         enddo
5958 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5959 !        endif
5960       enddo
5961       estr=0.5d0*AKP*estr+estr1
5962 !      print *,"estr_bb",estr,AKP
5963 !
5964 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5965 !
5966       do i=ibond_start,ibond_end
5967         iti=iabs(itype(i,1))
5968         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5969         if (iti.ne.10 .and. iti.ne.ntyp1) then
5970           nbi=nbondterm(iti)
5971           if (nbi.eq.1) then
5972             diff=vbld(i+nres)-vbldsc0(1,iti)
5973             if (energy_dec) write (iout,*) &
5974             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5975             AKSC(1,iti),AKSC(1,iti)*diff*diff
5976             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5977 !            print *,"estr_sc",estr
5978             do j=1,3
5979               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5980             enddo
5981           else
5982             do j=1,nbi
5983               diff=vbld(i+nres)-vbldsc0(j,iti)
5984               ud(j)=aksc(j,iti)*diff
5985               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5986             enddo
5987             uprod=u(1)
5988             do j=2,nbi
5989               uprod=uprod*u(j)
5990             enddo
5991             usum=0.0d0
5992             usumsqder=0.0d0
5993             do j=1,nbi
5994               uprod1=1.0d0
5995               uprod2=1.0d0
5996               do k=1,nbi
5997                 if (k.ne.j) then
5998                   uprod1=uprod1*u(k)
5999                   uprod2=uprod2*u(k)*u(k)
6000                 endif
6001               enddo
6002               usum=usum+uprod1
6003               usumsqder=usumsqder+ud(j)*uprod2
6004             enddo
6005             estr=estr+uprod/usum
6006 !            print *,"estr_sc",estr,i
6007
6008              if (energy_dec) write (iout,*) &
6009             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6010             AKSC(1,iti),uprod/usum
6011             do j=1,3
6012              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6013             enddo
6014           endif
6015         endif
6016       enddo
6017       return
6018       end subroutine ebond
6019 #ifdef CRYST_THETA
6020 !-----------------------------------------------------------------------------
6021       subroutine ebend(etheta)
6022 !
6023 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6024 ! angles gamma and its derivatives in consecutive thetas and gammas.
6025 !
6026       use comm_calcthet
6027 !      implicit real*8 (a-h,o-z)
6028 !      include 'DIMENSIONS'
6029 !      include 'COMMON.LOCAL'
6030 !      include 'COMMON.GEO'
6031 !      include 'COMMON.INTERACT'
6032 !      include 'COMMON.DERIV'
6033 !      include 'COMMON.VAR'
6034 !      include 'COMMON.CHAIN'
6035 !      include 'COMMON.IOUNITS'
6036 !      include 'COMMON.NAMES'
6037 !      include 'COMMON.FFIELD'
6038 !      include 'COMMON.CONTROL'
6039 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6040 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6041 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6042 !el      integer :: it
6043 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6044 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6045 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6046 !el local variables
6047       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6048        ichir21,ichir22
6049       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6050        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6051        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6052       real(kind=8),dimension(2) :: y,z
6053
6054       delta=0.02d0*pi
6055 !      time11=dexp(-2*time)
6056 !      time12=1.0d0
6057       etheta=0.0D0
6058 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6059       do i=ithet_start,ithet_end
6060         if (itype(i-1,1).eq.ntyp1) cycle
6061 ! Zero the energy function and its derivative at 0 or pi.
6062         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6063         it=itype(i-1,1)
6064         ichir1=isign(1,itype(i-2,1))
6065         ichir2=isign(1,itype(i,1))
6066          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6067          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6068          if (itype(i-1,1).eq.10) then
6069           itype1=isign(10,itype(i-2,1))
6070           ichir11=isign(1,itype(i-2,1))
6071           ichir12=isign(1,itype(i-2,1))
6072           itype2=isign(10,itype(i,1))
6073           ichir21=isign(1,itype(i,1))
6074           ichir22=isign(1,itype(i,1))
6075          endif
6076
6077         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6078 #ifdef OSF
6079           phii=phi(i)
6080           if (phii.ne.phii) phii=150.0
6081 #else
6082           phii=phi(i)
6083 #endif
6084           y(1)=dcos(phii)
6085           y(2)=dsin(phii)
6086         else
6087           y(1)=0.0D0
6088           y(2)=0.0D0
6089         endif
6090         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6091 #ifdef OSF
6092           phii1=phi(i+1)
6093           if (phii1.ne.phii1) phii1=150.0
6094           phii1=pinorm(phii1)
6095           z(1)=cos(phii1)
6096 #else
6097           phii1=phi(i+1)
6098           z(1)=dcos(phii1)
6099 #endif
6100           z(2)=dsin(phii1)
6101         else
6102           z(1)=0.0D0
6103           z(2)=0.0D0
6104         endif
6105 ! Calculate the "mean" value of theta from the part of the distribution
6106 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6107 ! In following comments this theta will be referred to as t_c.
6108         thet_pred_mean=0.0d0
6109         do k=1,2
6110             athetk=athet(k,it,ichir1,ichir2)
6111             bthetk=bthet(k,it,ichir1,ichir2)
6112           if (it.eq.10) then
6113              athetk=athet(k,itype1,ichir11,ichir12)
6114              bthetk=bthet(k,itype2,ichir21,ichir22)
6115           endif
6116          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6117         enddo
6118         dthett=thet_pred_mean*ssd
6119         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6120 ! Derivatives of the "mean" values in gamma1 and gamma2.
6121         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6122                +athet(2,it,ichir1,ichir2)*y(1))*ss
6123         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6124                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6125          if (it.eq.10) then
6126         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6127              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6128         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6129                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6130          endif
6131         if (theta(i).gt.pi-delta) then
6132           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6133                E_tc0)
6134           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6135           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6136           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6137               E_theta)
6138           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6139               E_tc)
6140         else if (theta(i).lt.delta) then
6141           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6142           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6143           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6144               E_theta)
6145           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6146           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6147               E_tc)
6148         else
6149           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6150               E_theta,E_tc)
6151         endif
6152         etheta=etheta+ethetai
6153         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6154             'ebend',i,ethetai
6155         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6156         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6157         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6158       enddo
6159 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6160
6161 ! Ufff.... We've done all this!!!
6162       return
6163       end subroutine ebend
6164 !-----------------------------------------------------------------------------
6165       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6166
6167       use comm_calcthet
6168 !      implicit real*8 (a-h,o-z)
6169 !      include 'DIMENSIONS'
6170 !      include 'COMMON.LOCAL'
6171 !      include 'COMMON.IOUNITS'
6172 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6173 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6174 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6175       integer :: i,j,k
6176       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6177 !el      integer :: it
6178 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6179 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6180 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6181 !el local variables
6182       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6183        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6184
6185 ! Calculate the contributions to both Gaussian lobes.
6186 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6187 ! The "polynomial part" of the "standard deviation" of this part of
6188 ! the distribution.
6189         sig=polthet(3,it)
6190         do j=2,0,-1
6191           sig=sig*thet_pred_mean+polthet(j,it)
6192         enddo
6193 ! Derivative of the "interior part" of the "standard deviation of the"
6194 ! gamma-dependent Gaussian lobe in t_c.
6195         sigtc=3*polthet(3,it)
6196         do j=2,1,-1
6197           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6198         enddo
6199         sigtc=sig*sigtc
6200 ! Set the parameters of both Gaussian lobes of the distribution.
6201 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6202         fac=sig*sig+sigc0(it)
6203         sigcsq=fac+fac
6204         sigc=1.0D0/sigcsq
6205 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6206         sigsqtc=-4.0D0*sigcsq*sigtc
6207 !       print *,i,sig,sigtc,sigsqtc
6208 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6209         sigtc=-sigtc/(fac*fac)
6210 ! Following variable is sigma(t_c)**(-2)
6211         sigcsq=sigcsq*sigcsq
6212         sig0i=sig0(it)
6213         sig0inv=1.0D0/sig0i**2
6214         delthec=thetai-thet_pred_mean
6215         delthe0=thetai-theta0i
6216         term1=-0.5D0*sigcsq*delthec*delthec
6217         term2=-0.5D0*sig0inv*delthe0*delthe0
6218 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6219 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6220 ! to the energy (this being the log of the distribution) at the end of energy
6221 ! term evaluation for this virtual-bond angle.
6222         if (term1.gt.term2) then
6223           termm=term1
6224           term2=dexp(term2-termm)
6225           term1=1.0d0
6226         else
6227           termm=term2
6228           term1=dexp(term1-termm)
6229           term2=1.0d0
6230         endif
6231 ! The ratio between the gamma-independent and gamma-dependent lobes of
6232 ! the distribution is a Gaussian function of thet_pred_mean too.
6233         diffak=gthet(2,it)-thet_pred_mean
6234         ratak=diffak/gthet(3,it)**2
6235         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6236 ! Let's differentiate it in thet_pred_mean NOW.
6237         aktc=ak*ratak
6238 ! Now put together the distribution terms to make complete distribution.
6239         termexp=term1+ak*term2
6240         termpre=sigc+ak*sig0i
6241 ! Contribution of the bending energy from this theta is just the -log of
6242 ! the sum of the contributions from the two lobes and the pre-exponential
6243 ! factor. Simple enough, isn't it?
6244         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6245 ! NOW the derivatives!!!
6246 ! 6/6/97 Take into account the deformation.
6247         E_theta=(delthec*sigcsq*term1 &
6248              +ak*delthe0*sig0inv*term2)/termexp
6249         E_tc=((sigtc+aktc*sig0i)/termpre &
6250             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6251              aktc*term2)/termexp)
6252       return
6253       end subroutine theteng
6254 #else
6255 !-----------------------------------------------------------------------------
6256       subroutine ebend(etheta)
6257 !
6258 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6259 ! angles gamma and its derivatives in consecutive thetas and gammas.
6260 ! ab initio-derived potentials from
6261 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6262 !
6263 !      implicit real*8 (a-h,o-z)
6264 !      include 'DIMENSIONS'
6265 !      include 'COMMON.LOCAL'
6266 !      include 'COMMON.GEO'
6267 !      include 'COMMON.INTERACT'
6268 !      include 'COMMON.DERIV'
6269 !      include 'COMMON.VAR'
6270 !      include 'COMMON.CHAIN'
6271 !      include 'COMMON.IOUNITS'
6272 !      include 'COMMON.NAMES'
6273 !      include 'COMMON.FFIELD'
6274 !      include 'COMMON.CONTROL'
6275       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6276       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6277       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6278       logical :: lprn=.false., lprn1=.false.
6279 !el local variables
6280       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6281       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6282       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6283 ! local variables for constrains
6284       real(kind=8) :: difi,thetiii
6285        integer itheta
6286 !      write(iout,*) "in ebend",ithet_start,ithet_end
6287       call flush(iout)
6288       etheta=0.0D0
6289       do i=ithet_start,ithet_end
6290         if (itype(i-1,1).eq.ntyp1) cycle
6291         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6292         if (iabs(itype(i+1,1)).eq.20) iblock=2
6293         if (iabs(itype(i+1,1)).ne.20) iblock=1
6294         dethetai=0.0d0
6295         dephii=0.0d0
6296         dephii1=0.0d0
6297         theti2=0.5d0*theta(i)
6298         ityp2=ithetyp((itype(i-1,1)))
6299         do k=1,nntheterm
6300           coskt(k)=dcos(k*theti2)
6301           sinkt(k)=dsin(k*theti2)
6302         enddo
6303         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6304 #ifdef OSF
6305           phii=phi(i)
6306           if (phii.ne.phii) phii=150.0
6307 #else
6308           phii=phi(i)
6309 #endif
6310           ityp1=ithetyp((itype(i-2,1)))
6311 ! propagation of chirality for glycine type
6312           do k=1,nsingle
6313             cosph1(k)=dcos(k*phii)
6314             sinph1(k)=dsin(k*phii)
6315           enddo
6316         else
6317           phii=0.0d0
6318           ityp1=ithetyp(itype(i-2,1))
6319           do k=1,nsingle
6320             cosph1(k)=0.0d0
6321             sinph1(k)=0.0d0
6322           enddo
6323         endif
6324         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6325 #ifdef OSF
6326           phii1=phi(i+1)
6327           if (phii1.ne.phii1) phii1=150.0
6328           phii1=pinorm(phii1)
6329 #else
6330           phii1=phi(i+1)
6331 #endif
6332           ityp3=ithetyp((itype(i,1)))
6333           do k=1,nsingle
6334             cosph2(k)=dcos(k*phii1)
6335             sinph2(k)=dsin(k*phii1)
6336           enddo
6337         else
6338           phii1=0.0d0
6339           ityp3=ithetyp(itype(i,1))
6340           do k=1,nsingle
6341             cosph2(k)=0.0d0
6342             sinph2(k)=0.0d0
6343           enddo
6344         endif
6345         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6346         do k=1,ndouble
6347           do l=1,k-1
6348             ccl=cosph1(l)*cosph2(k-l)
6349             ssl=sinph1(l)*sinph2(k-l)
6350             scl=sinph1(l)*cosph2(k-l)
6351             csl=cosph1(l)*sinph2(k-l)
6352             cosph1ph2(l,k)=ccl-ssl
6353             cosph1ph2(k,l)=ccl+ssl
6354             sinph1ph2(l,k)=scl+csl
6355             sinph1ph2(k,l)=scl-csl
6356           enddo
6357         enddo
6358         if (lprn) then
6359         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6360           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6361         write (iout,*) "coskt and sinkt"
6362         do k=1,nntheterm
6363           write (iout,*) k,coskt(k),sinkt(k)
6364         enddo
6365         endif
6366         do k=1,ntheterm
6367           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6368           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6369             *coskt(k)
6370           if (lprn) &
6371           write (iout,*) "k",k,&
6372            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6373            " ethetai",ethetai
6374         enddo
6375         if (lprn) then
6376         write (iout,*) "cosph and sinph"
6377         do k=1,nsingle
6378           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6379         enddo
6380         write (iout,*) "cosph1ph2 and sinph2ph2"
6381         do k=2,ndouble
6382           do l=1,k-1
6383             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6384                sinph1ph2(l,k),sinph1ph2(k,l)
6385           enddo
6386         enddo
6387         write(iout,*) "ethetai",ethetai
6388         endif
6389         do m=1,ntheterm2
6390           do k=1,nsingle
6391             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6392                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6393                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6394                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6395             ethetai=ethetai+sinkt(m)*aux
6396             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6397             dephii=dephii+k*sinkt(m)* &
6398                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6399                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6400             dephii1=dephii1+k*sinkt(m)* &
6401                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6402                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6403             if (lprn) &
6404             write (iout,*) "m",m," k",k," bbthet", &
6405                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6406                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6407                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6408                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6409           enddo
6410         enddo
6411         if (lprn) &
6412         write(iout,*) "ethetai",ethetai
6413         do m=1,ntheterm3
6414           do k=2,ndouble
6415             do l=1,k-1
6416               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6417                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6418                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6419                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6420               ethetai=ethetai+sinkt(m)*aux
6421               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6422               dephii=dephii+l*sinkt(m)* &
6423                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6424                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6425                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6426                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6427               dephii1=dephii1+(k-l)*sinkt(m)* &
6428                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6429                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6430                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6431                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6432               if (lprn) then
6433               write (iout,*) "m",m," k",k," l",l," ffthet",&
6434                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6435                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6436                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6437                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6438                   " ethetai",ethetai
6439               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6440                   cosph1ph2(k,l)*sinkt(m),&
6441                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6442               endif
6443             enddo
6444           enddo
6445         enddo
6446 10      continue
6447 !        lprn1=.true.
6448         if (lprn1) &
6449           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6450          i,theta(i)*rad2deg,phii*rad2deg,&
6451          phii1*rad2deg,ethetai
6452 !        lprn1=.false.
6453         etheta=etheta+ethetai
6454         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6455                                     'ebend',i,ethetai
6456         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6457         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6458         gloc(nphi+i-2,icg)=wang*dethetai
6459       enddo
6460 !-----------thete constrains
6461 !      if (tor_mode.ne.2) then
6462
6463       return
6464       end subroutine ebend
6465 #endif
6466 #ifdef CRYST_SC
6467 !-----------------------------------------------------------------------------
6468       subroutine esc(escloc)
6469 ! Calculate the local energy of a side chain and its derivatives in the
6470 ! corresponding virtual-bond valence angles THETA and the spherical angles
6471 ! ALPHA and OMEGA.
6472 !
6473       use comm_sccalc
6474 !      implicit real*8 (a-h,o-z)
6475 !      include 'DIMENSIONS'
6476 !      include 'COMMON.GEO'
6477 !      include 'COMMON.LOCAL'
6478 !      include 'COMMON.VAR'
6479 !      include 'COMMON.INTERACT'
6480 !      include 'COMMON.DERIV'
6481 !      include 'COMMON.CHAIN'
6482 !      include 'COMMON.IOUNITS'
6483 !      include 'COMMON.NAMES'
6484 !      include 'COMMON.FFIELD'
6485 !      include 'COMMON.CONTROL'
6486       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6487          ddersc0,ddummy,xtemp,temp
6488 !el      real(kind=8) :: time11,time12,time112,theti
6489       real(kind=8) :: escloc,delta
6490 !el      integer :: it,nlobit
6491 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6492 !el local variables
6493       integer :: i,k
6494       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6495        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6496       delta=0.02d0*pi
6497       escloc=0.0D0
6498 !     write (iout,'(a)') 'ESC'
6499       do i=loc_start,loc_end
6500         it=itype(i,1)
6501         if (it.eq.ntyp1) cycle
6502         if (it.eq.10) goto 1
6503         nlobit=nlob(iabs(it))
6504 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6505 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6506         theti=theta(i+1)-pipol
6507         x(1)=dtan(theti)
6508         x(2)=alph(i)
6509         x(3)=omeg(i)
6510
6511         if (x(2).gt.pi-delta) then
6512           xtemp(1)=x(1)
6513           xtemp(2)=pi-delta
6514           xtemp(3)=x(3)
6515           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6516           xtemp(2)=pi
6517           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6518           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6519               escloci,dersc(2))
6520           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6521               ddersc0(1),dersc(1))
6522           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6523               ddersc0(3),dersc(3))
6524           xtemp(2)=pi-delta
6525           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6526           xtemp(2)=pi
6527           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6528           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6529                   dersc0(2),esclocbi,dersc02)
6530           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6531                   dersc12,dersc01)
6532           call splinthet(x(2),0.5d0*delta,ss,ssd)
6533           dersc0(1)=dersc01
6534           dersc0(2)=dersc02
6535           dersc0(3)=0.0d0
6536           do k=1,3
6537             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6538           enddo
6539           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6540 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6541 !    &             esclocbi,ss,ssd
6542           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6543 !         escloci=esclocbi
6544 !         write (iout,*) escloci
6545         else if (x(2).lt.delta) then
6546           xtemp(1)=x(1)
6547           xtemp(2)=delta
6548           xtemp(3)=x(3)
6549           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6550           xtemp(2)=0.0d0
6551           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6552           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6553               escloci,dersc(2))
6554           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6555               ddersc0(1),dersc(1))
6556           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6557               ddersc0(3),dersc(3))
6558           xtemp(2)=delta
6559           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6560           xtemp(2)=0.0d0
6561           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6562           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6563                   dersc0(2),esclocbi,dersc02)
6564           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6565                   dersc12,dersc01)
6566           dersc0(1)=dersc01
6567           dersc0(2)=dersc02
6568           dersc0(3)=0.0d0
6569           call splinthet(x(2),0.5d0*delta,ss,ssd)
6570           do k=1,3
6571             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6572           enddo
6573           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6574 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6575 !    &             esclocbi,ss,ssd
6576           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6577 !         write (iout,*) escloci
6578         else
6579           call enesc(x,escloci,dersc,ddummy,.false.)
6580         endif
6581
6582         escloc=escloc+escloci
6583         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6584            'escloc',i,escloci
6585 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6586
6587         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6588          wscloc*dersc(1)
6589         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6590         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6591     1   continue
6592       enddo
6593       return
6594       end subroutine esc
6595 !-----------------------------------------------------------------------------
6596       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6597
6598       use comm_sccalc
6599 !      implicit real*8 (a-h,o-z)
6600 !      include 'DIMENSIONS'
6601 !      include 'COMMON.GEO'
6602 !      include 'COMMON.LOCAL'
6603 !      include 'COMMON.IOUNITS'
6604 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6605       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6606       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6607       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6608       real(kind=8) :: escloci
6609       logical :: mixed
6610 !el local variables
6611       integer :: j,iii,l,k !el,it,nlobit
6612       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6613 !el       time11,time12,time112
6614 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6615         escloc_i=0.0D0
6616         do j=1,3
6617           dersc(j)=0.0D0
6618           if (mixed) ddersc(j)=0.0d0
6619         enddo
6620         x3=x(3)
6621
6622 ! Because of periodicity of the dependence of the SC energy in omega we have
6623 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6624 ! To avoid underflows, first compute & store the exponents.
6625
6626         do iii=-1,1
6627
6628           x(3)=x3+iii*dwapi
6629
6630           do j=1,nlobit
6631             do k=1,3
6632               z(k)=x(k)-censc(k,j,it)
6633             enddo
6634             do k=1,3
6635               Axk=0.0D0
6636               do l=1,3
6637                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6638               enddo
6639               Ax(k,j,iii)=Axk
6640             enddo
6641             expfac=0.0D0
6642             do k=1,3
6643               expfac=expfac+Ax(k,j,iii)*z(k)
6644             enddo
6645             contr(j,iii)=expfac
6646           enddo ! j
6647
6648         enddo ! iii
6649
6650         x(3)=x3
6651 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6652 ! subsequent NaNs and INFs in energy calculation.
6653 ! Find the largest exponent
6654         emin=contr(1,-1)
6655         do iii=-1,1
6656           do j=1,nlobit
6657             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6658           enddo
6659         enddo
6660         emin=0.5D0*emin
6661 !d      print *,'it=',it,' emin=',emin
6662
6663 ! Compute the contribution to SC energy and derivatives
6664         do iii=-1,1
6665
6666           do j=1,nlobit
6667 #ifdef OSF
6668             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6669             if(adexp.ne.adexp) adexp=1.0
6670             expfac=dexp(adexp)
6671 #else
6672             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6673 #endif
6674 !d          print *,'j=',j,' expfac=',expfac
6675             escloc_i=escloc_i+expfac
6676             do k=1,3
6677               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6678             enddo
6679             if (mixed) then
6680               do k=1,3,2
6681                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6682                   +gaussc(k,2,j,it))*expfac
6683               enddo
6684             endif
6685           enddo
6686
6687         enddo ! iii
6688
6689         dersc(1)=dersc(1)/cos(theti)**2
6690         ddersc(1)=ddersc(1)/cos(theti)**2
6691         ddersc(3)=ddersc(3)
6692
6693         escloci=-(dlog(escloc_i)-emin)
6694         do j=1,3
6695           dersc(j)=dersc(j)/escloc_i
6696         enddo
6697         if (mixed) then
6698           do j=1,3,2
6699             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6700           enddo
6701         endif
6702       return
6703       end subroutine enesc
6704 !-----------------------------------------------------------------------------
6705       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6706
6707       use comm_sccalc
6708 !      implicit real*8 (a-h,o-z)
6709 !      include 'DIMENSIONS'
6710 !      include 'COMMON.GEO'
6711 !      include 'COMMON.LOCAL'
6712 !      include 'COMMON.IOUNITS'
6713 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6714       real(kind=8),dimension(3) :: x,z,dersc
6715       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6716       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6717       real(kind=8) :: escloci,dersc12,emin
6718       logical :: mixed
6719 !el local varables
6720       integer :: j,k,l !el,it,nlobit
6721       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6722
6723       escloc_i=0.0D0
6724
6725       do j=1,3
6726         dersc(j)=0.0D0
6727       enddo
6728
6729       do j=1,nlobit
6730         do k=1,2
6731           z(k)=x(k)-censc(k,j,it)
6732         enddo
6733         z(3)=dwapi
6734         do k=1,3
6735           Axk=0.0D0
6736           do l=1,3
6737             Axk=Axk+gaussc(l,k,j,it)*z(l)
6738           enddo
6739           Ax(k,j)=Axk
6740         enddo
6741         expfac=0.0D0
6742         do k=1,3
6743           expfac=expfac+Ax(k,j)*z(k)
6744         enddo
6745         contr(j)=expfac
6746       enddo ! j
6747
6748 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6749 ! subsequent NaNs and INFs in energy calculation.
6750 ! Find the largest exponent
6751       emin=contr(1)
6752       do j=1,nlobit
6753         if (emin.gt.contr(j)) emin=contr(j)
6754       enddo
6755       emin=0.5D0*emin
6756
6757 ! Compute the contribution to SC energy and derivatives
6758
6759       dersc12=0.0d0
6760       do j=1,nlobit
6761         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6762         escloc_i=escloc_i+expfac
6763         do k=1,2
6764           dersc(k)=dersc(k)+Ax(k,j)*expfac
6765         enddo
6766         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6767                   +gaussc(1,2,j,it))*expfac
6768         dersc(3)=0.0d0
6769       enddo
6770
6771       dersc(1)=dersc(1)/cos(theti)**2
6772       dersc12=dersc12/cos(theti)**2
6773       escloci=-(dlog(escloc_i)-emin)
6774       do j=1,2
6775         dersc(j)=dersc(j)/escloc_i
6776       enddo
6777       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6778       return
6779       end subroutine enesc_bound
6780 #else
6781 !-----------------------------------------------------------------------------
6782       subroutine esc(escloc)
6783 ! Calculate the local energy of a side chain and its derivatives in the
6784 ! corresponding virtual-bond valence angles THETA and the spherical angles
6785 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6786 ! added by Urszula Kozlowska. 07/11/2007
6787 !
6788       use comm_sccalc
6789 !      implicit real*8 (a-h,o-z)
6790 !      include 'DIMENSIONS'
6791 !      include 'COMMON.GEO'
6792 !      include 'COMMON.LOCAL'
6793 !      include 'COMMON.VAR'
6794 !      include 'COMMON.SCROT'
6795 !      include 'COMMON.INTERACT'
6796 !      include 'COMMON.DERIV'
6797 !      include 'COMMON.CHAIN'
6798 !      include 'COMMON.IOUNITS'
6799 !      include 'COMMON.NAMES'
6800 !      include 'COMMON.FFIELD'
6801 !      include 'COMMON.CONTROL'
6802 !      include 'COMMON.VECTORS'
6803       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6804       real(kind=8),dimension(65) :: x
6805       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6806          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6807       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6808       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6809          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6810 !el local variables
6811       integer :: i,j,k !el,it,nlobit
6812       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6813 !el      real(kind=8) :: time11,time12,time112,theti
6814 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6815       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6816                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6817                    sumene1x,sumene2x,sumene3x,sumene4x,&
6818                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6819                    cosfac2xx,sinfac2yy
6820 #ifdef DEBUG
6821       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6822                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6823                    de_dt_num
6824 #endif
6825 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6826
6827       delta=0.02d0*pi
6828       escloc=0.0D0
6829       do i=loc_start,loc_end
6830         if (itype(i,1).eq.ntyp1) cycle
6831         costtab(i+1) =dcos(theta(i+1))
6832         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6833         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6834         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6835         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6836         cosfac=dsqrt(cosfac2)
6837         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6838         sinfac=dsqrt(sinfac2)
6839         it=iabs(itype(i,1))
6840         if (it.eq.10) goto 1
6841 !
6842 !  Compute the axes of tghe local cartesian coordinates system; store in
6843 !   x_prime, y_prime and z_prime
6844 !
6845         do j=1,3
6846           x_prime(j) = 0.00
6847           y_prime(j) = 0.00
6848           z_prime(j) = 0.00
6849         enddo
6850 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6851 !     &   dc_norm(3,i+nres)
6852         do j = 1,3
6853           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6854           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6855         enddo
6856         do j = 1,3
6857           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6858         enddo
6859 !       write (2,*) "i",i
6860 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6861 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6862 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6863 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6864 !      & " xy",scalar(x_prime(1),y_prime(1)),
6865 !      & " xz",scalar(x_prime(1),z_prime(1)),
6866 !      & " yy",scalar(y_prime(1),y_prime(1)),
6867 !      & " yz",scalar(y_prime(1),z_prime(1)),
6868 !      & " zz",scalar(z_prime(1),z_prime(1))
6869 !
6870 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6871 ! to local coordinate system. Store in xx, yy, zz.
6872 !
6873         xx=0.0d0
6874         yy=0.0d0
6875         zz=0.0d0
6876         do j = 1,3
6877           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6878           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6879           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6880         enddo
6881
6882         xxtab(i)=xx
6883         yytab(i)=yy
6884         zztab(i)=zz
6885 !
6886 ! Compute the energy of the ith side cbain
6887 !
6888 !        write (2,*) "xx",xx," yy",yy," zz",zz
6889         it=iabs(itype(i,1))
6890         do j = 1,65
6891           x(j) = sc_parmin(j,it)
6892         enddo
6893 #ifdef CHECK_COORD
6894 !c diagnostics - remove later
6895         xx1 = dcos(alph(2))
6896         yy1 = dsin(alph(2))*dcos(omeg(2))
6897         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6898         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6899           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6900           xx1,yy1,zz1
6901 !,"  --- ", xx_w,yy_w,zz_w
6902 ! end diagnostics
6903 #endif
6904         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6905          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6906          + x(10)*yy*zz
6907         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6908          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6909          + x(20)*yy*zz
6910         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6911          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6912          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6913          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6914          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6915          +x(40)*xx*yy*zz
6916         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6917          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6918          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6919          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6920          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6921          +x(60)*xx*yy*zz
6922         dsc_i   = 0.743d0+x(61)
6923         dp2_i   = 1.9d0+x(62)
6924         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6925                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6926         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6927                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6928         s1=(1+x(63))/(0.1d0 + dscp1)
6929         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6930         s2=(1+x(65))/(0.1d0 + dscp2)
6931         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6932         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6933       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6934 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6935 !     &   sumene4,
6936 !     &   dscp1,dscp2,sumene
6937 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6938         escloc = escloc + sumene
6939 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6940 !     & ,zz,xx,yy
6941 !#define DEBUG
6942 #ifdef DEBUG
6943 !
6944 ! This section to check the numerical derivatives of the energy of ith side
6945 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6946 ! #define DEBUG in the code to turn it on.
6947 !
6948         write (2,*) "sumene               =",sumene
6949         aincr=1.0d-7
6950         xxsave=xx
6951         xx=xx+aincr
6952         write (2,*) xx,yy,zz
6953         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6954         de_dxx_num=(sumenep-sumene)/aincr
6955         xx=xxsave
6956         write (2,*) "xx+ sumene from enesc=",sumenep
6957         yysave=yy
6958         yy=yy+aincr
6959         write (2,*) xx,yy,zz
6960         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6961         de_dyy_num=(sumenep-sumene)/aincr
6962         yy=yysave
6963         write (2,*) "yy+ sumene from enesc=",sumenep
6964         zzsave=zz
6965         zz=zz+aincr
6966         write (2,*) xx,yy,zz
6967         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6968         de_dzz_num=(sumenep-sumene)/aincr
6969         zz=zzsave
6970         write (2,*) "zz+ sumene from enesc=",sumenep
6971         costsave=cost2tab(i+1)
6972         sintsave=sint2tab(i+1)
6973         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6974         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6975         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6976         de_dt_num=(sumenep-sumene)/aincr
6977         write (2,*) " t+ sumene from enesc=",sumenep
6978         cost2tab(i+1)=costsave
6979         sint2tab(i+1)=sintsave
6980 ! End of diagnostics section.
6981 #endif
6982 !
6983 ! Compute the gradient of esc
6984 !
6985 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6986         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6987         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6988         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6989         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6990         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6991         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6992         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6993         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6994         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6995            *(pom_s1/dscp1+pom_s16*dscp1**4)
6996         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6997            *(pom_s2/dscp2+pom_s26*dscp2**4)
6998         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6999         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7000         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7001         +x(40)*yy*zz
7002         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7003         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7004         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7005         +x(60)*yy*zz
7006         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7007               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7008               +(pom1+pom2)*pom_dx
7009 #ifdef DEBUG
7010         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7011 #endif
7012 !
7013         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7014         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7015         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7016         +x(40)*xx*zz
7017         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7018         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7019         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7020         +x(59)*zz**2 +x(60)*xx*zz
7021         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7022               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7023               +(pom1-pom2)*pom_dy
7024 #ifdef DEBUG
7025         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7026 #endif
7027 !
7028         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7029         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7030         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7031         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7032         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7033         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7034         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7035         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7036 #ifdef DEBUG
7037         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7038 #endif
7039 !
7040         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7041         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7042         +pom1*pom_dt1+pom2*pom_dt2
7043 #ifdef DEBUG
7044         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7045 #endif
7046 !
7047 !
7048        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7049        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7050        cosfac2xx=cosfac2*xx
7051        sinfac2yy=sinfac2*yy
7052        do k = 1,3
7053          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7054             vbld_inv(i+1)
7055          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7056             vbld_inv(i)
7057          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7058          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7059 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7060 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7061 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7062 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7063          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7064          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7065          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7066          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7067          dZZ_Ci1(k)=0.0d0
7068          dZZ_Ci(k)=0.0d0
7069          do j=1,3
7070            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7071            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7072            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7073            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7074          enddo
7075
7076          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7077          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7078          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7079          (z_prime(k)-zz*dC_norm(k,i+nres))
7080 !
7081          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7082          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7083        enddo
7084
7085        do k=1,3
7086          dXX_Ctab(k,i)=dXX_Ci(k)
7087          dXX_C1tab(k,i)=dXX_Ci1(k)
7088          dYY_Ctab(k,i)=dYY_Ci(k)
7089          dYY_C1tab(k,i)=dYY_Ci1(k)
7090          dZZ_Ctab(k,i)=dZZ_Ci(k)
7091          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7092          dXX_XYZtab(k,i)=dXX_XYZ(k)
7093          dYY_XYZtab(k,i)=dYY_XYZ(k)
7094          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7095        enddo
7096
7097        do k = 1,3
7098 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7099 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7100 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7101 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7102 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7103 !     &    dt_dci(k)
7104 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7105 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7106          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7107           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7108          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7109           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7110          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7111           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7112        enddo
7113 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7114 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7115
7116 ! to check gradient call subroutine check_grad
7117
7118     1 continue
7119       enddo
7120       return
7121       end subroutine esc
7122 !-----------------------------------------------------------------------------
7123       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7124 !      implicit none
7125       real(kind=8),dimension(65) :: x
7126       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7127         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7128
7129       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7130         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7131         + x(10)*yy*zz
7132       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7133         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7134         + x(20)*yy*zz
7135       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7136         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7137         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7138         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7139         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7140         +x(40)*xx*yy*zz
7141       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7142         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7143         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7144         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7145         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7146         +x(60)*xx*yy*zz
7147       dsc_i   = 0.743d0+x(61)
7148       dp2_i   = 1.9d0+x(62)
7149       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7150                 *(xx*cost2+yy*sint2))
7151       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7152                 *(xx*cost2-yy*sint2))
7153       s1=(1+x(63))/(0.1d0 + dscp1)
7154       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7155       s2=(1+x(65))/(0.1d0 + dscp2)
7156       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7157       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7158        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7159       enesc=sumene
7160       return
7161       end function enesc
7162 #endif
7163 !-----------------------------------------------------------------------------
7164       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7165 !
7166 ! This procedure calculates two-body contact function g(rij) and its derivative:
7167 !
7168 !           eps0ij                                     !       x < -1
7169 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7170 !            0                                         !       x > 1
7171 !
7172 ! where x=(rij-r0ij)/delta
7173 !
7174 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7175 !
7176 !      implicit none
7177       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7178       real(kind=8) :: x,x2,x4,delta
7179 !     delta=0.02D0*r0ij
7180 !      delta=0.2D0*r0ij
7181       x=(rij-r0ij)/delta
7182       if (x.lt.-1.0D0) then
7183         fcont=eps0ij
7184         fprimcont=0.0D0
7185       else if (x.le.1.0D0) then
7186         x2=x*x
7187         x4=x2*x2
7188         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7189         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7190       else
7191         fcont=0.0D0
7192         fprimcont=0.0D0
7193       endif
7194       return
7195       end subroutine gcont
7196 !-----------------------------------------------------------------------------
7197       subroutine splinthet(theti,delta,ss,ssder)
7198 !      implicit real*8 (a-h,o-z)
7199 !      include 'DIMENSIONS'
7200 !      include 'COMMON.VAR'
7201 !      include 'COMMON.GEO'
7202       real(kind=8) :: theti,delta,ss,ssder
7203       real(kind=8) :: thetup,thetlow
7204       thetup=pi-delta
7205       thetlow=delta
7206       if (theti.gt.pipol) then
7207         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7208       else
7209         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7210         ssder=-ssder
7211       endif
7212       return
7213       end subroutine splinthet
7214 !-----------------------------------------------------------------------------
7215       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7216 !      implicit none
7217       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7218       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7219       a1=fprim0*delta/(f1-f0)
7220       a2=3.0d0-2.0d0*a1
7221       a3=a1-2.0d0
7222       ksi=(x-x0)/delta
7223       ksi2=ksi*ksi
7224       ksi3=ksi2*ksi
7225       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7226       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7227       return
7228       end subroutine spline1
7229 !-----------------------------------------------------------------------------
7230       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7231 !      implicit none
7232       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7233       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7234       ksi=(x-x0)/delta
7235       ksi2=ksi*ksi
7236       ksi3=ksi2*ksi
7237       a1=fprim0x*delta
7238       a2=3*(f1x-f0x)-2*fprim0x*delta
7239       a3=fprim0x*delta-2*(f1x-f0x)
7240       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7241       return
7242       end subroutine spline2
7243 !-----------------------------------------------------------------------------
7244 #ifdef CRYST_TOR
7245 !-----------------------------------------------------------------------------
7246       subroutine etor(etors,edihcnstr)
7247 !      implicit real*8 (a-h,o-z)
7248 !      include 'DIMENSIONS'
7249 !      include 'COMMON.VAR'
7250 !      include 'COMMON.GEO'
7251 !      include 'COMMON.LOCAL'
7252 !      include 'COMMON.TORSION'
7253 !      include 'COMMON.INTERACT'
7254 !      include 'COMMON.DERIV'
7255 !      include 'COMMON.CHAIN'
7256 !      include 'COMMON.NAMES'
7257 !      include 'COMMON.IOUNITS'
7258 !      include 'COMMON.FFIELD'
7259 !      include 'COMMON.TORCNSTR'
7260 !      include 'COMMON.CONTROL'
7261       real(kind=8) :: etors,edihcnstr
7262       logical :: lprn
7263 !el local variables
7264       integer :: i,j,
7265       real(kind=8) :: phii,fac,etors_ii
7266
7267 ! Set lprn=.true. for debugging
7268       lprn=.false.
7269 !      lprn=.true.
7270       etors=0.0D0
7271       do i=iphi_start,iphi_end
7272       etors_ii=0.0D0
7273         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7274             .or. itype(i,1).eq.ntyp1) cycle
7275         itori=itortyp(itype(i-2,1))
7276         itori1=itortyp(itype(i-1,1))
7277         phii=phi(i)
7278         gloci=0.0D0
7279 ! Proline-Proline pair is a special case...
7280         if (itori.eq.3 .and. itori1.eq.3) then
7281           if (phii.gt.-dwapi3) then
7282             cosphi=dcos(3*phii)
7283             fac=1.0D0/(1.0D0-cosphi)
7284             etorsi=v1(1,3,3)*fac
7285             etorsi=etorsi+etorsi
7286             etors=etors+etorsi-v1(1,3,3)
7287             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7288             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7289           endif
7290           do j=1,3
7291             v1ij=v1(j+1,itori,itori1)
7292             v2ij=v2(j+1,itori,itori1)
7293             cosphi=dcos(j*phii)
7294             sinphi=dsin(j*phii)
7295             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7296             if (energy_dec) etors_ii=etors_ii+ &
7297                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7298             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7299           enddo
7300         else
7301           do j=1,nterm_old
7302             v1ij=v1(j,itori,itori1)
7303             v2ij=v2(j,itori,itori1)
7304             cosphi=dcos(j*phii)
7305             sinphi=dsin(j*phii)
7306             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7307             if (energy_dec) etors_ii=etors_ii+ &
7308                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7309             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7310           enddo
7311         endif
7312         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7313              'etor',i,etors_ii
7314         if (lprn) &
7315         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7316         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7317         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7318         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7319 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7320       enddo
7321 ! 6/20/98 - dihedral angle constraints
7322       edihcnstr=0.0d0
7323       do i=1,ndih_constr
7324         itori=idih_constr(i)
7325         phii=phi(itori)
7326         difi=phii-phi0(i)
7327         if (difi.gt.drange(i)) then
7328           difi=difi-drange(i)
7329           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7330           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7331         else if (difi.lt.-drange(i)) then
7332           difi=difi+drange(i)
7333           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7334           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7335         endif
7336 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7337 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7338       enddo
7339 !      write (iout,*) 'edihcnstr',edihcnstr
7340       return
7341       end subroutine etor
7342 !-----------------------------------------------------------------------------
7343       subroutine etor_d(etors_d)
7344       real(kind=8) :: etors_d
7345       etors_d=0.0d0
7346       return
7347       end subroutine etor_d
7348 #else
7349 !-----------------------------------------------------------------------------
7350       subroutine etor(etors)
7351 !      implicit real*8 (a-h,o-z)
7352 !      include 'DIMENSIONS'
7353 !      include 'COMMON.VAR'
7354 !      include 'COMMON.GEO'
7355 !      include 'COMMON.LOCAL'
7356 !      include 'COMMON.TORSION'
7357 !      include 'COMMON.INTERACT'
7358 !      include 'COMMON.DERIV'
7359 !      include 'COMMON.CHAIN'
7360 !      include 'COMMON.NAMES'
7361 !      include 'COMMON.IOUNITS'
7362 !      include 'COMMON.FFIELD'
7363 !      include 'COMMON.TORCNSTR'
7364 !      include 'COMMON.CONTROL'
7365       real(kind=8) :: etors,edihcnstr
7366       logical :: lprn
7367 !el local variables
7368       integer :: i,j,iblock,itori,itori1
7369       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7370                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7371 ! Set lprn=.true. for debugging
7372       lprn=.false.
7373 !     lprn=.true.
7374       etors=0.0D0
7375       do i=iphi_start,iphi_end
7376         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7377              .or. itype(i-3,1).eq.ntyp1 &
7378              .or. itype(i,1).eq.ntyp1) cycle
7379         etors_ii=0.0D0
7380          if (iabs(itype(i,1)).eq.20) then
7381          iblock=2
7382          else
7383          iblock=1
7384          endif
7385         itori=itortyp(itype(i-2,1))
7386         itori1=itortyp(itype(i-1,1))
7387         phii=phi(i)
7388         gloci=0.0D0
7389 ! Regular cosine and sine terms
7390         do j=1,nterm(itori,itori1,iblock)
7391           v1ij=v1(j,itori,itori1,iblock)
7392           v2ij=v2(j,itori,itori1,iblock)
7393           cosphi=dcos(j*phii)
7394           sinphi=dsin(j*phii)
7395           etors=etors+v1ij*cosphi+v2ij*sinphi
7396           if (energy_dec) etors_ii=etors_ii+ &
7397                      v1ij*cosphi+v2ij*sinphi
7398           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7399         enddo
7400 ! Lorentz terms
7401 !                         v1
7402 !  E = SUM ----------------------------------- - v1
7403 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7404 !
7405         cosphi=dcos(0.5d0*phii)
7406         sinphi=dsin(0.5d0*phii)
7407         do j=1,nlor(itori,itori1,iblock)
7408           vl1ij=vlor1(j,itori,itori1)
7409           vl2ij=vlor2(j,itori,itori1)
7410           vl3ij=vlor3(j,itori,itori1)
7411           pom=vl2ij*cosphi+vl3ij*sinphi
7412           pom1=1.0d0/(pom*pom+1.0d0)
7413           etors=etors+vl1ij*pom1
7414           if (energy_dec) etors_ii=etors_ii+ &
7415                      vl1ij*pom1
7416           pom=-pom*pom1*pom1
7417           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7418         enddo
7419 ! Subtract the constant term
7420         etors=etors-v0(itori,itori1,iblock)
7421           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7422                'etor',i,etors_ii-v0(itori,itori1,iblock)
7423         if (lprn) &
7424         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7425         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7426         (v1(j,itori,itori1,iblock),j=1,6),&
7427         (v2(j,itori,itori1,iblock),j=1,6)
7428         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7429 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7430       enddo
7431 ! 6/20/98 - dihedral angle constraints
7432       return
7433       end subroutine etor
7434 !C The rigorous attempt to derive energy function
7435 !-------------------------------------------------------------------------------------------
7436       subroutine etor_kcc(etors)
7437       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7438       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7439        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7440        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7441        gradvalst2,etori
7442       logical lprn
7443       integer :: i,j,itori,itori1,nval,k,l
7444
7445       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7446       etors=0.0D0
7447       do i=iphi_start,iphi_end
7448 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7449 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7450 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7451 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7452         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7453            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7454         itori=itortyp(itype(i-2,1))
7455         itori1=itortyp(itype(i-1,1))
7456         phii=phi(i)
7457         glocig=0.0D0
7458         glocit1=0.0d0
7459         glocit2=0.0d0
7460 !C to avoid multiple devision by 2
7461 !c        theti22=0.5d0*theta(i)
7462 !C theta 12 is the theta_1 /2
7463 !C theta 22 is theta_2 /2
7464 !c        theti12=0.5d0*theta(i-1)
7465 !C and appropriate sinus function
7466         sinthet1=dsin(theta(i-1))
7467         sinthet2=dsin(theta(i))
7468         costhet1=dcos(theta(i-1))
7469         costhet2=dcos(theta(i))
7470 !C to speed up lets store its mutliplication
7471         sint1t2=sinthet2*sinthet1
7472         sint1t2n=1.0d0
7473 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7474 !C +d_n*sin(n*gamma)) *
7475 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7476 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7477         nval=nterm_kcc_Tb(itori,itori1)
7478         c1(0)=0.0d0
7479         c2(0)=0.0d0
7480         c1(1)=1.0d0
7481         c2(1)=1.0d0
7482         do j=2,nval
7483           c1(j)=c1(j-1)*costhet1
7484           c2(j)=c2(j-1)*costhet2
7485         enddo
7486         etori=0.0d0
7487
7488        do j=1,nterm_kcc(itori,itori1)
7489           cosphi=dcos(j*phii)
7490           sinphi=dsin(j*phii)
7491           sint1t2n1=sint1t2n
7492           sint1t2n=sint1t2n*sint1t2
7493           sumvalc=0.0d0
7494           gradvalct1=0.0d0
7495           gradvalct2=0.0d0
7496           do k=1,nval
7497             do l=1,nval
7498               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7499               gradvalct1=gradvalct1+ &
7500                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7501               gradvalct2=gradvalct2+ &
7502                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7503             enddo
7504           enddo
7505           gradvalct1=-gradvalct1*sinthet1
7506           gradvalct2=-gradvalct2*sinthet2
7507           sumvals=0.0d0
7508           gradvalst1=0.0d0
7509           gradvalst2=0.0d0
7510           do k=1,nval
7511             do l=1,nval
7512               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7513               gradvalst1=gradvalst1+ &
7514                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7515               gradvalst2=gradvalst2+ &
7516                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7517             enddo
7518           enddo
7519           gradvalst1=-gradvalst1*sinthet1
7520           gradvalst2=-gradvalst2*sinthet2
7521           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7522           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7523 !C glocig is the gradient local i site in gamma
7524           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7525 !C now gradient over theta_1
7526          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7527         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7528          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7529         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7530         enddo ! j
7531         etors=etors+etori
7532         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7533 !C derivative over theta1
7534         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7535 !C now derivative over theta2
7536         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7537         if (lprn) then
7538          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7539             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7540           write (iout,*) "c1",(c1(k),k=0,nval), &
7541          " c2",(c2(k),k=0,nval)
7542         endif
7543       enddo
7544       return
7545        end  subroutine etor_kcc
7546 !------------------------------------------------------------------------------
7547
7548         subroutine etor_constr(edihcnstr)
7549       real(kind=8) :: etors,edihcnstr
7550       logical :: lprn
7551 !el local variables
7552       integer :: i,j,iblock,itori,itori1
7553       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7554                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7555                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7556
7557       if (raw_psipred) then
7558         do i=idihconstr_start,idihconstr_end
7559           itori=idih_constr(i)
7560           phii=phi(itori)
7561           gaudih_i=vpsipred(1,i)
7562           gauder_i=0.0d0
7563           do j=1,2
7564             s = sdihed(j,i)
7565             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7566             dexpcos_i=dexp(-cos_i*cos_i)
7567             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7568           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7569                  *cos_i*dexpcos_i/s**2
7570           enddo
7571           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7572           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7573           if (energy_dec) &
7574           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7575           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7576           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7577           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7578           -wdihc*dlog(gaudih_i)
7579         enddo
7580       else
7581
7582       do i=idihconstr_start,idihconstr_end
7583         itori=idih_constr(i)
7584         phii=phi(itori)
7585         difi=pinorm(phii-phi0(i))
7586         if (difi.gt.drange(i)) then
7587           difi=difi-drange(i)
7588           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7589           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7590         else if (difi.lt.-drange(i)) then
7591           difi=difi+drange(i)
7592           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7594         else
7595           difi=0.0
7596         endif
7597       enddo
7598
7599       endif
7600
7601       return
7602
7603       end subroutine etor_constr
7604 !-----------------------------------------------------------------------------
7605       subroutine etor_d(etors_d)
7606 ! 6/23/01 Compute double torsional energy
7607 !      implicit real*8 (a-h,o-z)
7608 !      include 'DIMENSIONS'
7609 !      include 'COMMON.VAR'
7610 !      include 'COMMON.GEO'
7611 !      include 'COMMON.LOCAL'
7612 !      include 'COMMON.TORSION'
7613 !      include 'COMMON.INTERACT'
7614 !      include 'COMMON.DERIV'
7615 !      include 'COMMON.CHAIN'
7616 !      include 'COMMON.NAMES'
7617 !      include 'COMMON.IOUNITS'
7618 !      include 'COMMON.FFIELD'
7619 !      include 'COMMON.TORCNSTR'
7620       real(kind=8) :: etors_d,etors_d_ii
7621       logical :: lprn
7622 !el local variables
7623       integer :: i,j,k,l,itori,itori1,itori2,iblock
7624       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7625                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7626                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7627                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7628 ! Set lprn=.true. for debugging
7629       lprn=.false.
7630 !     lprn=.true.
7631       etors_d=0.0D0
7632 !      write(iout,*) "a tu??"
7633       do i=iphid_start,iphid_end
7634         etors_d_ii=0.0D0
7635         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7636             .or. itype(i-3,1).eq.ntyp1 &
7637             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7638         itori=itortyp(itype(i-2,1))
7639         itori1=itortyp(itype(i-1,1))
7640         itori2=itortyp(itype(i,1))
7641         phii=phi(i)
7642         phii1=phi(i+1)
7643         gloci1=0.0D0
7644         gloci2=0.0D0
7645         iblock=1
7646         if (iabs(itype(i+1,1)).eq.20) iblock=2
7647
7648 ! Regular cosine and sine terms
7649         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7650           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7651           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7652           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7653           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7654           cosphi1=dcos(j*phii)
7655           sinphi1=dsin(j*phii)
7656           cosphi2=dcos(j*phii1)
7657           sinphi2=dsin(j*phii1)
7658           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7659            v2cij*cosphi2+v2sij*sinphi2
7660           if (energy_dec) etors_d_ii=etors_d_ii+ &
7661            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7662           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7663           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7664         enddo
7665         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7666           do l=1,k-1
7667             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7668             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7669             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7670             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7671             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7672             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7673             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7674             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7675             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7676               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7677             if (energy_dec) etors_d_ii=etors_d_ii+ &
7678               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7679               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7680             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7681               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7682             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7683               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7684           enddo
7685         enddo
7686         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7687                             'etor_d',i,etors_d_ii
7688         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7689         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7690       enddo
7691       return
7692       end subroutine etor_d
7693 #endif
7694
7695       subroutine ebend_kcc(etheta)
7696       logical lprn
7697       double precision thybt1(maxang_kcc),etheta
7698       integer :: i,iti,j,ihelp
7699       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7700 !C Set lprn=.true. for debugging
7701       lprn=energy_dec
7702 !c     lprn=.true.
7703 !C      print *,"wchodze kcc"
7704       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7705       etheta=0.0D0
7706       do i=ithet_start,ithet_end
7707 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7708         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7709        .or.itype(i,1).eq.ntyp1) cycle
7710         iti=iabs(itortyp(itype(i-1,1)))
7711         sinthet=dsin(theta(i))
7712         costhet=dcos(theta(i))
7713         do j=1,nbend_kcc_Tb(iti)
7714           thybt1(j)=v1bend_chyb(j,iti)
7715         enddo
7716         sumth1thyb=v1bend_chyb(0,iti)+ &
7717          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7718         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7719          sumth1thyb
7720         ihelp=nbend_kcc_Tb(iti)-1
7721         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7722         etheta=etheta+sumth1thyb
7723 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7724         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7725       enddo
7726       return
7727       end subroutine ebend_kcc
7728 !c------------
7729 !c-------------------------------------------------------------------------------------
7730       subroutine etheta_constr(ethetacnstr)
7731       real (kind=8) :: ethetacnstr,thetiii,difi
7732       integer :: i,itheta
7733       ethetacnstr=0.0d0
7734 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7735       do i=ithetaconstr_start,ithetaconstr_end
7736         itheta=itheta_constr(i)
7737         thetiii=theta(itheta)
7738         difi=pinorm(thetiii-theta_constr0(i))
7739         if (difi.gt.theta_drange(i)) then
7740           difi=difi-theta_drange(i)
7741           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7742           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7743          +for_thet_constr(i)*difi**3
7744         else if (difi.lt.-drange(i)) then
7745           difi=difi+drange(i)
7746           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7747           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7748           +for_thet_constr(i)*difi**3
7749         else
7750           difi=0.0
7751         endif
7752        if (energy_dec) then
7753         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7754          i,itheta,rad2deg*thetiii,&
7755          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7756          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7757          gloc(itheta+nphi-2,icg)
7758         endif
7759       enddo
7760       return
7761       end subroutine etheta_constr
7762
7763 !-----------------------------------------------------------------------------
7764       subroutine eback_sc_corr(esccor)
7765 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7766 !        conformational states; temporarily implemented as differences
7767 !        between UNRES torsional potentials (dependent on three types of
7768 !        residues) and the torsional potentials dependent on all 20 types
7769 !        of residues computed from AM1  energy surfaces of terminally-blocked
7770 !        amino-acid residues.
7771 !      implicit real*8 (a-h,o-z)
7772 !      include 'DIMENSIONS'
7773 !      include 'COMMON.VAR'
7774 !      include 'COMMON.GEO'
7775 !      include 'COMMON.LOCAL'
7776 !      include 'COMMON.TORSION'
7777 !      include 'COMMON.SCCOR'
7778 !      include 'COMMON.INTERACT'
7779 !      include 'COMMON.DERIV'
7780 !      include 'COMMON.CHAIN'
7781 !      include 'COMMON.NAMES'
7782 !      include 'COMMON.IOUNITS'
7783 !      include 'COMMON.FFIELD'
7784 !      include 'COMMON.CONTROL'
7785       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7786                    cosphi,sinphi
7787       logical :: lprn
7788       integer :: i,interty,j,isccori,isccori1,intertyp
7789 ! Set lprn=.true. for debugging
7790       lprn=.false.
7791 !      lprn=.true.
7792 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7793       esccor=0.0D0
7794       do i=itau_start,itau_end
7795         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7796         esccor_ii=0.0D0
7797         isccori=isccortyp(itype(i-2,1))
7798         isccori1=isccortyp(itype(i-1,1))
7799
7800 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7801         phii=phi(i)
7802         do intertyp=1,3 !intertyp
7803          esccor_ii=0.0D0
7804 !c Added 09 May 2012 (Adasko)
7805 !c  Intertyp means interaction type of backbone mainchain correlation:
7806 !   1 = SC...Ca...Ca...Ca
7807 !   2 = Ca...Ca...Ca...SC
7808 !   3 = SC...Ca...Ca...SCi
7809         gloci=0.0D0
7810         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7811             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7812             (itype(i-1,1).eq.ntyp1))) &
7813           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7814            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7815            .or.(itype(i,1).eq.ntyp1))) &
7816           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7817             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7818             (itype(i-3,1).eq.ntyp1)))) cycle
7819         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7820         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7821        cycle
7822        do j=1,nterm_sccor(isccori,isccori1)
7823           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7824           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7825           cosphi=dcos(j*tauangle(intertyp,i))
7826           sinphi=dsin(j*tauangle(intertyp,i))
7827           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7828           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7829           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7830         enddo
7831         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7832                                 'esccor',i,intertyp,esccor_ii
7833 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7834         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7835         if (lprn) &
7836         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7837         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7838         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7839         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7840         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7841        enddo !intertyp
7842       enddo
7843
7844       return
7845       end subroutine eback_sc_corr
7846 !-----------------------------------------------------------------------------
7847       subroutine multibody(ecorr)
7848 ! This subroutine calculates multi-body contributions to energy following
7849 ! the idea of Skolnick et al. If side chains I and J make a contact and
7850 ! at the same time side chains I+1 and J+1 make a contact, an extra
7851 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7852 !      implicit real*8 (a-h,o-z)
7853 !      include 'DIMENSIONS'
7854 !      include 'COMMON.IOUNITS'
7855 !      include 'COMMON.DERIV'
7856 !      include 'COMMON.INTERACT'
7857 !      include 'COMMON.CONTACTS'
7858       real(kind=8),dimension(3) :: gx,gx1
7859       logical :: lprn
7860       real(kind=8) :: ecorr
7861       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7862 ! Set lprn=.true. for debugging
7863       lprn=.false.
7864
7865       if (lprn) then
7866         write (iout,'(a)') 'Contact function values:'
7867         do i=nnt,nct-2
7868           write (iout,'(i2,20(1x,i2,f10.5))') &
7869               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7870         enddo
7871       endif
7872       ecorr=0.0D0
7873
7874 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7875 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7876       do i=nnt,nct
7877         do j=1,3
7878           gradcorr(j,i)=0.0D0
7879           gradxorr(j,i)=0.0D0
7880         enddo
7881       enddo
7882       do i=nnt,nct-2
7883
7884         DO ISHIFT = 3,4
7885
7886         i1=i+ishift
7887         num_conti=num_cont(i)
7888         num_conti1=num_cont(i1)
7889         do jj=1,num_conti
7890           j=jcont(jj,i)
7891           do kk=1,num_conti1
7892             j1=jcont(kk,i1)
7893             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7894 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7895 !d   &                   ' ishift=',ishift
7896 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7897 ! The system gains extra energy.
7898               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7899             endif   ! j1==j+-ishift
7900           enddo     ! kk
7901         enddo       ! jj
7902
7903         ENDDO ! ISHIFT
7904
7905       enddo         ! i
7906       return
7907       end subroutine multibody
7908 !-----------------------------------------------------------------------------
7909       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7910 !      implicit real*8 (a-h,o-z)
7911 !      include 'DIMENSIONS'
7912 !      include 'COMMON.IOUNITS'
7913 !      include 'COMMON.DERIV'
7914 !      include 'COMMON.INTERACT'
7915 !      include 'COMMON.CONTACTS'
7916       real(kind=8),dimension(3) :: gx,gx1
7917       logical :: lprn
7918       integer :: i,j,k,l,jj,kk,m,ll
7919       real(kind=8) :: eij,ekl
7920       lprn=.false.
7921       eij=facont(jj,i)
7922       ekl=facont(kk,k)
7923 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7924 ! Calculate the multi-body contribution to energy.
7925 ! Calculate multi-body contributions to the gradient.
7926 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7927 !d   & k,l,(gacont(m,kk,k),m=1,3)
7928       do m=1,3
7929         gx(m) =ekl*gacont(m,jj,i)
7930         gx1(m)=eij*gacont(m,kk,k)
7931         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7932         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7933         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7934         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7935       enddo
7936       do m=i,j-1
7937         do ll=1,3
7938           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7939         enddo
7940       enddo
7941       do m=k,l-1
7942         do ll=1,3
7943           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7944         enddo
7945       enddo
7946       esccorr=-eij*ekl
7947       return
7948       end function esccorr
7949 !-----------------------------------------------------------------------------
7950       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7951 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7952 !      implicit real*8 (a-h,o-z)
7953 !      include 'DIMENSIONS'
7954 !      include 'COMMON.IOUNITS'
7955 #ifdef MPI
7956       include "mpif.h"
7957 !      integer :: maxconts !max_cont=maxconts  =nres/4
7958       integer,parameter :: max_dim=26
7959       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7960       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7961 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7962 !el      common /przechowalnia/ zapas
7963       integer :: status(MPI_STATUS_SIZE)
7964       integer,dimension((nres/4)*2) :: req !maxconts*2
7965       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7966 #endif
7967 !      include 'COMMON.SETUP'
7968 !      include 'COMMON.FFIELD'
7969 !      include 'COMMON.DERIV'
7970 !      include 'COMMON.INTERACT'
7971 !      include 'COMMON.CONTACTS'
7972 !      include 'COMMON.CONTROL'
7973 !      include 'COMMON.LOCAL'
7974       real(kind=8),dimension(3) :: gx,gx1
7975       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7976       logical :: lprn,ldone
7977 !el local variables
7978       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7979               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7980
7981 ! Set lprn=.true. for debugging
7982       lprn=.false.
7983 #ifdef MPI
7984 !      maxconts=nres/4
7985       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7986       n_corr=0
7987       n_corr1=0
7988       if (nfgtasks.le.1) goto 30
7989       if (lprn) then
7990         write (iout,'(a)') 'Contact function values before RECEIVE:'
7991         do i=nnt,nct-2
7992           write (iout,'(2i3,50(1x,i2,f5.2))') &
7993           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7994           j=1,num_cont_hb(i))
7995         enddo
7996       endif
7997       call flush(iout)
7998       do i=1,ntask_cont_from
7999         ncont_recv(i)=0
8000       enddo
8001       do i=1,ntask_cont_to
8002         ncont_sent(i)=0
8003       enddo
8004 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8005 !     & ntask_cont_to
8006 ! Make the list of contacts to send to send to other procesors
8007 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8008 !      call flush(iout)
8009       do i=iturn3_start,iturn3_end
8010 !        write (iout,*) "make contact list turn3",i," num_cont",
8011 !     &    num_cont_hb(i)
8012         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8013       enddo
8014       do i=iturn4_start,iturn4_end
8015 !        write (iout,*) "make contact list turn4",i," num_cont",
8016 !     &   num_cont_hb(i)
8017         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8018       enddo
8019       do ii=1,nat_sent
8020         i=iat_sent(ii)
8021 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8022 !     &    num_cont_hb(i)
8023         do j=1,num_cont_hb(i)
8024         do k=1,4
8025           jjc=jcont_hb(j,i)
8026           iproc=iint_sent_local(k,jjc,ii)
8027 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8028           if (iproc.gt.0) then
8029             ncont_sent(iproc)=ncont_sent(iproc)+1
8030             nn=ncont_sent(iproc)
8031             zapas(1,nn,iproc)=i
8032             zapas(2,nn,iproc)=jjc
8033             zapas(3,nn,iproc)=facont_hb(j,i)
8034             zapas(4,nn,iproc)=ees0p(j,i)
8035             zapas(5,nn,iproc)=ees0m(j,i)
8036             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8037             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8038             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8039             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8040             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8041             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8042             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8043             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8044             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8045             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8046             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8047             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8048             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8049             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8050             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8051             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8052             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8053             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8054             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8055             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8056             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8057           endif
8058         enddo
8059         enddo
8060       enddo
8061       if (lprn) then
8062       write (iout,*) &
8063         "Numbers of contacts to be sent to other processors",&
8064         (ncont_sent(i),i=1,ntask_cont_to)
8065       write (iout,*) "Contacts sent"
8066       do ii=1,ntask_cont_to
8067         nn=ncont_sent(ii)
8068         iproc=itask_cont_to(ii)
8069         write (iout,*) nn," contacts to processor",iproc,&
8070          " of CONT_TO_COMM group"
8071         do i=1,nn
8072           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8073         enddo
8074       enddo
8075       call flush(iout)
8076       endif
8077       CorrelType=477
8078       CorrelID=fg_rank+1
8079       CorrelType1=478
8080       CorrelID1=nfgtasks+fg_rank+1
8081       ireq=0
8082 ! Receive the numbers of needed contacts from other processors
8083       do ii=1,ntask_cont_from
8084         iproc=itask_cont_from(ii)
8085         ireq=ireq+1
8086         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8087           FG_COMM,req(ireq),IERR)
8088       enddo
8089 !      write (iout,*) "IRECV ended"
8090 !      call flush(iout)
8091 ! Send the number of contacts needed by other processors
8092       do ii=1,ntask_cont_to
8093         iproc=itask_cont_to(ii)
8094         ireq=ireq+1
8095         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8096           FG_COMM,req(ireq),IERR)
8097       enddo
8098 !      write (iout,*) "ISEND ended"
8099 !      write (iout,*) "number of requests (nn)",ireq
8100       call flush(iout)
8101       if (ireq.gt.0) &
8102         call MPI_Waitall(ireq,req,status_array,ierr)
8103 !      write (iout,*)
8104 !     &  "Numbers of contacts to be received from other processors",
8105 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8106 !      call flush(iout)
8107 ! Receive contacts
8108       ireq=0
8109       do ii=1,ntask_cont_from
8110         iproc=itask_cont_from(ii)
8111         nn=ncont_recv(ii)
8112 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8113 !     &   " of CONT_TO_COMM group"
8114         call flush(iout)
8115         if (nn.gt.0) then
8116           ireq=ireq+1
8117           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8118           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8119 !          write (iout,*) "ireq,req",ireq,req(ireq)
8120         endif
8121       enddo
8122 ! Send the contacts to processors that need them
8123       do ii=1,ntask_cont_to
8124         iproc=itask_cont_to(ii)
8125         nn=ncont_sent(ii)
8126 !        write (iout,*) nn," contacts to processor",iproc,
8127 !     &   " of CONT_TO_COMM group"
8128         if (nn.gt.0) then
8129           ireq=ireq+1
8130           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8131             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8132 !          write (iout,*) "ireq,req",ireq,req(ireq)
8133 !          do i=1,nn
8134 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8135 !          enddo
8136         endif
8137       enddo
8138 !      write (iout,*) "number of requests (contacts)",ireq
8139 !      write (iout,*) "req",(req(i),i=1,4)
8140 !      call flush(iout)
8141       if (ireq.gt.0) &
8142        call MPI_Waitall(ireq,req,status_array,ierr)
8143       do iii=1,ntask_cont_from
8144         iproc=itask_cont_from(iii)
8145         nn=ncont_recv(iii)
8146         if (lprn) then
8147         write (iout,*) "Received",nn," contacts from processor",iproc,&
8148          " of CONT_FROM_COMM group"
8149         call flush(iout)
8150         do i=1,nn
8151           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8152         enddo
8153         call flush(iout)
8154         endif
8155         do i=1,nn
8156           ii=zapas_recv(1,i,iii)
8157 ! Flag the received contacts to prevent double-counting
8158           jj=-zapas_recv(2,i,iii)
8159 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8160 !          call flush(iout)
8161           nnn=num_cont_hb(ii)+1
8162           num_cont_hb(ii)=nnn
8163           jcont_hb(nnn,ii)=jj
8164           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8165           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8166           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8167           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8168           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8169           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8170           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8171           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8172           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8173           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8174           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8175           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8176           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8177           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8178           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8179           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8180           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8181           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8182           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8183           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8184           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8185           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8186           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8187           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8188         enddo
8189       enddo
8190       call flush(iout)
8191       if (lprn) then
8192         write (iout,'(a)') 'Contact function values after receive:'
8193         do i=nnt,nct-2
8194           write (iout,'(2i3,50(1x,i3,f5.2))') &
8195           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8196           j=1,num_cont_hb(i))
8197         enddo
8198         call flush(iout)
8199       endif
8200    30 continue
8201 #endif
8202       if (lprn) then
8203         write (iout,'(a)') 'Contact function values:'
8204         do i=nnt,nct-2
8205           write (iout,'(2i3,50(1x,i3,f5.2))') &
8206           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8207           j=1,num_cont_hb(i))
8208         enddo
8209       endif
8210       ecorr=0.0D0
8211
8212 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8213 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8214 ! Remove the loop below after debugging !!!
8215       do i=nnt,nct
8216         do j=1,3
8217           gradcorr(j,i)=0.0D0
8218           gradxorr(j,i)=0.0D0
8219         enddo
8220       enddo
8221 ! Calculate the local-electrostatic correlation terms
8222       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8223         i1=i+1
8224         num_conti=num_cont_hb(i)
8225         num_conti1=num_cont_hb(i+1)
8226         do jj=1,num_conti
8227           j=jcont_hb(jj,i)
8228           jp=iabs(j)
8229           do kk=1,num_conti1
8230             j1=jcont_hb(kk,i1)
8231             jp1=iabs(j1)
8232 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8233 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8234             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8235                 .or. j.lt.0 .and. j1.gt.0) .and. &
8236                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8237 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8238 ! The system gains extra energy.
8239               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8240               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8241                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8242               n_corr=n_corr+1
8243             else if (j1.eq.j) then
8244 ! Contacts I-J and I-(J+1) occur simultaneously.
8245 ! The system loses extra energy.
8246 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8247             endif
8248           enddo ! kk
8249           do kk=1,num_conti
8250             j1=jcont_hb(kk,i)
8251 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8252 !    &         ' jj=',jj,' kk=',kk
8253             if (j1.eq.j+1) then
8254 ! Contacts I-J and (I+1)-J occur simultaneously.
8255 ! The system loses extra energy.
8256 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8257             endif ! j1==j+1
8258           enddo ! kk
8259         enddo ! jj
8260       enddo ! i
8261       return
8262       end subroutine multibody_hb
8263 !-----------------------------------------------------------------------------
8264       subroutine add_hb_contact(ii,jj,itask)
8265 !      implicit real*8 (a-h,o-z)
8266 !      include "DIMENSIONS"
8267 !      include "COMMON.IOUNITS"
8268 !      include "COMMON.CONTACTS"
8269 !      integer,parameter :: maxconts=nres/4
8270       integer,parameter :: max_dim=26
8271       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8272 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8273 !      common /przechowalnia/ zapas
8274       integer :: i,j,ii,jj,iproc,nn,jjc
8275       integer,dimension(4) :: itask
8276 !      write (iout,*) "itask",itask
8277       do i=1,2
8278         iproc=itask(i)
8279         if (iproc.gt.0) then
8280           do j=1,num_cont_hb(ii)
8281             jjc=jcont_hb(j,ii)
8282 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8283             if (jjc.eq.jj) then
8284               ncont_sent(iproc)=ncont_sent(iproc)+1
8285               nn=ncont_sent(iproc)
8286               zapas(1,nn,iproc)=ii
8287               zapas(2,nn,iproc)=jjc
8288               zapas(3,nn,iproc)=facont_hb(j,ii)
8289               zapas(4,nn,iproc)=ees0p(j,ii)
8290               zapas(5,nn,iproc)=ees0m(j,ii)
8291               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8292               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8293               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8294               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8295               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8296               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8297               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8298               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8299               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8300               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8301               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8302               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8303               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8304               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8305               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8306               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8307               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8308               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8309               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8310               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8311               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8312               exit
8313             endif
8314           enddo
8315         endif
8316       enddo
8317       return
8318       end subroutine add_hb_contact
8319 !-----------------------------------------------------------------------------
8320       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8321 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8322 !      implicit real*8 (a-h,o-z)
8323 !      include 'DIMENSIONS'
8324 !      include 'COMMON.IOUNITS'
8325       integer,parameter :: max_dim=70
8326 #ifdef MPI
8327       include "mpif.h"
8328 !      integer :: maxconts !max_cont=maxconts=nres/4
8329       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8330       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8331 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8332 !      common /przechowalnia/ zapas
8333       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8334         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8335         ierr,iii,nnn
8336 #endif
8337 !      include 'COMMON.SETUP'
8338 !      include 'COMMON.FFIELD'
8339 !      include 'COMMON.DERIV'
8340 !      include 'COMMON.LOCAL'
8341 !      include 'COMMON.INTERACT'
8342 !      include 'COMMON.CONTACTS'
8343 !      include 'COMMON.CHAIN'
8344 !      include 'COMMON.CONTROL'
8345       real(kind=8),dimension(3) :: gx,gx1
8346       integer,dimension(nres) :: num_cont_hb_old
8347       logical :: lprn,ldone
8348 !EL      double precision eello4,eello5,eelo6,eello_turn6
8349 !EL      external eello4,eello5,eello6,eello_turn6
8350 !el local variables
8351       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8352               j1,jp1,i1,num_conti1
8353       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8354       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8355
8356 ! Set lprn=.true. for debugging
8357       lprn=.false.
8358       eturn6=0.0d0
8359 #ifdef MPI
8360 !      maxconts=nres/4
8361       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8362       do i=1,nres
8363         num_cont_hb_old(i)=num_cont_hb(i)
8364       enddo
8365       n_corr=0
8366       n_corr1=0
8367       if (nfgtasks.le.1) goto 30
8368       if (lprn) then
8369         write (iout,'(a)') 'Contact function values before RECEIVE:'
8370         do i=nnt,nct-2
8371           write (iout,'(2i3,50(1x,i2,f5.2))') &
8372           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8373           j=1,num_cont_hb(i))
8374         enddo
8375       endif
8376       call flush(iout)
8377       do i=1,ntask_cont_from
8378         ncont_recv(i)=0
8379       enddo
8380       do i=1,ntask_cont_to
8381         ncont_sent(i)=0
8382       enddo
8383 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8384 !     & ntask_cont_to
8385 ! Make the list of contacts to send to send to other procesors
8386       do i=iturn3_start,iturn3_end
8387 !        write (iout,*) "make contact list turn3",i," num_cont",
8388 !     &    num_cont_hb(i)
8389         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8390       enddo
8391       do i=iturn4_start,iturn4_end
8392 !        write (iout,*) "make contact list turn4",i," num_cont",
8393 !     &   num_cont_hb(i)
8394         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8395       enddo
8396       do ii=1,nat_sent
8397         i=iat_sent(ii)
8398 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8399 !     &    num_cont_hb(i)
8400         do j=1,num_cont_hb(i)
8401         do k=1,4
8402           jjc=jcont_hb(j,i)
8403           iproc=iint_sent_local(k,jjc,ii)
8404 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8405           if (iproc.ne.0) then
8406             ncont_sent(iproc)=ncont_sent(iproc)+1
8407             nn=ncont_sent(iproc)
8408             zapas(1,nn,iproc)=i
8409             zapas(2,nn,iproc)=jjc
8410             zapas(3,nn,iproc)=d_cont(j,i)
8411             ind=3
8412             do kk=1,3
8413               ind=ind+1
8414               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8415             enddo
8416             do kk=1,2
8417               do ll=1,2
8418                 ind=ind+1
8419                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8420               enddo
8421             enddo
8422             do jj=1,5
8423               do kk=1,3
8424                 do ll=1,2
8425                   do mm=1,2
8426                     ind=ind+1
8427                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8428                   enddo
8429                 enddo
8430               enddo
8431             enddo
8432           endif
8433         enddo
8434         enddo
8435       enddo
8436       if (lprn) then
8437       write (iout,*) &
8438         "Numbers of contacts to be sent to other processors",&
8439         (ncont_sent(i),i=1,ntask_cont_to)
8440       write (iout,*) "Contacts sent"
8441       do ii=1,ntask_cont_to
8442         nn=ncont_sent(ii)
8443         iproc=itask_cont_to(ii)
8444         write (iout,*) nn," contacts to processor",iproc,&
8445          " of CONT_TO_COMM group"
8446         do i=1,nn
8447           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8448         enddo
8449       enddo
8450       call flush(iout)
8451       endif
8452       CorrelType=477
8453       CorrelID=fg_rank+1
8454       CorrelType1=478
8455       CorrelID1=nfgtasks+fg_rank+1
8456       ireq=0
8457 ! Receive the numbers of needed contacts from other processors
8458       do ii=1,ntask_cont_from
8459         iproc=itask_cont_from(ii)
8460         ireq=ireq+1
8461         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8462           FG_COMM,req(ireq),IERR)
8463       enddo
8464 !      write (iout,*) "IRECV ended"
8465 !      call flush(iout)
8466 ! Send the number of contacts needed by other processors
8467       do ii=1,ntask_cont_to
8468         iproc=itask_cont_to(ii)
8469         ireq=ireq+1
8470         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8471           FG_COMM,req(ireq),IERR)
8472       enddo
8473 !      write (iout,*) "ISEND ended"
8474 !      write (iout,*) "number of requests (nn)",ireq
8475       call flush(iout)
8476       if (ireq.gt.0) &
8477         call MPI_Waitall(ireq,req,status_array,ierr)
8478 !      write (iout,*)
8479 !     &  "Numbers of contacts to be received from other processors",
8480 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8481 !      call flush(iout)
8482 ! Receive contacts
8483       ireq=0
8484       do ii=1,ntask_cont_from
8485         iproc=itask_cont_from(ii)
8486         nn=ncont_recv(ii)
8487 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8488 !     &   " of CONT_TO_COMM group"
8489         call flush(iout)
8490         if (nn.gt.0) then
8491           ireq=ireq+1
8492           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8493           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8494 !          write (iout,*) "ireq,req",ireq,req(ireq)
8495         endif
8496       enddo
8497 ! Send the contacts to processors that need them
8498       do ii=1,ntask_cont_to
8499         iproc=itask_cont_to(ii)
8500         nn=ncont_sent(ii)
8501 !        write (iout,*) nn," contacts to processor",iproc,
8502 !     &   " of CONT_TO_COMM group"
8503         if (nn.gt.0) then
8504           ireq=ireq+1
8505           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8506             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8507 !          write (iout,*) "ireq,req",ireq,req(ireq)
8508 !          do i=1,nn
8509 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8510 !          enddo
8511         endif
8512       enddo
8513 !      write (iout,*) "number of requests (contacts)",ireq
8514 !      write (iout,*) "req",(req(i),i=1,4)
8515 !      call flush(iout)
8516       if (ireq.gt.0) &
8517        call MPI_Waitall(ireq,req,status_array,ierr)
8518       do iii=1,ntask_cont_from
8519         iproc=itask_cont_from(iii)
8520         nn=ncont_recv(iii)
8521         if (lprn) then
8522         write (iout,*) "Received",nn," contacts from processor",iproc,&
8523          " of CONT_FROM_COMM group"
8524         call flush(iout)
8525         do i=1,nn
8526           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8527         enddo
8528         call flush(iout)
8529         endif
8530         do i=1,nn
8531           ii=zapas_recv(1,i,iii)
8532 ! Flag the received contacts to prevent double-counting
8533           jj=-zapas_recv(2,i,iii)
8534 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8535 !          call flush(iout)
8536           nnn=num_cont_hb(ii)+1
8537           num_cont_hb(ii)=nnn
8538           jcont_hb(nnn,ii)=jj
8539           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8540           ind=3
8541           do kk=1,3
8542             ind=ind+1
8543             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8544           enddo
8545           do kk=1,2
8546             do ll=1,2
8547               ind=ind+1
8548               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8549             enddo
8550           enddo
8551           do jj=1,5
8552             do kk=1,3
8553               do ll=1,2
8554                 do mm=1,2
8555                   ind=ind+1
8556                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8557                 enddo
8558               enddo
8559             enddo
8560           enddo
8561         enddo
8562       enddo
8563       call flush(iout)
8564       if (lprn) then
8565         write (iout,'(a)') 'Contact function values after receive:'
8566         do i=nnt,nct-2
8567           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8568           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8569           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8570         enddo
8571         call flush(iout)
8572       endif
8573    30 continue
8574 #endif
8575       if (lprn) then
8576         write (iout,'(a)') 'Contact function values:'
8577         do i=nnt,nct-2
8578           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8579           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8580           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8581         enddo
8582       endif
8583       ecorr=0.0D0
8584       ecorr5=0.0d0
8585       ecorr6=0.0d0
8586
8587 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8588 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8589 ! Remove the loop below after debugging !!!
8590       do i=nnt,nct
8591         do j=1,3
8592           gradcorr(j,i)=0.0D0
8593           gradxorr(j,i)=0.0D0
8594         enddo
8595       enddo
8596 ! Calculate the dipole-dipole interaction energies
8597       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8598       do i=iatel_s,iatel_e+1
8599         num_conti=num_cont_hb(i)
8600         do jj=1,num_conti
8601           j=jcont_hb(jj,i)
8602 #ifdef MOMENT
8603           call dipole(i,j,jj)
8604 #endif
8605         enddo
8606       enddo
8607       endif
8608 ! Calculate the local-electrostatic correlation terms
8609 !                write (iout,*) "gradcorr5 in eello5 before loop"
8610 !                do iii=1,nres
8611 !                  write (iout,'(i5,3f10.5)')
8612 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8613 !                enddo
8614       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8615 !        write (iout,*) "corr loop i",i
8616         i1=i+1
8617         num_conti=num_cont_hb(i)
8618         num_conti1=num_cont_hb(i+1)
8619         do jj=1,num_conti
8620           j=jcont_hb(jj,i)
8621           jp=iabs(j)
8622           do kk=1,num_conti1
8623             j1=jcont_hb(kk,i1)
8624             jp1=iabs(j1)
8625 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8626 !     &         ' jj=',jj,' kk=',kk
8627 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8628             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8629                 .or. j.lt.0 .and. j1.gt.0) .and. &
8630                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8631 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8632 ! The system gains extra energy.
8633               n_corr=n_corr+1
8634               sqd1=dsqrt(d_cont(jj,i))
8635               sqd2=dsqrt(d_cont(kk,i1))
8636               sred_geom = sqd1*sqd2
8637               IF (sred_geom.lt.cutoff_corr) THEN
8638                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8639                   ekont,fprimcont)
8640 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8641 !d     &         ' jj=',jj,' kk=',kk
8642                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8643                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8644                 do l=1,3
8645                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8646                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8647                 enddo
8648                 n_corr1=n_corr1+1
8649 !d               write (iout,*) 'sred_geom=',sred_geom,
8650 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8651 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8652 !d               write (iout,*) "g_contij",g_contij
8653 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8654 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8655                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8656                 if (wcorr4.gt.0.0d0) &
8657                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8658                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8659                        write (iout,'(a6,4i5,0pf7.3)') &
8660                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8661 !                write (iout,*) "gradcorr5 before eello5"
8662 !                do iii=1,nres
8663 !                  write (iout,'(i5,3f10.5)')
8664 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8665 !                enddo
8666                 if (wcorr5.gt.0.0d0) &
8667                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8668 !                write (iout,*) "gradcorr5 after eello5"
8669 !                do iii=1,nres
8670 !                  write (iout,'(i5,3f10.5)')
8671 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8672 !                enddo
8673                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8674                        write (iout,'(a6,4i5,0pf7.3)') &
8675                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8676 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8677 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8678                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8679                      .or. wturn6.eq.0.0d0))then
8680 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8681                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8682                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8683                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8684 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8685 !d     &            'ecorr6=',ecorr6
8686 !d                write (iout,'(4e15.5)') sred_geom,
8687 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8688 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8689 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8690                 else if (wturn6.gt.0.0d0 &
8691                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8692 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8693                   eturn6=eturn6+eello_turn6(i,jj,kk)
8694                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8695                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8696 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8697                 endif
8698               ENDIF
8699 1111          continue
8700             endif
8701           enddo ! kk
8702         enddo ! jj
8703       enddo ! i
8704       do i=1,nres
8705         num_cont_hb(i)=num_cont_hb_old(i)
8706       enddo
8707 !                write (iout,*) "gradcorr5 in eello5"
8708 !                do iii=1,nres
8709 !                  write (iout,'(i5,3f10.5)')
8710 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8711 !                enddo
8712       return
8713       end subroutine multibody_eello
8714 !-----------------------------------------------------------------------------
8715       subroutine add_hb_contact_eello(ii,jj,itask)
8716 !      implicit real*8 (a-h,o-z)
8717 !      include "DIMENSIONS"
8718 !      include "COMMON.IOUNITS"
8719 !      include "COMMON.CONTACTS"
8720 !      integer,parameter :: maxconts=nres/4
8721       integer,parameter :: max_dim=70
8722       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8723 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8724 !      common /przechowalnia/ zapas
8725
8726       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8727       integer,dimension(4) ::itask
8728 !      write (iout,*) "itask",itask
8729       do i=1,2
8730         iproc=itask(i)
8731         if (iproc.gt.0) then
8732           do j=1,num_cont_hb(ii)
8733             jjc=jcont_hb(j,ii)
8734 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8735             if (jjc.eq.jj) then
8736               ncont_sent(iproc)=ncont_sent(iproc)+1
8737               nn=ncont_sent(iproc)
8738               zapas(1,nn,iproc)=ii
8739               zapas(2,nn,iproc)=jjc
8740               zapas(3,nn,iproc)=d_cont(j,ii)
8741               ind=3
8742               do kk=1,3
8743                 ind=ind+1
8744                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8745               enddo
8746               do kk=1,2
8747                 do ll=1,2
8748                   ind=ind+1
8749                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8750                 enddo
8751               enddo
8752               do jj=1,5
8753                 do kk=1,3
8754                   do ll=1,2
8755                     do mm=1,2
8756                       ind=ind+1
8757                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8758                     enddo
8759                   enddo
8760                 enddo
8761               enddo
8762               exit
8763             endif
8764           enddo
8765         endif
8766       enddo
8767       return
8768       end subroutine add_hb_contact_eello
8769 !-----------------------------------------------------------------------------
8770       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8771 !      implicit real*8 (a-h,o-z)
8772 !      include 'DIMENSIONS'
8773 !      include 'COMMON.IOUNITS'
8774 !      include 'COMMON.DERIV'
8775 !      include 'COMMON.INTERACT'
8776 !      include 'COMMON.CONTACTS'
8777       real(kind=8),dimension(3) :: gx,gx1
8778       logical :: lprn
8779 !el local variables
8780       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8781       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8782                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8783                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8784                    rlocshield
8785
8786       lprn=.false.
8787       eij=facont_hb(jj,i)
8788       ekl=facont_hb(kk,k)
8789       ees0pij=ees0p(jj,i)
8790       ees0pkl=ees0p(kk,k)
8791       ees0mij=ees0m(jj,i)
8792       ees0mkl=ees0m(kk,k)
8793       ekont=eij*ekl
8794       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8795 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8796 ! Following 4 lines for diagnostics.
8797 !d    ees0pkl=0.0D0
8798 !d    ees0pij=1.0D0
8799 !d    ees0mkl=0.0D0
8800 !d    ees0mij=1.0D0
8801 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8802 !     & 'Contacts ',i,j,
8803 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8804 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8805 !     & 'gradcorr_long'
8806 ! Calculate the multi-body contribution to energy.
8807 !      ecorr=ecorr+ekont*ees
8808 ! Calculate multi-body contributions to the gradient.
8809       coeffpees0pij=coeffp*ees0pij
8810       coeffmees0mij=coeffm*ees0mij
8811       coeffpees0pkl=coeffp*ees0pkl
8812       coeffmees0mkl=coeffm*ees0mkl
8813       do ll=1,3
8814 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8815         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8816         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8817         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8818         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8819         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8820         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8821 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8822         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8823         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8824         coeffmees0mij*gacontm_hb1(ll,kk,k))
8825         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8826         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8827         coeffmees0mij*gacontm_hb2(ll,kk,k))
8828         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8829            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8830            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8831         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8832         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8833         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8834            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8835            coeffmees0mij*gacontm_hb3(ll,kk,k))
8836         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8837         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8838 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8839       enddo
8840 !      write (iout,*)
8841 !grad      do m=i+1,j-1
8842 !grad        do ll=1,3
8843 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8844 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8845 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8846 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8847 !grad        enddo
8848 !grad      enddo
8849 !grad      do m=k+1,l-1
8850 !grad        do ll=1,3
8851 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8852 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8853 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8854 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8855 !grad        enddo
8856 !grad      enddo
8857 !      write (iout,*) "ehbcorr",ekont*ees
8858       ehbcorr=ekont*ees
8859       if (shield_mode.gt.0) then
8860        j=ees0plist(jj,i)
8861        l=ees0plist(kk,k)
8862 !C        print *,i,j,fac_shield(i),fac_shield(j),
8863 !C     &fac_shield(k),fac_shield(l)
8864         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8865            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8866           do ilist=1,ishield_list(i)
8867            iresshield=shield_list(ilist,i)
8868            do m=1,3
8869            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8870            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8871                    rlocshield  &
8872             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8873             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8874             +rlocshield
8875            enddo
8876           enddo
8877           do ilist=1,ishield_list(j)
8878            iresshield=shield_list(ilist,j)
8879            do m=1,3
8880            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8881            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8882                    rlocshield &
8883             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8884            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8885             +rlocshield
8886            enddo
8887           enddo
8888
8889           do ilist=1,ishield_list(k)
8890            iresshield=shield_list(ilist,k)
8891            do m=1,3
8892            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8893            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8894                    rlocshield &
8895             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8896            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8897             +rlocshield
8898            enddo
8899           enddo
8900           do ilist=1,ishield_list(l)
8901            iresshield=shield_list(ilist,l)
8902            do m=1,3
8903            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8904            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8905                    rlocshield &
8906             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8907            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8908             +rlocshield
8909            enddo
8910           enddo
8911           do m=1,3
8912             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8913                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8914             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8915                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8916             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8917                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8918             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8919                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8920
8921             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8922                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8923             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8924                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8925             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8926                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8927             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8928                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8929
8930            enddo
8931       endif
8932       endif
8933       return
8934       end function ehbcorr
8935 #ifdef MOMENT
8936 !-----------------------------------------------------------------------------
8937       subroutine dipole(i,j,jj)
8938 !      implicit real*8 (a-h,o-z)
8939 !      include 'DIMENSIONS'
8940 !      include 'COMMON.IOUNITS'
8941 !      include 'COMMON.CHAIN'
8942 !      include 'COMMON.FFIELD'
8943 !      include 'COMMON.DERIV'
8944 !      include 'COMMON.INTERACT'
8945 !      include 'COMMON.CONTACTS'
8946 !      include 'COMMON.TORSION'
8947 !      include 'COMMON.VAR'
8948 !      include 'COMMON.GEO'
8949       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8950       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8951       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8952
8953       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8954       allocate(dipderx(3,5,4,maxconts,nres))
8955 !
8956
8957       iti1 = itortyp(itype(i+1,1))
8958       if (j.lt.nres-1) then
8959         itj1 = itype2loc(itype(j+1,1))
8960       else
8961         itj1=nloctyp
8962       endif
8963       do iii=1,2
8964         dipi(iii,1)=Ub2(iii,i)
8965         dipderi(iii)=Ub2der(iii,i)
8966         dipi(iii,2)=b1(iii,iti1)
8967         dipj(iii,1)=Ub2(iii,j)
8968         dipderj(iii)=Ub2der(iii,j)
8969         dipj(iii,2)=b1(iii,itj1)
8970       enddo
8971       kkk=0
8972       do iii=1,2
8973         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8974         do jjj=1,2
8975           kkk=kkk+1
8976           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8977         enddo
8978       enddo
8979       do kkk=1,5
8980         do lll=1,3
8981           mmm=0
8982           do iii=1,2
8983             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8984               auxvec(1))
8985             do jjj=1,2
8986               mmm=mmm+1
8987               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8988             enddo
8989           enddo
8990         enddo
8991       enddo
8992       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8993       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8994       do iii=1,2
8995         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8996       enddo
8997       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8998       do iii=1,2
8999         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9000       enddo
9001       return
9002       end subroutine dipole
9003 #endif
9004 !-----------------------------------------------------------------------------
9005       subroutine calc_eello(i,j,k,l,jj,kk)
9006 !
9007 ! This subroutine computes matrices and vectors needed to calculate
9008 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9009 !
9010       use comm_kut
9011 !      implicit real*8 (a-h,o-z)
9012 !      include 'DIMENSIONS'
9013 !      include 'COMMON.IOUNITS'
9014 !      include 'COMMON.CHAIN'
9015 !      include 'COMMON.DERIV'
9016 !      include 'COMMON.INTERACT'
9017 !      include 'COMMON.CONTACTS'
9018 !      include 'COMMON.TORSION'
9019 !      include 'COMMON.VAR'
9020 !      include 'COMMON.GEO'
9021 !      include 'COMMON.FFIELD'
9022       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9023       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9024       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9025               itj1
9026 !el      logical :: lprn
9027 !el      common /kutas/ lprn
9028 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9029 !d     & ' jj=',jj,' kk=',kk
9030 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9031 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9032 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9033       do iii=1,2
9034         do jjj=1,2
9035           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9036           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9037         enddo
9038       enddo
9039       call transpose2(aa1(1,1),aa1t(1,1))
9040       call transpose2(aa2(1,1),aa2t(1,1))
9041       do kkk=1,5
9042         do lll=1,3
9043           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9044             aa1tder(1,1,lll,kkk))
9045           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9046             aa2tder(1,1,lll,kkk))
9047         enddo
9048       enddo
9049       if (l.eq.j+1) then
9050 ! parallel orientation of the two CA-CA-CA frames.
9051         if (i.gt.1) then
9052           iti=itortyp(itype(i,1))
9053         else
9054           iti=ntortyp+1
9055         endif
9056         itk1=itortyp(itype(k+1,1))
9057         itj=itortyp(itype(j,1))
9058         if (l.lt.nres-1) then
9059           itl1=itortyp(itype(l+1,1))
9060         else
9061           itl1=ntortyp+1
9062         endif
9063 ! A1 kernel(j+1) A2T
9064 !d        do iii=1,2
9065 !d          write (iout,'(3f10.5,5x,3f10.5)')
9066 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9067 !d        enddo
9068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9069          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9070          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9071 ! Following matrices are needed only for 6-th order cumulants
9072         IF (wcorr6.gt.0.0d0) THEN
9073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9074          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9075          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9077          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9078          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9079          ADtEAderx(1,1,1,1,1,1))
9080         lprn=.false.
9081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9082          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9083          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9084          ADtEA1derx(1,1,1,1,1,1))
9085         ENDIF
9086 ! End 6-th order cumulants
9087 !d        lprn=.false.
9088 !d        if (lprn) then
9089 !d        write (2,*) 'In calc_eello6'
9090 !d        do iii=1,2
9091 !d          write (2,*) 'iii=',iii
9092 !d          do kkk=1,5
9093 !d            write (2,*) 'kkk=',kkk
9094 !d            do jjj=1,2
9095 !d              write (2,'(3(2f10.5),5x)')
9096 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9097 !d            enddo
9098 !d          enddo
9099 !d        enddo
9100 !d        endif
9101         call transpose2(EUgder(1,1,k),auxmat(1,1))
9102         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9103         call transpose2(EUg(1,1,k),auxmat(1,1))
9104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9105         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9106         do iii=1,2
9107           do kkk=1,5
9108             do lll=1,3
9109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9110                 EAEAderx(1,1,lll,kkk,iii,1))
9111             enddo
9112           enddo
9113         enddo
9114 ! A1T kernel(i+1) A2
9115         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9116          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9117          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9118 ! Following matrices are needed only for 6-th order cumulants
9119         IF (wcorr6.gt.0.0d0) THEN
9120         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9121          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9122          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9123         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9124          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9125          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9126          ADtEAderx(1,1,1,1,1,2))
9127         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9128          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9129          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9130          ADtEA1derx(1,1,1,1,1,2))
9131         ENDIF
9132 ! End 6-th order cumulants
9133         call transpose2(EUgder(1,1,l),auxmat(1,1))
9134         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9135         call transpose2(EUg(1,1,l),auxmat(1,1))
9136         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9137         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9138         do iii=1,2
9139           do kkk=1,5
9140             do lll=1,3
9141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9142                 EAEAderx(1,1,lll,kkk,iii,2))
9143             enddo
9144           enddo
9145         enddo
9146 ! AEAb1 and AEAb2
9147 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9148 ! They are needed only when the fifth- or the sixth-order cumulants are
9149 ! indluded.
9150         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9151         call transpose2(AEA(1,1,1),auxmat(1,1))
9152         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9153         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9154         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9155         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9156         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9157         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9158         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9159         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9160         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9161         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9162         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9163         call transpose2(AEA(1,1,2),auxmat(1,1))
9164         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9165         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9166         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9167         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9168         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9169         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9170         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9171         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9172         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9173         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9174         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9175 ! Calculate the Cartesian derivatives of the vectors.
9176         do iii=1,2
9177           do kkk=1,5
9178             do lll=1,3
9179               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9180               call matvec2(auxmat(1,1),b1(1,iti),&
9181                 AEAb1derx(1,lll,kkk,iii,1,1))
9182               call matvec2(auxmat(1,1),Ub2(1,i),&
9183                 AEAb2derx(1,lll,kkk,iii,1,1))
9184               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9185                 AEAb1derx(1,lll,kkk,iii,2,1))
9186               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9187                 AEAb2derx(1,lll,kkk,iii,2,1))
9188               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9189               call matvec2(auxmat(1,1),b1(1,itj),&
9190                 AEAb1derx(1,lll,kkk,iii,1,2))
9191               call matvec2(auxmat(1,1),Ub2(1,j),&
9192                 AEAb2derx(1,lll,kkk,iii,1,2))
9193               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9194                 AEAb1derx(1,lll,kkk,iii,2,2))
9195               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9196                 AEAb2derx(1,lll,kkk,iii,2,2))
9197             enddo
9198           enddo
9199         enddo
9200         ENDIF
9201 ! End vectors
9202       else
9203 ! Antiparallel orientation of the two CA-CA-CA frames.
9204         if (i.gt.1) then
9205           iti=itortyp(itype(i,1))
9206         else
9207           iti=ntortyp+1
9208         endif
9209         itk1=itortyp(itype(k+1,1))
9210         itl=itortyp(itype(l,1))
9211         itj=itortyp(itype(j,1))
9212         if (j.lt.nres-1) then
9213           itj1=itortyp(itype(j+1,1))
9214         else
9215           itj1=ntortyp+1
9216         endif
9217 ! A2 kernel(j-1)T A1T
9218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9219          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9220          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9221 ! Following matrices are needed only for 6-th order cumulants
9222         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9223            j.eq.i+4 .and. l.eq.i+3)) THEN
9224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9225          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9226          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9227         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9228          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9229          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9230          ADtEAderx(1,1,1,1,1,1))
9231         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9232          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9233          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9234          ADtEA1derx(1,1,1,1,1,1))
9235         ENDIF
9236 ! End 6-th order cumulants
9237         call transpose2(EUgder(1,1,k),auxmat(1,1))
9238         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9239         call transpose2(EUg(1,1,k),auxmat(1,1))
9240         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9241         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9242         do iii=1,2
9243           do kkk=1,5
9244             do lll=1,3
9245               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9246                 EAEAderx(1,1,lll,kkk,iii,1))
9247             enddo
9248           enddo
9249         enddo
9250 ! A2T kernel(i+1)T A1
9251         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9252          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9253          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9254 ! Following matrices are needed only for 6-th order cumulants
9255         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9256            j.eq.i+4 .and. l.eq.i+3)) THEN
9257         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9258          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9259          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9260         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9261          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9262          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9263          ADtEAderx(1,1,1,1,1,2))
9264         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9265          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9266          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9267          ADtEA1derx(1,1,1,1,1,2))
9268         ENDIF
9269 ! End 6-th order cumulants
9270         call transpose2(EUgder(1,1,j),auxmat(1,1))
9271         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9272         call transpose2(EUg(1,1,j),auxmat(1,1))
9273         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9274         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9275         do iii=1,2
9276           do kkk=1,5
9277             do lll=1,3
9278               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9279                 EAEAderx(1,1,lll,kkk,iii,2))
9280             enddo
9281           enddo
9282         enddo
9283 ! AEAb1 and AEAb2
9284 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9285 ! They are needed only when the fifth- or the sixth-order cumulants are
9286 ! indluded.
9287         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9288           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9289         call transpose2(AEA(1,1,1),auxmat(1,1))
9290         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9291         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9292         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9293         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9294         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9295         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9296         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9297         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9298         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9299         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9300         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9301         call transpose2(AEA(1,1,2),auxmat(1,1))
9302         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9303         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9304         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9305         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9306         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9307         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9308         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9309         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9310         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9311         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9312         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9313 ! Calculate the Cartesian derivatives of the vectors.
9314         do iii=1,2
9315           do kkk=1,5
9316             do lll=1,3
9317               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9318               call matvec2(auxmat(1,1),b1(1,iti),&
9319                 AEAb1derx(1,lll,kkk,iii,1,1))
9320               call matvec2(auxmat(1,1),Ub2(1,i),&
9321                 AEAb2derx(1,lll,kkk,iii,1,1))
9322               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9323                 AEAb1derx(1,lll,kkk,iii,2,1))
9324               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9325                 AEAb2derx(1,lll,kkk,iii,2,1))
9326               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9327               call matvec2(auxmat(1,1),b1(1,itl),&
9328                 AEAb1derx(1,lll,kkk,iii,1,2))
9329               call matvec2(auxmat(1,1),Ub2(1,l),&
9330                 AEAb2derx(1,lll,kkk,iii,1,2))
9331               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9332                 AEAb1derx(1,lll,kkk,iii,2,2))
9333               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9334                 AEAb2derx(1,lll,kkk,iii,2,2))
9335             enddo
9336           enddo
9337         enddo
9338         ENDIF
9339 ! End vectors
9340       endif
9341       return
9342       end subroutine calc_eello
9343 !-----------------------------------------------------------------------------
9344       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9345       use comm_kut
9346       implicit none
9347       integer :: nderg
9348       logical :: transp
9349       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9350       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9351       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9352       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9353       integer :: iii,kkk,lll
9354       integer :: jjj,mmm
9355 !el      logical :: lprn
9356 !el      common /kutas/ lprn
9357       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9358       do iii=1,nderg
9359         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9360           AKAderg(1,1,iii))
9361       enddo
9362 !d      if (lprn) write (2,*) 'In kernel'
9363       do kkk=1,5
9364 !d        if (lprn) write (2,*) 'kkk=',kkk
9365         do lll=1,3
9366           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9367             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9368 !d          if (lprn) then
9369 !d            write (2,*) 'lll=',lll
9370 !d            write (2,*) 'iii=1'
9371 !d            do jjj=1,2
9372 !d              write (2,'(3(2f10.5),5x)')
9373 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9374 !d            enddo
9375 !d          endif
9376           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9377             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9378 !d          if (lprn) then
9379 !d            write (2,*) 'lll=',lll
9380 !d            write (2,*) 'iii=2'
9381 !d            do jjj=1,2
9382 !d              write (2,'(3(2f10.5),5x)')
9383 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9384 !d            enddo
9385 !d          endif
9386         enddo
9387       enddo
9388       return
9389       end subroutine kernel
9390 !-----------------------------------------------------------------------------
9391       real(kind=8) function eello4(i,j,k,l,jj,kk)
9392 !      implicit real*8 (a-h,o-z)
9393 !      include 'DIMENSIONS'
9394 !      include 'COMMON.IOUNITS'
9395 !      include 'COMMON.CHAIN'
9396 !      include 'COMMON.DERIV'
9397 !      include 'COMMON.INTERACT'
9398 !      include 'COMMON.CONTACTS'
9399 !      include 'COMMON.TORSION'
9400 !      include 'COMMON.VAR'
9401 !      include 'COMMON.GEO'
9402       real(kind=8),dimension(2,2) :: pizda
9403       real(kind=8),dimension(3) :: ggg1,ggg2
9404       real(kind=8) ::  eel4,glongij,glongkl
9405       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9406 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9407 !d        eello4=0.0d0
9408 !d        return
9409 !d      endif
9410 !d      print *,'eello4:',i,j,k,l,jj,kk
9411 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9412 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9413 !old      eij=facont_hb(jj,i)
9414 !old      ekl=facont_hb(kk,k)
9415 !old      ekont=eij*ekl
9416       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9417 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9418       gcorr_loc(k-1)=gcorr_loc(k-1) &
9419          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9420       if (l.eq.j+1) then
9421         gcorr_loc(l-1)=gcorr_loc(l-1) &
9422            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9423       else
9424         gcorr_loc(j-1)=gcorr_loc(j-1) &
9425            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9426       endif
9427       do iii=1,2
9428         do kkk=1,5
9429           do lll=1,3
9430             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9431                               -EAEAderx(2,2,lll,kkk,iii,1)
9432 !d            derx(lll,kkk,iii)=0.0d0
9433           enddo
9434         enddo
9435       enddo
9436 !d      gcorr_loc(l-1)=0.0d0
9437 !d      gcorr_loc(j-1)=0.0d0
9438 !d      gcorr_loc(k-1)=0.0d0
9439 !d      eel4=1.0d0
9440 !d      write (iout,*)'Contacts have occurred for peptide groups',
9441 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9442 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9443       if (j.lt.nres-1) then
9444         j1=j+1
9445         j2=j-1
9446       else
9447         j1=j-1
9448         j2=j-2
9449       endif
9450       if (l.lt.nres-1) then
9451         l1=l+1
9452         l2=l-1
9453       else
9454         l1=l-1
9455         l2=l-2
9456       endif
9457       do ll=1,3
9458 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9459 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9460         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9461         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9462 !grad        ghalf=0.5d0*ggg1(ll)
9463         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9464         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9465         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9466         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9467         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9468         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9469 !grad        ghalf=0.5d0*ggg2(ll)
9470         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9471         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9472         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9473         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9474         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9475         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9476       enddo
9477 !grad      do m=i+1,j-1
9478 !grad        do ll=1,3
9479 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9480 !grad        enddo
9481 !grad      enddo
9482 !grad      do m=k+1,l-1
9483 !grad        do ll=1,3
9484 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9485 !grad        enddo
9486 !grad      enddo
9487 !grad      do m=i+2,j2
9488 !grad        do ll=1,3
9489 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9490 !grad        enddo
9491 !grad      enddo
9492 !grad      do m=k+2,l2
9493 !grad        do ll=1,3
9494 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9495 !grad        enddo
9496 !grad      enddo
9497 !d      do iii=1,nres-3
9498 !d        write (2,*) iii,gcorr_loc(iii)
9499 !d      enddo
9500       eello4=ekont*eel4
9501 !d      write (2,*) 'ekont',ekont
9502 !d      write (iout,*) 'eello4',ekont*eel4
9503       return
9504       end function eello4
9505 !-----------------------------------------------------------------------------
9506       real(kind=8) function eello5(i,j,k,l,jj,kk)
9507 !      implicit real*8 (a-h,o-z)
9508 !      include 'DIMENSIONS'
9509 !      include 'COMMON.IOUNITS'
9510 !      include 'COMMON.CHAIN'
9511 !      include 'COMMON.DERIV'
9512 !      include 'COMMON.INTERACT'
9513 !      include 'COMMON.CONTACTS'
9514 !      include 'COMMON.TORSION'
9515 !      include 'COMMON.VAR'
9516 !      include 'COMMON.GEO'
9517       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9518       real(kind=8),dimension(2) :: vv
9519       real(kind=8),dimension(3) :: ggg1,ggg2
9520       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9521       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9522       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9523 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9524 !                                                                              C
9525 !                            Parallel chains                                   C
9526 !                                                                              C
9527 !          o             o                   o             o                   C
9528 !         /l\           / \             \   / \           / \   /              C
9529 !        /   \         /   \             \ /   \         /   \ /               C
9530 !       j| o |l1       | o |                o| o |         | o |o                C
9531 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9532 !      \i/   \         /   \ /             /   \         /   \                 C
9533 !       o    k1             o                                                  C
9534 !         (I)          (II)                (III)          (IV)                 C
9535 !                                                                              C
9536 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9537 !                                                                              C
9538 !                            Antiparallel chains                               C
9539 !                                                                              C
9540 !          o             o                   o             o                   C
9541 !         /j\           / \             \   / \           / \   /              C
9542 !        /   \         /   \             \ /   \         /   \ /               C
9543 !      j1| o |l        | o |                o| o |         | o |o                C
9544 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9545 !      \i/   \         /   \ /             /   \         /   \                 C
9546 !       o     k1            o                                                  C
9547 !         (I)          (II)                (III)          (IV)                 C
9548 !                                                                              C
9549 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9550 !                                                                              C
9551 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9552 !                                                                              C
9553 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9554 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9555 !d        eello5=0.0d0
9556 !d        return
9557 !d      endif
9558 !d      write (iout,*)
9559 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9560 !d     &   ' and',k,l
9561       itk=itortyp(itype(k,1))
9562       itl=itortyp(itype(l,1))
9563       itj=itortyp(itype(j,1))
9564       eello5_1=0.0d0
9565       eello5_2=0.0d0
9566       eello5_3=0.0d0
9567       eello5_4=0.0d0
9568 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9569 !d     &   eel5_3_num,eel5_4_num)
9570       do iii=1,2
9571         do kkk=1,5
9572           do lll=1,3
9573             derx(lll,kkk,iii)=0.0d0
9574           enddo
9575         enddo
9576       enddo
9577 !d      eij=facont_hb(jj,i)
9578 !d      ekl=facont_hb(kk,k)
9579 !d      ekont=eij*ekl
9580 !d      write (iout,*)'Contacts have occurred for peptide groups',
9581 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9582 !d      goto 1111
9583 ! Contribution from the graph I.
9584 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9585 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9586       call transpose2(EUg(1,1,k),auxmat(1,1))
9587       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9588       vv(1)=pizda(1,1)-pizda(2,2)
9589       vv(2)=pizda(1,2)+pizda(2,1)
9590       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9591        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9592 ! Explicit gradient in virtual-dihedral angles.
9593       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9594        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9595        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9596       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9597       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9598       vv(1)=pizda(1,1)-pizda(2,2)
9599       vv(2)=pizda(1,2)+pizda(2,1)
9600       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9601        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9602        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9603       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9604       vv(1)=pizda(1,1)-pizda(2,2)
9605       vv(2)=pizda(1,2)+pizda(2,1)
9606       if (l.eq.j+1) then
9607         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9608          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9609          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9610       else
9611         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9612          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9613          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9614       endif
9615 ! Cartesian gradient
9616       do iii=1,2
9617         do kkk=1,5
9618           do lll=1,3
9619             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9620               pizda(1,1))
9621             vv(1)=pizda(1,1)-pizda(2,2)
9622             vv(2)=pizda(1,2)+pizda(2,1)
9623             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9624              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9625              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9626           enddo
9627         enddo
9628       enddo
9629 !      goto 1112
9630 !1111  continue
9631 ! Contribution from graph II
9632       call transpose2(EE(1,1,itk),auxmat(1,1))
9633       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9634       vv(1)=pizda(1,1)+pizda(2,2)
9635       vv(2)=pizda(2,1)-pizda(1,2)
9636       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9637        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9638 ! Explicit gradient in virtual-dihedral angles.
9639       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9640        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9641       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9642       vv(1)=pizda(1,1)+pizda(2,2)
9643       vv(2)=pizda(2,1)-pizda(1,2)
9644       if (l.eq.j+1) then
9645         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9646          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9647          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9648       else
9649         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9650          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9651          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9652       endif
9653 ! Cartesian gradient
9654       do iii=1,2
9655         do kkk=1,5
9656           do lll=1,3
9657             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9658               pizda(1,1))
9659             vv(1)=pizda(1,1)+pizda(2,2)
9660             vv(2)=pizda(2,1)-pizda(1,2)
9661             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9662              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9663              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9664           enddo
9665         enddo
9666       enddo
9667 !d      goto 1112
9668 !d1111  continue
9669       if (l.eq.j+1) then
9670 !d        goto 1110
9671 ! Parallel orientation
9672 ! Contribution from graph III
9673         call transpose2(EUg(1,1,l),auxmat(1,1))
9674         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9675         vv(1)=pizda(1,1)-pizda(2,2)
9676         vv(2)=pizda(1,2)+pizda(2,1)
9677         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9678          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9679 ! Explicit gradient in virtual-dihedral angles.
9680         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9681          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9682          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9683         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9684         vv(1)=pizda(1,1)-pizda(2,2)
9685         vv(2)=pizda(1,2)+pizda(2,1)
9686         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9687          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9688          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9689         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9690         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9691         vv(1)=pizda(1,1)-pizda(2,2)
9692         vv(2)=pizda(1,2)+pizda(2,1)
9693         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9694          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9695          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9696 ! Cartesian gradient
9697         do iii=1,2
9698           do kkk=1,5
9699             do lll=1,3
9700               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9701                 pizda(1,1))
9702               vv(1)=pizda(1,1)-pizda(2,2)
9703               vv(2)=pizda(1,2)+pizda(2,1)
9704               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9705                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9706                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9707             enddo
9708           enddo
9709         enddo
9710 !d        goto 1112
9711 ! Contribution from graph IV
9712 !d1110    continue
9713         call transpose2(EE(1,1,itl),auxmat(1,1))
9714         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9715         vv(1)=pizda(1,1)+pizda(2,2)
9716         vv(2)=pizda(2,1)-pizda(1,2)
9717         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9718          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9719 ! Explicit gradient in virtual-dihedral angles.
9720         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9721          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9722         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9723         vv(1)=pizda(1,1)+pizda(2,2)
9724         vv(2)=pizda(2,1)-pizda(1,2)
9725         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9726          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9727          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9728 ! Cartesian gradient
9729         do iii=1,2
9730           do kkk=1,5
9731             do lll=1,3
9732               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9733                 pizda(1,1))
9734               vv(1)=pizda(1,1)+pizda(2,2)
9735               vv(2)=pizda(2,1)-pizda(1,2)
9736               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9737                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9738                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9739             enddo
9740           enddo
9741         enddo
9742       else
9743 ! Antiparallel orientation
9744 ! Contribution from graph III
9745 !        goto 1110
9746         call transpose2(EUg(1,1,j),auxmat(1,1))
9747         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9748         vv(1)=pizda(1,1)-pizda(2,2)
9749         vv(2)=pizda(1,2)+pizda(2,1)
9750         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9751          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9752 ! Explicit gradient in virtual-dihedral angles.
9753         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9754          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9755          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9756         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9757         vv(1)=pizda(1,1)-pizda(2,2)
9758         vv(2)=pizda(1,2)+pizda(2,1)
9759         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9760          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9761          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9762         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9763         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9764         vv(1)=pizda(1,1)-pizda(2,2)
9765         vv(2)=pizda(1,2)+pizda(2,1)
9766         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9767          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9768          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9769 ! Cartesian gradient
9770         do iii=1,2
9771           do kkk=1,5
9772             do lll=1,3
9773               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9774                 pizda(1,1))
9775               vv(1)=pizda(1,1)-pizda(2,2)
9776               vv(2)=pizda(1,2)+pizda(2,1)
9777               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9778                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9779                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9780             enddo
9781           enddo
9782         enddo
9783 !d        goto 1112
9784 ! Contribution from graph IV
9785 1110    continue
9786         call transpose2(EE(1,1,itj),auxmat(1,1))
9787         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9788         vv(1)=pizda(1,1)+pizda(2,2)
9789         vv(2)=pizda(2,1)-pizda(1,2)
9790         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9791          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9792 ! Explicit gradient in virtual-dihedral angles.
9793         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9794          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9795         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9796         vv(1)=pizda(1,1)+pizda(2,2)
9797         vv(2)=pizda(2,1)-pizda(1,2)
9798         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9799          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9800          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9801 ! Cartesian gradient
9802         do iii=1,2
9803           do kkk=1,5
9804             do lll=1,3
9805               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9806                 pizda(1,1))
9807               vv(1)=pizda(1,1)+pizda(2,2)
9808               vv(2)=pizda(2,1)-pizda(1,2)
9809               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9810                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9811                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9812             enddo
9813           enddo
9814         enddo
9815       endif
9816 1112  continue
9817       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9818 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9819 !d        write (2,*) 'ijkl',i,j,k,l
9820 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9821 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9822 !d      endif
9823 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9824 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9825 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9826 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9827       if (j.lt.nres-1) then
9828         j1=j+1
9829         j2=j-1
9830       else
9831         j1=j-1
9832         j2=j-2
9833       endif
9834       if (l.lt.nres-1) then
9835         l1=l+1
9836         l2=l-1
9837       else
9838         l1=l-1
9839         l2=l-2
9840       endif
9841 !d      eij=1.0d0
9842 !d      ekl=1.0d0
9843 !d      ekont=1.0d0
9844 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9845 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9846 !        summed up outside the subrouine as for the other subroutines
9847 !        handling long-range interactions. The old code is commented out
9848 !        with "cgrad" to keep track of changes.
9849       do ll=1,3
9850 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9851 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9852         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9853         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9854 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9855 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9856 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9857 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9858 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9859 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9860 !     &   gradcorr5ij,
9861 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9862 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9863 !grad        ghalf=0.5d0*ggg1(ll)
9864 !d        ghalf=0.0d0
9865         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9866         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9867         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9868         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9869         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9870         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9871 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9872 !grad        ghalf=0.5d0*ggg2(ll)
9873         ghalf=0.0d0
9874         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9875         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9876         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9877         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9878         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9879         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9880       enddo
9881 !d      goto 1112
9882 !grad      do m=i+1,j-1
9883 !grad        do ll=1,3
9884 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9885 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9886 !grad        enddo
9887 !grad      enddo
9888 !grad      do m=k+1,l-1
9889 !grad        do ll=1,3
9890 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9891 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9892 !grad        enddo
9893 !grad      enddo
9894 !1112  continue
9895 !grad      do m=i+2,j2
9896 !grad        do ll=1,3
9897 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9898 !grad        enddo
9899 !grad      enddo
9900 !grad      do m=k+2,l2
9901 !grad        do ll=1,3
9902 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9903 !grad        enddo
9904 !grad      enddo
9905 !d      do iii=1,nres-3
9906 !d        write (2,*) iii,g_corr5_loc(iii)
9907 !d      enddo
9908       eello5=ekont*eel5
9909 !d      write (2,*) 'ekont',ekont
9910 !d      write (iout,*) 'eello5',ekont*eel5
9911       return
9912       end function eello5
9913 !-----------------------------------------------------------------------------
9914       real(kind=8) function eello6(i,j,k,l,jj,kk)
9915 !      implicit real*8 (a-h,o-z)
9916 !      include 'DIMENSIONS'
9917 !      include 'COMMON.IOUNITS'
9918 !      include 'COMMON.CHAIN'
9919 !      include 'COMMON.DERIV'
9920 !      include 'COMMON.INTERACT'
9921 !      include 'COMMON.CONTACTS'
9922 !      include 'COMMON.TORSION'
9923 !      include 'COMMON.VAR'
9924 !      include 'COMMON.GEO'
9925 !      include 'COMMON.FFIELD'
9926       real(kind=8),dimension(3) :: ggg1,ggg2
9927       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9928                    eello6_6,eel6
9929       real(kind=8) :: gradcorr6ij,gradcorr6kl
9930       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9931 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9932 !d        eello6=0.0d0
9933 !d        return
9934 !d      endif
9935 !d      write (iout,*)
9936 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9937 !d     &   ' and',k,l
9938       eello6_1=0.0d0
9939       eello6_2=0.0d0
9940       eello6_3=0.0d0
9941       eello6_4=0.0d0
9942       eello6_5=0.0d0
9943       eello6_6=0.0d0
9944 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9945 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9946       do iii=1,2
9947         do kkk=1,5
9948           do lll=1,3
9949             derx(lll,kkk,iii)=0.0d0
9950           enddo
9951         enddo
9952       enddo
9953 !d      eij=facont_hb(jj,i)
9954 !d      ekl=facont_hb(kk,k)
9955 !d      ekont=eij*ekl
9956 !d      eij=1.0d0
9957 !d      ekl=1.0d0
9958 !d      ekont=1.0d0
9959       if (l.eq.j+1) then
9960         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9961         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9962         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9963         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9964         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9965         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9966       else
9967         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9968         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9969         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9970         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9971         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9972           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9973         else
9974           eello6_5=0.0d0
9975         endif
9976         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9977       endif
9978 ! If turn contributions are considered, they will be handled separately.
9979       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9980 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9981 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9982 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9983 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9984 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9985 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9986 !d      goto 1112
9987       if (j.lt.nres-1) then
9988         j1=j+1
9989         j2=j-1
9990       else
9991         j1=j-1
9992         j2=j-2
9993       endif
9994       if (l.lt.nres-1) then
9995         l1=l+1
9996         l2=l-1
9997       else
9998         l1=l-1
9999         l2=l-2
10000       endif
10001       do ll=1,3
10002 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10003 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10004 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10005 !grad        ghalf=0.5d0*ggg1(ll)
10006 !d        ghalf=0.0d0
10007         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10008         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10009         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10010         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10011         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10012         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10013         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10014         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10015 !grad        ghalf=0.5d0*ggg2(ll)
10016 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10017 !d        ghalf=0.0d0
10018         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10019         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10020         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10021         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10022         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10023         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10024       enddo
10025 !d      goto 1112
10026 !grad      do m=i+1,j-1
10027 !grad        do ll=1,3
10028 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10029 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10030 !grad        enddo
10031 !grad      enddo
10032 !grad      do m=k+1,l-1
10033 !grad        do ll=1,3
10034 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10035 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10036 !grad        enddo
10037 !grad      enddo
10038 !grad1112  continue
10039 !grad      do m=i+2,j2
10040 !grad        do ll=1,3
10041 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10042 !grad        enddo
10043 !grad      enddo
10044 !grad      do m=k+2,l2
10045 !grad        do ll=1,3
10046 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10047 !grad        enddo
10048 !grad      enddo
10049 !d      do iii=1,nres-3
10050 !d        write (2,*) iii,g_corr6_loc(iii)
10051 !d      enddo
10052       eello6=ekont*eel6
10053 !d      write (2,*) 'ekont',ekont
10054 !d      write (iout,*) 'eello6',ekont*eel6
10055       return
10056       end function eello6
10057 !-----------------------------------------------------------------------------
10058       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10059       use comm_kut
10060 !      implicit real*8 (a-h,o-z)
10061 !      include 'DIMENSIONS'
10062 !      include 'COMMON.IOUNITS'
10063 !      include 'COMMON.CHAIN'
10064 !      include 'COMMON.DERIV'
10065 !      include 'COMMON.INTERACT'
10066 !      include 'COMMON.CONTACTS'
10067 !      include 'COMMON.TORSION'
10068 !      include 'COMMON.VAR'
10069 !      include 'COMMON.GEO'
10070       real(kind=8),dimension(2) :: vv,vv1
10071       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10072       logical :: swap
10073 !el      logical :: lprn
10074 !el      common /kutas/ lprn
10075       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10076       real(kind=8) :: s1,s2,s3,s4,s5
10077 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10078 !                                                                              C
10079 !      Parallel       Antiparallel                                             C
10080 !                                                                              C
10081 !          o             o                                                     C
10082 !         /l\           /j\                                                    C
10083 !        /   \         /   \                                                   C
10084 !       /| o |         | o |\                                                  C
10085 !     \ j|/k\|  /   \  |/k\|l /                                                C
10086 !      \ /   \ /     \ /   \ /                                                 C
10087 !       o     o       o     o                                                  C
10088 !       i             i                                                        C
10089 !                                                                              C
10090 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10091       itk=itortyp(itype(k,1))
10092       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10093       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10094       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10095       call transpose2(EUgC(1,1,k),auxmat(1,1))
10096       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10097       vv1(1)=pizda1(1,1)-pizda1(2,2)
10098       vv1(2)=pizda1(1,2)+pizda1(2,1)
10099       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10100       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10101       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10102       s5=scalar2(vv(1),Dtobr2(1,i))
10103 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10104       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10105       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10106        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10107        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10108        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10109        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10110        +scalar2(vv(1),Dtobr2der(1,i)))
10111       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10112       vv1(1)=pizda1(1,1)-pizda1(2,2)
10113       vv1(2)=pizda1(1,2)+pizda1(2,1)
10114       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10115       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10116       if (l.eq.j+1) then
10117         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10118        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10119        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10120        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10121        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10122       else
10123         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10124        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10125        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10126        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10127        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10128       endif
10129       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10130       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10131       vv1(1)=pizda1(1,1)-pizda1(2,2)
10132       vv1(2)=pizda1(1,2)+pizda1(2,1)
10133       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10134        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10135        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10136        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10137       do iii=1,2
10138         if (swap) then
10139           ind=3-iii
10140         else
10141           ind=iii
10142         endif
10143         do kkk=1,5
10144           do lll=1,3
10145             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10146             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10147             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10148             call transpose2(EUgC(1,1,k),auxmat(1,1))
10149             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10150               pizda1(1,1))
10151             vv1(1)=pizda1(1,1)-pizda1(2,2)
10152             vv1(2)=pizda1(1,2)+pizda1(2,1)
10153             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10154             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10155              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10156             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10157              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10158             s5=scalar2(vv(1),Dtobr2(1,i))
10159             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10160           enddo
10161         enddo
10162       enddo
10163       return
10164       end function eello6_graph1
10165 !-----------------------------------------------------------------------------
10166       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10167       use comm_kut
10168 !      implicit real*8 (a-h,o-z)
10169 !      include 'DIMENSIONS'
10170 !      include 'COMMON.IOUNITS'
10171 !      include 'COMMON.CHAIN'
10172 !      include 'COMMON.DERIV'
10173 !      include 'COMMON.INTERACT'
10174 !      include 'COMMON.CONTACTS'
10175 !      include 'COMMON.TORSION'
10176 !      include 'COMMON.VAR'
10177 !      include 'COMMON.GEO'
10178       logical :: swap
10179       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10180       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10181 !el      logical :: lprn
10182 !el      common /kutas/ lprn
10183       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10184       real(kind=8) :: s2,s3,s4
10185 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10186 !                                                                              C
10187 !      Parallel       Antiparallel                                             C
10188 !                                                                              C
10189 !          o             o                                                     C
10190 !     \   /l\           /j\   /                                                C
10191 !      \ /   \         /   \ /                                                 C
10192 !       o| o |         | o |o                                                  C
10193 !     \ j|/k\|      \  |/k\|l                                                  C
10194 !      \ /   \       \ /   \                                                   C
10195 !       o             o                                                        C
10196 !       i             i                                                        C
10197 !                                                                              C
10198 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10199 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10200 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10201 !           but not in a cluster cumulant
10202 #ifdef MOMENT
10203       s1=dip(1,jj,i)*dip(1,kk,k)
10204 #endif
10205       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10206       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10207       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10208       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10209       call transpose2(EUg(1,1,k),auxmat(1,1))
10210       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10211       vv(1)=pizda(1,1)-pizda(2,2)
10212       vv(2)=pizda(1,2)+pizda(2,1)
10213       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10214 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10215 #ifdef MOMENT
10216       eello6_graph2=-(s1+s2+s3+s4)
10217 #else
10218       eello6_graph2=-(s2+s3+s4)
10219 #endif
10220 !      eello6_graph2=-s3
10221 ! Derivatives in gamma(i-1)
10222       if (i.gt.1) then
10223 #ifdef MOMENT
10224         s1=dipderg(1,jj,i)*dip(1,kk,k)
10225 #endif
10226         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10227         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10228         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10229         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10230 #ifdef MOMENT
10231         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10232 #else
10233         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10234 #endif
10235 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10236       endif
10237 ! Derivatives in gamma(k-1)
10238 #ifdef MOMENT
10239       s1=dip(1,jj,i)*dipderg(1,kk,k)
10240 #endif
10241       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10242       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10243       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10244       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10245       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10246       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10247       vv(1)=pizda(1,1)-pizda(2,2)
10248       vv(2)=pizda(1,2)+pizda(2,1)
10249       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10250 #ifdef MOMENT
10251       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10252 #else
10253       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10254 #endif
10255 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10256 ! Derivatives in gamma(j-1) or gamma(l-1)
10257       if (j.gt.1) then
10258 #ifdef MOMENT
10259         s1=dipderg(3,jj,i)*dip(1,kk,k)
10260 #endif
10261         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10262         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10263         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10264         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10265         vv(1)=pizda(1,1)-pizda(2,2)
10266         vv(2)=pizda(1,2)+pizda(2,1)
10267         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10268 #ifdef MOMENT
10269         if (swap) then
10270           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10271         else
10272           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10273         endif
10274 #endif
10275         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10276 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10277       endif
10278 ! Derivatives in gamma(l-1) or gamma(j-1)
10279       if (l.gt.1) then
10280 #ifdef MOMENT
10281         s1=dip(1,jj,i)*dipderg(3,kk,k)
10282 #endif
10283         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10284         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10285         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10286         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10287         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10288         vv(1)=pizda(1,1)-pizda(2,2)
10289         vv(2)=pizda(1,2)+pizda(2,1)
10290         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10291 #ifdef MOMENT
10292         if (swap) then
10293           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10294         else
10295           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10296         endif
10297 #endif
10298         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10299 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10300       endif
10301 ! Cartesian derivatives.
10302       if (lprn) then
10303         write (2,*) 'In eello6_graph2'
10304         do iii=1,2
10305           write (2,*) 'iii=',iii
10306           do kkk=1,5
10307             write (2,*) 'kkk=',kkk
10308             do jjj=1,2
10309               write (2,'(3(2f10.5),5x)') &
10310               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10311             enddo
10312           enddo
10313         enddo
10314       endif
10315       do iii=1,2
10316         do kkk=1,5
10317           do lll=1,3
10318 #ifdef MOMENT
10319             if (iii.eq.1) then
10320               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10321             else
10322               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10323             endif
10324 #endif
10325             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10326               auxvec(1))
10327             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10328             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10329               auxvec(1))
10330             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10331             call transpose2(EUg(1,1,k),auxmat(1,1))
10332             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10333               pizda(1,1))
10334             vv(1)=pizda(1,1)-pizda(2,2)
10335             vv(2)=pizda(1,2)+pizda(2,1)
10336             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10337 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10338 #ifdef MOMENT
10339             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10340 #else
10341             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10342 #endif
10343             if (swap) then
10344               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10345             else
10346               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10347             endif
10348           enddo
10349         enddo
10350       enddo
10351       return
10352       end function eello6_graph2
10353 !-----------------------------------------------------------------------------
10354       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10355 !      implicit real*8 (a-h,o-z)
10356 !      include 'DIMENSIONS'
10357 !      include 'COMMON.IOUNITS'
10358 !      include 'COMMON.CHAIN'
10359 !      include 'COMMON.DERIV'
10360 !      include 'COMMON.INTERACT'
10361 !      include 'COMMON.CONTACTS'
10362 !      include 'COMMON.TORSION'
10363 !      include 'COMMON.VAR'
10364 !      include 'COMMON.GEO'
10365       real(kind=8),dimension(2) :: vv,auxvec
10366       real(kind=8),dimension(2,2) :: pizda,auxmat
10367       logical :: swap
10368       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10369       real(kind=8) :: s1,s2,s3,s4
10370 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10371 !                                                                              C
10372 !      Parallel       Antiparallel                                             C
10373 !                                                                              C
10374 !          o             o                                                     C
10375 !         /l\   /   \   /j\                                                    C
10376 !        /   \ /     \ /   \                                                   C
10377 !       /| o |o       o| o |\                                                  C
10378 !       j|/k\|  /      |/k\|l /                                                C
10379 !        /   \ /       /   \ /                                                 C
10380 !       /     o       /     o                                                  C
10381 !       i             i                                                        C
10382 !                                                                              C
10383 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10384 !
10385 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10386 !           energy moment and not to the cluster cumulant.
10387       iti=itortyp(itype(i,1))
10388       if (j.lt.nres-1) then
10389         itj1=itortyp(itype(j+1,1))
10390       else
10391         itj1=ntortyp+1
10392       endif
10393       itk=itortyp(itype(k,1))
10394       itk1=itortyp(itype(k+1,1))
10395       if (l.lt.nres-1) then
10396         itl1=itortyp(itype(l+1,1))
10397       else
10398         itl1=ntortyp+1
10399       endif
10400 #ifdef MOMENT
10401       s1=dip(4,jj,i)*dip(4,kk,k)
10402 #endif
10403       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10404       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10405       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10406       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10407       call transpose2(EE(1,1,itk),auxmat(1,1))
10408       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10409       vv(1)=pizda(1,1)+pizda(2,2)
10410       vv(2)=pizda(2,1)-pizda(1,2)
10411       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10412 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10413 !d     & "sum",-(s2+s3+s4)
10414 #ifdef MOMENT
10415       eello6_graph3=-(s1+s2+s3+s4)
10416 #else
10417       eello6_graph3=-(s2+s3+s4)
10418 #endif
10419 !      eello6_graph3=-s4
10420 ! Derivatives in gamma(k-1)
10421       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10422       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10423       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10424       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10425 ! Derivatives in gamma(l-1)
10426       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10427       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10428       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10429       vv(1)=pizda(1,1)+pizda(2,2)
10430       vv(2)=pizda(2,1)-pizda(1,2)
10431       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10432       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10433 ! Cartesian derivatives.
10434       do iii=1,2
10435         do kkk=1,5
10436           do lll=1,3
10437 #ifdef MOMENT
10438             if (iii.eq.1) then
10439               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10440             else
10441               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10442             endif
10443 #endif
10444             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10445               auxvec(1))
10446             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10447             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10448               auxvec(1))
10449             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10450             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10451               pizda(1,1))
10452             vv(1)=pizda(1,1)+pizda(2,2)
10453             vv(2)=pizda(2,1)-pizda(1,2)
10454             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10455 #ifdef MOMENT
10456             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10457 #else
10458             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10459 #endif
10460             if (swap) then
10461               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10462             else
10463               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10464             endif
10465 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10466           enddo
10467         enddo
10468       enddo
10469       return
10470       end function eello6_graph3
10471 !-----------------------------------------------------------------------------
10472       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10473 !      implicit real*8 (a-h,o-z)
10474 !      include 'DIMENSIONS'
10475 !      include 'COMMON.IOUNITS'
10476 !      include 'COMMON.CHAIN'
10477 !      include 'COMMON.DERIV'
10478 !      include 'COMMON.INTERACT'
10479 !      include 'COMMON.CONTACTS'
10480 !      include 'COMMON.TORSION'
10481 !      include 'COMMON.VAR'
10482 !      include 'COMMON.GEO'
10483 !      include 'COMMON.FFIELD'
10484       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10485       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10486       logical :: swap
10487       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10488               iii,kkk,lll
10489       real(kind=8) :: s1,s2,s3,s4
10490 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10491 !                                                                              C
10492 !      Parallel       Antiparallel                                             C
10493 !                                                                              C
10494 !          o             o                                                     C
10495 !         /l\   /   \   /j\                                                    C
10496 !        /   \ /     \ /   \                                                   C
10497 !       /| o |o       o| o |\                                                  C
10498 !     \ j|/k\|      \  |/k\|l                                                  C
10499 !      \ /   \       \ /   \                                                   C
10500 !       o     \       o     \                                                  C
10501 !       i             i                                                        C
10502 !                                                                              C
10503 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10504 !
10505 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10506 !           energy moment and not to the cluster cumulant.
10507 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10508       iti=itortyp(itype(i,1))
10509       itj=itortyp(itype(j,1))
10510       if (j.lt.nres-1) then
10511         itj1=itortyp(itype(j+1,1))
10512       else
10513         itj1=ntortyp+1
10514       endif
10515       itk=itortyp(itype(k,1))
10516       if (k.lt.nres-1) then
10517         itk1=itortyp(itype(k+1,1))
10518       else
10519         itk1=ntortyp+1
10520       endif
10521       itl=itortyp(itype(l,1))
10522       if (l.lt.nres-1) then
10523         itl1=itortyp(itype(l+1,1))
10524       else
10525         itl1=ntortyp+1
10526       endif
10527 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10528 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10529 !d     & ' itl',itl,' itl1',itl1
10530 #ifdef MOMENT
10531       if (imat.eq.1) then
10532         s1=dip(3,jj,i)*dip(3,kk,k)
10533       else
10534         s1=dip(2,jj,j)*dip(2,kk,l)
10535       endif
10536 #endif
10537       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10538       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10539       if (j.eq.l+1) then
10540         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10541         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10542       else
10543         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10544         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10545       endif
10546       call transpose2(EUg(1,1,k),auxmat(1,1))
10547       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10548       vv(1)=pizda(1,1)-pizda(2,2)
10549       vv(2)=pizda(2,1)+pizda(1,2)
10550       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10551 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10552 #ifdef MOMENT
10553       eello6_graph4=-(s1+s2+s3+s4)
10554 #else
10555       eello6_graph4=-(s2+s3+s4)
10556 #endif
10557 ! Derivatives in gamma(i-1)
10558       if (i.gt.1) then
10559 #ifdef MOMENT
10560         if (imat.eq.1) then
10561           s1=dipderg(2,jj,i)*dip(3,kk,k)
10562         else
10563           s1=dipderg(4,jj,j)*dip(2,kk,l)
10564         endif
10565 #endif
10566         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10567         if (j.eq.l+1) then
10568           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10569           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10570         else
10571           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10572           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10573         endif
10574         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10575         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10576 !d          write (2,*) 'turn6 derivatives'
10577 #ifdef MOMENT
10578           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10579 #else
10580           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10581 #endif
10582         else
10583 #ifdef MOMENT
10584           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10585 #else
10586           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10587 #endif
10588         endif
10589       endif
10590 ! Derivatives in gamma(k-1)
10591 #ifdef MOMENT
10592       if (imat.eq.1) then
10593         s1=dip(3,jj,i)*dipderg(2,kk,k)
10594       else
10595         s1=dip(2,jj,j)*dipderg(4,kk,l)
10596       endif
10597 #endif
10598       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10599       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10600       if (j.eq.l+1) then
10601         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10602         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10603       else
10604         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10605         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10606       endif
10607       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10608       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10609       vv(1)=pizda(1,1)-pizda(2,2)
10610       vv(2)=pizda(2,1)+pizda(1,2)
10611       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10612       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10613 #ifdef MOMENT
10614         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10615 #else
10616         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10617 #endif
10618       else
10619 #ifdef MOMENT
10620         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10621 #else
10622         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10623 #endif
10624       endif
10625 ! Derivatives in gamma(j-1) or gamma(l-1)
10626       if (l.eq.j+1 .and. l.gt.1) then
10627         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10628         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10629         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10630         vv(1)=pizda(1,1)-pizda(2,2)
10631         vv(2)=pizda(2,1)+pizda(1,2)
10632         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10633         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10634       else if (j.gt.1) then
10635         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10636         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10637         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10638         vv(1)=pizda(1,1)-pizda(2,2)
10639         vv(2)=pizda(2,1)+pizda(1,2)
10640         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10641         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10642           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10643         else
10644           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10645         endif
10646       endif
10647 ! Cartesian derivatives.
10648       do iii=1,2
10649         do kkk=1,5
10650           do lll=1,3
10651 #ifdef MOMENT
10652             if (iii.eq.1) then
10653               if (imat.eq.1) then
10654                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10655               else
10656                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10657               endif
10658             else
10659               if (imat.eq.1) then
10660                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10661               else
10662                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10663               endif
10664             endif
10665 #endif
10666             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10667               auxvec(1))
10668             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10669             if (j.eq.l+1) then
10670               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10671                 b1(1,itj1),auxvec(1))
10672               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10673             else
10674               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10675                 b1(1,itl1),auxvec(1))
10676               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10677             endif
10678             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10679               pizda(1,1))
10680             vv(1)=pizda(1,1)-pizda(2,2)
10681             vv(2)=pizda(2,1)+pizda(1,2)
10682             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10683             if (swap) then
10684               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10685 #ifdef MOMENT
10686                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10687                    -(s1+s2+s4)
10688 #else
10689                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10690                    -(s2+s4)
10691 #endif
10692                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10693               else
10694 #ifdef MOMENT
10695                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10696 #else
10697                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10698 #endif
10699                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10700               endif
10701             else
10702 #ifdef MOMENT
10703               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10704 #else
10705               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10706 #endif
10707               if (l.eq.j+1) then
10708                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10709               else
10710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10711               endif
10712             endif
10713           enddo
10714         enddo
10715       enddo
10716       return
10717       end function eello6_graph4
10718 !-----------------------------------------------------------------------------
10719       real(kind=8) function eello_turn6(i,jj,kk)
10720 !      implicit real*8 (a-h,o-z)
10721 !      include 'DIMENSIONS'
10722 !      include 'COMMON.IOUNITS'
10723 !      include 'COMMON.CHAIN'
10724 !      include 'COMMON.DERIV'
10725 !      include 'COMMON.INTERACT'
10726 !      include 'COMMON.CONTACTS'
10727 !      include 'COMMON.TORSION'
10728 !      include 'COMMON.VAR'
10729 !      include 'COMMON.GEO'
10730       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10731       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10732       real(kind=8),dimension(3) :: ggg1,ggg2
10733       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10734       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10735 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10736 !           the respective energy moment and not to the cluster cumulant.
10737 !el local variables
10738       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10739       integer :: j1,j2,l1,l2,ll
10740       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10741       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10742       s1=0.0d0
10743       s8=0.0d0
10744       s13=0.0d0
10745 !
10746       eello_turn6=0.0d0
10747       j=i+4
10748       k=i+1
10749       l=i+3
10750       iti=itortyp(itype(i,1))
10751       itk=itortyp(itype(k,1))
10752       itk1=itortyp(itype(k+1,1))
10753       itl=itortyp(itype(l,1))
10754       itj=itortyp(itype(j,1))
10755 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10756 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10757 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10758 !d        eello6=0.0d0
10759 !d        return
10760 !d      endif
10761 !d      write (iout,*)
10762 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10763 !d     &   ' and',k,l
10764 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10765       do iii=1,2
10766         do kkk=1,5
10767           do lll=1,3
10768             derx_turn(lll,kkk,iii)=0.0d0
10769           enddo
10770         enddo
10771       enddo
10772 !d      eij=1.0d0
10773 !d      ekl=1.0d0
10774 !d      ekont=1.0d0
10775       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10776 !d      eello6_5=0.0d0
10777 !d      write (2,*) 'eello6_5',eello6_5
10778 #ifdef MOMENT
10779       call transpose2(AEA(1,1,1),auxmat(1,1))
10780       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10781       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10782       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10783 #endif
10784       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10785       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10786       s2 = scalar2(b1(1,itk),vtemp1(1))
10787 #ifdef MOMENT
10788       call transpose2(AEA(1,1,2),atemp(1,1))
10789       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10790       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10791       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10792 #endif
10793       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10794       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10795       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10796 #ifdef MOMENT
10797       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10798       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10799       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10800       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10801       ss13 = scalar2(b1(1,itk),vtemp4(1))
10802       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10803 #endif
10804 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10805 !      s1=0.0d0
10806 !      s2=0.0d0
10807 !      s8=0.0d0
10808 !      s12=0.0d0
10809 !      s13=0.0d0
10810       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10811 ! Derivatives in gamma(i+2)
10812       s1d =0.0d0
10813       s8d =0.0d0
10814 #ifdef MOMENT
10815       call transpose2(AEA(1,1,1),auxmatd(1,1))
10816       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10817       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10818       call transpose2(AEAderg(1,1,2),atempd(1,1))
10819       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10820       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10821 #endif
10822       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10823       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10824       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10825 !      s1d=0.0d0
10826 !      s2d=0.0d0
10827 !      s8d=0.0d0
10828 !      s12d=0.0d0
10829 !      s13d=0.0d0
10830       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10831 ! Derivatives in gamma(i+3)
10832 #ifdef MOMENT
10833       call transpose2(AEA(1,1,1),auxmatd(1,1))
10834       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10835       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10836       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10837 #endif
10838       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10839       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10840       s2d = scalar2(b1(1,itk),vtemp1d(1))
10841 #ifdef MOMENT
10842       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10843       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10844 #endif
10845       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10846 #ifdef MOMENT
10847       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10848       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10849       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10850 #endif
10851 !      s1d=0.0d0
10852 !      s2d=0.0d0
10853 !      s8d=0.0d0
10854 !      s12d=0.0d0
10855 !      s13d=0.0d0
10856 #ifdef MOMENT
10857       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10858                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10859 #else
10860       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10861                     -0.5d0*ekont*(s2d+s12d)
10862 #endif
10863 ! Derivatives in gamma(i+4)
10864       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10865       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10866       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10867 #ifdef MOMENT
10868       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10869       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10870       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10871 #endif
10872 !      s1d=0.0d0
10873 !      s2d=0.0d0
10874 !      s8d=0.0d0
10875 !      s12d=0.0d0
10876 !      s13d=0.0d0
10877 #ifdef MOMENT
10878       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10879 #else
10880       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10881 #endif
10882 ! Derivatives in gamma(i+5)
10883 #ifdef MOMENT
10884       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10885       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10886       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10887 #endif
10888       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10889       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10890       s2d = scalar2(b1(1,itk),vtemp1d(1))
10891 #ifdef MOMENT
10892       call transpose2(AEA(1,1,2),atempd(1,1))
10893       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10894       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10895 #endif
10896       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10897       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10898 #ifdef MOMENT
10899       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10900       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10901       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10902 #endif
10903 !      s1d=0.0d0
10904 !      s2d=0.0d0
10905 !      s8d=0.0d0
10906 !      s12d=0.0d0
10907 !      s13d=0.0d0
10908 #ifdef MOMENT
10909       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10910                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10911 #else
10912       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10913                     -0.5d0*ekont*(s2d+s12d)
10914 #endif
10915 ! Cartesian derivatives
10916       do iii=1,2
10917         do kkk=1,5
10918           do lll=1,3
10919 #ifdef MOMENT
10920             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10921             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10922             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10923 #endif
10924             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10925             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10926                 vtemp1d(1))
10927             s2d = scalar2(b1(1,itk),vtemp1d(1))
10928 #ifdef MOMENT
10929             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10930             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10931             s8d = -(atempd(1,1)+atempd(2,2))* &
10932                  scalar2(cc(1,1,itl),vtemp2(1))
10933 #endif
10934             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10935                  auxmatd(1,1))
10936             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10937             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10938 !      s1d=0.0d0
10939 !      s2d=0.0d0
10940 !      s8d=0.0d0
10941 !      s12d=0.0d0
10942 !      s13d=0.0d0
10943 #ifdef MOMENT
10944             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10945               - 0.5d0*(s1d+s2d)
10946 #else
10947             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10948               - 0.5d0*s2d
10949 #endif
10950 #ifdef MOMENT
10951             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10952               - 0.5d0*(s8d+s12d)
10953 #else
10954             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10955               - 0.5d0*s12d
10956 #endif
10957           enddo
10958         enddo
10959       enddo
10960 #ifdef MOMENT
10961       do kkk=1,5
10962         do lll=1,3
10963           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10964             achuj_tempd(1,1))
10965           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10966           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10967           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10968           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10969           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10970             vtemp4d(1))
10971           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10972           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10973           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10974         enddo
10975       enddo
10976 #endif
10977 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10978 !d     &  16*eel_turn6_num
10979 !d      goto 1112
10980       if (j.lt.nres-1) then
10981         j1=j+1
10982         j2=j-1
10983       else
10984         j1=j-1
10985         j2=j-2
10986       endif
10987       if (l.lt.nres-1) then
10988         l1=l+1
10989         l2=l-1
10990       else
10991         l1=l-1
10992         l2=l-2
10993       endif
10994       do ll=1,3
10995 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10996 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10997 !grad        ghalf=0.5d0*ggg1(ll)
10998 !d        ghalf=0.0d0
10999         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11000         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11001         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11002           +ekont*derx_turn(ll,2,1)
11003         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11004         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11005           +ekont*derx_turn(ll,4,1)
11006         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11007         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11008         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11009 !grad        ghalf=0.5d0*ggg2(ll)
11010 !d        ghalf=0.0d0
11011         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11012           +ekont*derx_turn(ll,2,2)
11013         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11014         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11015           +ekont*derx_turn(ll,4,2)
11016         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11017         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11018         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11019       enddo
11020 !d      goto 1112
11021 !grad      do m=i+1,j-1
11022 !grad        do ll=1,3
11023 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11024 !grad        enddo
11025 !grad      enddo
11026 !grad      do m=k+1,l-1
11027 !grad        do ll=1,3
11028 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11029 !grad        enddo
11030 !grad      enddo
11031 !grad1112  continue
11032 !grad      do m=i+2,j2
11033 !grad        do ll=1,3
11034 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11035 !grad        enddo
11036 !grad      enddo
11037 !grad      do m=k+2,l2
11038 !grad        do ll=1,3
11039 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11040 !grad        enddo
11041 !grad      enddo
11042 !d      do iii=1,nres-3
11043 !d        write (2,*) iii,g_corr6_loc(iii)
11044 !d      enddo
11045       eello_turn6=ekont*eel_turn6
11046 !d      write (2,*) 'ekont',ekont
11047 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11048       return
11049       end function eello_turn6
11050 !-----------------------------------------------------------------------------
11051       subroutine MATVEC2(A1,V1,V2)
11052 !DIR$ INLINEALWAYS MATVEC2
11053 #ifndef OSF
11054 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11055 #endif
11056 !      implicit real*8 (a-h,o-z)
11057 !      include 'DIMENSIONS'
11058       real(kind=8),dimension(2) :: V1,V2
11059       real(kind=8),dimension(2,2) :: A1
11060       real(kind=8) :: vaux1,vaux2
11061 !      DO 1 I=1,2
11062 !        VI=0.0
11063 !        DO 3 K=1,2
11064 !    3     VI=VI+A1(I,K)*V1(K)
11065 !        Vaux(I)=VI
11066 !    1 CONTINUE
11067
11068       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11069       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11070
11071       v2(1)=vaux1
11072       v2(2)=vaux2
11073       end subroutine MATVEC2
11074 !-----------------------------------------------------------------------------
11075       subroutine MATMAT2(A1,A2,A3)
11076 #ifndef OSF
11077 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11078 #endif
11079 !      implicit real*8 (a-h,o-z)
11080 !      include 'DIMENSIONS'
11081       real(kind=8),dimension(2,2) :: A1,A2,A3
11082       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11083 !      DIMENSION AI3(2,2)
11084 !        DO  J=1,2
11085 !          A3IJ=0.0
11086 !          DO K=1,2
11087 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11088 !          enddo
11089 !          A3(I,J)=A3IJ
11090 !       enddo
11091 !      enddo
11092
11093       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11094       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11095       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11096       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11097
11098       A3(1,1)=AI3_11
11099       A3(2,1)=AI3_21
11100       A3(1,2)=AI3_12
11101       A3(2,2)=AI3_22
11102       end subroutine MATMAT2
11103 !-----------------------------------------------------------------------------
11104       real(kind=8) function scalar2(u,v)
11105 !DIR$ INLINEALWAYS scalar2
11106       implicit none
11107       real(kind=8),dimension(2) :: u,v
11108       real(kind=8) :: sc
11109       integer :: i
11110       scalar2=u(1)*v(1)+u(2)*v(2)
11111       return
11112       end function scalar2
11113 !-----------------------------------------------------------------------------
11114       subroutine transpose2(a,at)
11115 !DIR$ INLINEALWAYS transpose2
11116 #ifndef OSF
11117 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11118 #endif
11119       implicit none
11120       real(kind=8),dimension(2,2) :: a,at
11121       at(1,1)=a(1,1)
11122       at(1,2)=a(2,1)
11123       at(2,1)=a(1,2)
11124       at(2,2)=a(2,2)
11125       return
11126       end subroutine transpose2
11127 !-----------------------------------------------------------------------------
11128       subroutine transpose(n,a,at)
11129       implicit none
11130       integer :: n,i,j
11131       real(kind=8),dimension(n,n) :: a,at
11132       do i=1,n
11133         do j=1,n
11134           at(j,i)=a(i,j)
11135         enddo
11136       enddo
11137       return
11138       end subroutine transpose
11139 !-----------------------------------------------------------------------------
11140       subroutine prodmat3(a1,a2,kk,transp,prod)
11141 !DIR$ INLINEALWAYS prodmat3
11142 #ifndef OSF
11143 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11144 #endif
11145       implicit none
11146       integer :: i,j
11147       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11148       logical :: transp
11149 !rc      double precision auxmat(2,2),prod_(2,2)
11150
11151       if (transp) then
11152 !rc        call transpose2(kk(1,1),auxmat(1,1))
11153 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11154 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11155
11156            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11157        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11158            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11159        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11160            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11161        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11162            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11163        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11164
11165       else
11166 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11167 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11168
11169            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11170         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11171            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11172         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11173            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11174         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11175            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11176         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11177
11178       endif
11179 !      call transpose2(a2(1,1),a2t(1,1))
11180
11181 !rc      print *,transp
11182 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11183 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11184
11185       return
11186       end subroutine prodmat3
11187 !-----------------------------------------------------------------------------
11188 ! energy_p_new_barrier.F
11189 !-----------------------------------------------------------------------------
11190       subroutine sum_gradient
11191 !      implicit real*8 (a-h,o-z)
11192       use io_base, only: pdbout
11193 !      include 'DIMENSIONS'
11194 #ifndef ISNAN
11195       external proc_proc
11196 #ifdef WINPGI
11197 !MS$ATTRIBUTES C ::  proc_proc
11198 #endif
11199 #endif
11200 #ifdef MPI
11201       include 'mpif.h'
11202 #endif
11203       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11204                    gloc_scbuf !(3,maxres)
11205
11206       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11207 !#endif
11208 !el local variables
11209       integer :: i,j,k,ierror,ierr
11210       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11211                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11212                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11213                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11214                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11215                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11216                    gsccorr_max,gsccorrx_max,time00
11217
11218 !      include 'COMMON.SETUP'
11219 !      include 'COMMON.IOUNITS'
11220 !      include 'COMMON.FFIELD'
11221 !      include 'COMMON.DERIV'
11222 !      include 'COMMON.INTERACT'
11223 !      include 'COMMON.SBRIDGE'
11224 !      include 'COMMON.CHAIN'
11225 !      include 'COMMON.VAR'
11226 !      include 'COMMON.CONTROL'
11227 !      include 'COMMON.TIME1'
11228 !      include 'COMMON.MAXGRAD'
11229 !      include 'COMMON.SCCOR'
11230 #ifdef TIMING
11231       time01=MPI_Wtime()
11232 #endif
11233 !#define DEBUG
11234 #ifdef DEBUG
11235       write (iout,*) "sum_gradient gvdwc, gvdwx"
11236       do i=1,nres
11237         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11238          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11239       enddo
11240       call flush(iout)
11241 #endif
11242 #ifdef MPI
11243         gradbufc=0.0d0
11244         gradbufx=0.0d0
11245         gradbufc_sum=0.0d0
11246         gloc_scbuf=0.0d0
11247         glocbuf=0.0d0
11248 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11249         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11250           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11251 #endif
11252 !
11253 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11254 !            in virtual-bond-vector coordinates
11255 !
11256 #ifdef DEBUG
11257 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11258 !      do i=1,nres-1
11259 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11260 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11261 !      enddo
11262 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11263 !      do i=1,nres-1
11264 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11265 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11266 !      enddo
11267 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11268 !      do i=1,nres
11269 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11270 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11271 !         (gvdwc_scpp(j,i),j=1,3)
11272 !      enddo
11273 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11274 !      do i=1,nres
11275 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11276 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11277 !         (gelc_loc_long(j,i),j=1,3)
11278 !      enddo
11279       call flush(iout)
11280 #endif
11281 #ifdef SPLITELE
11282       do i=0,nct
11283         do j=1,3
11284           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11285                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11286                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11287                       wel_loc*gel_loc_long(j,i)+ &
11288                       wcorr*gradcorr_long(j,i)+ &
11289                       wcorr5*gradcorr5_long(j,i)+ &
11290                       wcorr6*gradcorr6_long(j,i)+ &
11291                       wturn6*gcorr6_turn_long(j,i)+ &
11292                       wstrain*ghpbc(j,i) &
11293                      +wliptran*gliptranc(j,i) &
11294                      +gradafm(j,i) &
11295                      +welec*gshieldc(j,i) &
11296                      +wcorr*gshieldc_ec(j,i) &
11297                      +wturn3*gshieldc_t3(j,i)&
11298                      +wturn4*gshieldc_t4(j,i)&
11299                      +wel_loc*gshieldc_ll(j,i)&
11300                      +wtube*gg_tube(j,i) &
11301                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11302                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11303                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11304                      wcorr_nucl*gradcorr_nucl(j,i)&
11305                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11306                      wcatprot* gradpepcat(j,i)+ &
11307                      wcatcat*gradcatcat(j,i)+   &
11308                      wscbase*gvdwc_scbase(j,i)+ &
11309                      wpepbase*gvdwc_pepbase(j,i)+&
11310                      wscpho*gvdwc_scpho(j,i)+   &
11311                      wpeppho*gvdwc_peppho(j,i)
11312
11313
11314
11315
11316
11317         enddo
11318       enddo
11319 #else
11320       do i=0,nct
11321         do j=1,3
11322           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11323                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11324                       welec*gelc_long(j,i)+ &
11325                       wbond*gradb(j,i)+ &
11326                       wel_loc*gel_loc_long(j,i)+ &
11327                       wcorr*gradcorr_long(j,i)+ &
11328                       wcorr5*gradcorr5_long(j,i)+ &
11329                       wcorr6*gradcorr6_long(j,i)+ &
11330                       wturn6*gcorr6_turn_long(j,i)+ &
11331                       wstrain*ghpbc(j,i) &
11332                      +wliptran*gliptranc(j,i) &
11333                      +gradafm(j,i) &
11334                      +welec*gshieldc(j,i)&
11335                      +wcorr*gshieldc_ec(j,i) &
11336                      +wturn4*gshieldc_t4(j,i) &
11337                      +wel_loc*gshieldc_ll(j,i)&
11338                      +wtube*gg_tube(j,i) &
11339                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11340                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11341                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11342                      wcorr_nucl*gradcorr_nucl(j,i) &
11343                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11344                      wcatprot* gradpepcat(j,i)+ &
11345                      wcatcat*gradcatcat(j,i)+   &
11346                      wscbase*gvdwc_scbase(j,i)+ &
11347                      wpepbase*gvdwc_pepbase(j,i)+&
11348                      wscpho*gvdwc_scpho(j,i)+&
11349                      wpeppho*gvdwc_peppho(j,i)
11350
11351
11352         enddo
11353       enddo
11354 #endif
11355 #ifdef MPI
11356       if (nfgtasks.gt.1) then
11357       time00=MPI_Wtime()
11358 #ifdef DEBUG
11359       write (iout,*) "gradbufc before allreduce"
11360       do i=1,nres
11361         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11362       enddo
11363       call flush(iout)
11364 #endif
11365       do i=0,nres
11366         do j=1,3
11367           gradbufc_sum(j,i)=gradbufc(j,i)
11368         enddo
11369       enddo
11370 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11371 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11372 !      time_reduce=time_reduce+MPI_Wtime()-time00
11373 #ifdef DEBUG
11374 !      write (iout,*) "gradbufc_sum after allreduce"
11375 !      do i=1,nres
11376 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11377 !      enddo
11378 !      call flush(iout)
11379 #endif
11380 #ifdef TIMING
11381 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11382 #endif
11383       do i=0,nres
11384         do k=1,3
11385           gradbufc(k,i)=0.0d0
11386         enddo
11387       enddo
11388 #ifdef DEBUG
11389       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11390       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11391                         " jgrad_end  ",jgrad_end(i),&
11392                         i=igrad_start,igrad_end)
11393 #endif
11394 !
11395 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11396 ! do not parallelize this part.
11397 !
11398 !      do i=igrad_start,igrad_end
11399 !        do j=jgrad_start(i),jgrad_end(i)
11400 !          do k=1,3
11401 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11402 !          enddo
11403 !        enddo
11404 !      enddo
11405       do j=1,3
11406         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11407       enddo
11408       do i=nres-2,-1,-1
11409         do j=1,3
11410           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11411         enddo
11412       enddo
11413 #ifdef DEBUG
11414       write (iout,*) "gradbufc after summing"
11415       do i=1,nres
11416         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11417       enddo
11418       call flush(iout)
11419 #endif
11420       else
11421 #endif
11422 !el#define DEBUG
11423 #ifdef DEBUG
11424       write (iout,*) "gradbufc"
11425       do i=1,nres
11426         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11427       enddo
11428       call flush(iout)
11429 #endif
11430 !el#undef DEBUG
11431       do i=-1,nres
11432         do j=1,3
11433           gradbufc_sum(j,i)=gradbufc(j,i)
11434           gradbufc(j,i)=0.0d0
11435         enddo
11436       enddo
11437       do j=1,3
11438         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11439       enddo
11440       do i=nres-2,-1,-1
11441         do j=1,3
11442           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11443         enddo
11444       enddo
11445 !      do i=nnt,nres-1
11446 !        do k=1,3
11447 !          gradbufc(k,i)=0.0d0
11448 !        enddo
11449 !        do j=i+1,nres
11450 !          do k=1,3
11451 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11452 !          enddo
11453 !        enddo
11454 !      enddo
11455 !el#define DEBUG
11456 #ifdef DEBUG
11457       write (iout,*) "gradbufc after summing"
11458       do i=1,nres
11459         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11460       enddo
11461       call flush(iout)
11462 #endif
11463 !el#undef DEBUG
11464 #ifdef MPI
11465       endif
11466 #endif
11467       do k=1,3
11468         gradbufc(k,nres)=0.0d0
11469       enddo
11470 !el----------------
11471 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11472 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11473 !el-----------------
11474       do i=-1,nct
11475         do j=1,3
11476 #ifdef SPLITELE
11477           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11478                       wel_loc*gel_loc(j,i)+ &
11479                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11480                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11481                       wel_loc*gel_loc_long(j,i)+ &
11482                       wcorr*gradcorr_long(j,i)+ &
11483                       wcorr5*gradcorr5_long(j,i)+ &
11484                       wcorr6*gradcorr6_long(j,i)+ &
11485                       wturn6*gcorr6_turn_long(j,i))+ &
11486                       wbond*gradb(j,i)+ &
11487                       wcorr*gradcorr(j,i)+ &
11488                       wturn3*gcorr3_turn(j,i)+ &
11489                       wturn4*gcorr4_turn(j,i)+ &
11490                       wcorr5*gradcorr5(j,i)+ &
11491                       wcorr6*gradcorr6(j,i)+ &
11492                       wturn6*gcorr6_turn(j,i)+ &
11493                       wsccor*gsccorc(j,i) &
11494                      +wscloc*gscloc(j,i)  &
11495                      +wliptran*gliptranc(j,i) &
11496                      +gradafm(j,i) &
11497                      +welec*gshieldc(j,i) &
11498                      +welec*gshieldc_loc(j,i) &
11499                      +wcorr*gshieldc_ec(j,i) &
11500                      +wcorr*gshieldc_loc_ec(j,i) &
11501                      +wturn3*gshieldc_t3(j,i) &
11502                      +wturn3*gshieldc_loc_t3(j,i) &
11503                      +wturn4*gshieldc_t4(j,i) &
11504                      +wturn4*gshieldc_loc_t4(j,i) &
11505                      +wel_loc*gshieldc_ll(j,i) &
11506                      +wel_loc*gshieldc_loc_ll(j,i) &
11507                      +wtube*gg_tube(j,i) &
11508                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11509                      +wvdwpsb*gvdwpsb1(j,i))&
11510                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11511 !                      if (i.eq.21) then
11512 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11513 !                      wturn4*gshieldc_t4(j,i), &
11514 !                     wturn4*gshieldc_loc_t4(j,i)
11515 !                       endif
11516 !                 if ((i.le.2).and.(i.ge.1))
11517 !                       print *,gradc(j,i,icg),&
11518 !                      gradbufc(j,i),welec*gelc(j,i), &
11519 !                      wel_loc*gel_loc(j,i), &
11520 !                      wscp*gvdwc_scpp(j,i), &
11521 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11522 !                      wel_loc*gel_loc_long(j,i), &
11523 !                      wcorr*gradcorr_long(j,i), &
11524 !                      wcorr5*gradcorr5_long(j,i), &
11525 !                      wcorr6*gradcorr6_long(j,i), &
11526 !                      wturn6*gcorr6_turn_long(j,i), &
11527 !                      wbond*gradb(j,i), &
11528 !                      wcorr*gradcorr(j,i), &
11529 !                      wturn3*gcorr3_turn(j,i), &
11530 !                      wturn4*gcorr4_turn(j,i), &
11531 !                      wcorr5*gradcorr5(j,i), &
11532 !                      wcorr6*gradcorr6(j,i), &
11533 !                      wturn6*gcorr6_turn(j,i), &
11534 !                      wsccor*gsccorc(j,i) &
11535 !                     ,wscloc*gscloc(j,i)  &
11536 !                     ,wliptran*gliptranc(j,i) &
11537 !                    ,gradafm(j,i) &
11538 !                     ,welec*gshieldc(j,i) &
11539 !                     ,welec*gshieldc_loc(j,i) &
11540 !                     ,wcorr*gshieldc_ec(j,i) &
11541 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11542 !                     ,wturn3*gshieldc_t3(j,i) &
11543 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11544 !                     ,wturn4*gshieldc_t4(j,i) &
11545 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11546 !                     ,wel_loc*gshieldc_ll(j,i) &
11547 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11548 !                     ,wtube*gg_tube(j,i) &
11549 !                     ,wbond_nucl*gradb_nucl(j,i) &
11550 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11551 !                     wvdwpsb*gvdwpsb1(j,i)&
11552 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11553 !
11554
11555 #else
11556           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11557                       wel_loc*gel_loc(j,i)+ &
11558                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11559                       welec*gelc_long(j,i)+ &
11560                       wel_loc*gel_loc_long(j,i)+ &
11561 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11562                       wcorr5*gradcorr5_long(j,i)+ &
11563                       wcorr6*gradcorr6_long(j,i)+ &
11564                       wturn6*gcorr6_turn_long(j,i))+ &
11565                       wbond*gradb(j,i)+ &
11566                       wcorr*gradcorr(j,i)+ &
11567                       wturn3*gcorr3_turn(j,i)+ &
11568                       wturn4*gcorr4_turn(j,i)+ &
11569                       wcorr5*gradcorr5(j,i)+ &
11570                       wcorr6*gradcorr6(j,i)+ &
11571                       wturn6*gcorr6_turn(j,i)+ &
11572                       wsccor*gsccorc(j,i) &
11573                      +wscloc*gscloc(j,i) &
11574                      +gradafm(j,i) &
11575                      +wliptran*gliptranc(j,i) &
11576                      +welec*gshieldc(j,i) &
11577                      +welec*gshieldc_loc(j,i) &
11578                      +wcorr*gshieldc_ec(j,i) &
11579                      +wcorr*gshieldc_loc_ec(j,i) &
11580                      +wturn3*gshieldc_t3(j,i) &
11581                      +wturn3*gshieldc_loc_t3(j,i) &
11582                      +wturn4*gshieldc_t4(j,i) &
11583                      +wturn4*gshieldc_loc_t4(j,i) &
11584                      +wel_loc*gshieldc_ll(j,i) &
11585                      +wel_loc*gshieldc_loc_ll(j,i) &
11586                      +wtube*gg_tube(j,i) &
11587                      +wbond_nucl*gradb_nucl(j,i) &
11588                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11589                      +wvdwpsb*gvdwpsb1(j,i))&
11590                      +wsbloc*gsbloc(j,i)
11591
11592
11593
11594
11595 #endif
11596           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11597                         wbond*gradbx(j,i)+ &
11598                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11599                         wsccor*gsccorx(j,i) &
11600                        +wscloc*gsclocx(j,i) &
11601                        +wliptran*gliptranx(j,i) &
11602                        +welec*gshieldx(j,i)     &
11603                        +wcorr*gshieldx_ec(j,i)  &
11604                        +wturn3*gshieldx_t3(j,i) &
11605                        +wturn4*gshieldx_t4(j,i) &
11606                        +wel_loc*gshieldx_ll(j,i)&
11607                        +wtube*gg_tube_sc(j,i)   &
11608                        +wbond_nucl*gradbx_nucl(j,i) &
11609                        +wvdwsb*gvdwsbx(j,i) &
11610                        +welsb*gelsbx(j,i) &
11611                        +wcorr_nucl*gradxorr_nucl(j,i)&
11612                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11613                        +wsbloc*gsblocx(j,i) &
11614                        +wcatprot* gradpepcatx(j,i)&
11615                        +wscbase*gvdwx_scbase(j,i) &
11616                        +wpepbase*gvdwx_pepbase(j,i)&
11617                        +wscpho*gvdwx_scpho(j,i)
11618 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11619
11620         enddo
11621       enddo
11622 !#define DEBUG
11623 #ifdef DEBUG
11624       write (iout,*) "gloc before adding corr"
11625       do i=1,4*nres
11626         write (iout,*) i,gloc(i,icg)
11627       enddo
11628 #endif
11629       do i=1,nres-3
11630         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11631          +wcorr5*g_corr5_loc(i) &
11632          +wcorr6*g_corr6_loc(i) &
11633          +wturn4*gel_loc_turn4(i) &
11634          +wturn3*gel_loc_turn3(i) &
11635          +wturn6*gel_loc_turn6(i) &
11636          +wel_loc*gel_loc_loc(i)
11637       enddo
11638 #ifdef DEBUG
11639       write (iout,*) "gloc after adding corr"
11640       do i=1,4*nres
11641         write (iout,*) i,gloc(i,icg)
11642       enddo
11643 #endif
11644 !#undef DEBUG
11645 #ifdef MPI
11646       if (nfgtasks.gt.1) then
11647         do j=1,3
11648           do i=0,nres
11649             gradbufc(j,i)=gradc(j,i,icg)
11650             gradbufx(j,i)=gradx(j,i,icg)
11651           enddo
11652         enddo
11653         do i=1,4*nres
11654           glocbuf(i)=gloc(i,icg)
11655         enddo
11656 !#define DEBUG
11657 #ifdef DEBUG
11658       write (iout,*) "gloc_sc before reduce"
11659       do i=1,nres
11660        do j=1,1
11661         write (iout,*) i,j,gloc_sc(j,i,icg)
11662        enddo
11663       enddo
11664 #endif
11665 !#undef DEBUG
11666         do i=1,nres
11667          do j=1,3
11668           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11669          enddo
11670         enddo
11671         time00=MPI_Wtime()
11672         call MPI_Barrier(FG_COMM,IERR)
11673         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11674         time00=MPI_Wtime()
11675         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11676           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11677         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11678           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11679         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11680           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11681         time_reduce=time_reduce+MPI_Wtime()-time00
11682         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11683           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11684         time_reduce=time_reduce+MPI_Wtime()-time00
11685 !#define DEBUG
11686 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11687 #ifdef DEBUG
11688       write (iout,*) "gloc_sc after reduce"
11689       do i=1,nres
11690        do j=1,1
11691         write (iout,*) i,j,gloc_sc(j,i,icg)
11692        enddo
11693       enddo
11694 #endif
11695 !#undef DEBUG
11696 #ifdef DEBUG
11697       write (iout,*) "gloc after reduce"
11698       do i=1,4*nres
11699         write (iout,*) i,gloc(i,icg)
11700       enddo
11701 #endif
11702       endif
11703 #endif
11704       if (gnorm_check) then
11705 !
11706 ! Compute the maximum elements of the gradient
11707 !
11708       gvdwc_max=0.0d0
11709       gvdwc_scp_max=0.0d0
11710       gelc_max=0.0d0
11711       gvdwpp_max=0.0d0
11712       gradb_max=0.0d0
11713       ghpbc_max=0.0d0
11714       gradcorr_max=0.0d0
11715       gel_loc_max=0.0d0
11716       gcorr3_turn_max=0.0d0
11717       gcorr4_turn_max=0.0d0
11718       gradcorr5_max=0.0d0
11719       gradcorr6_max=0.0d0
11720       gcorr6_turn_max=0.0d0
11721       gsccorc_max=0.0d0
11722       gscloc_max=0.0d0
11723       gvdwx_max=0.0d0
11724       gradx_scp_max=0.0d0
11725       ghpbx_max=0.0d0
11726       gradxorr_max=0.0d0
11727       gsccorx_max=0.0d0
11728       gsclocx_max=0.0d0
11729       do i=1,nct
11730         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11731         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11732         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11733         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11734          gvdwc_scp_max=gvdwc_scp_norm
11735         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11736         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11737         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11738         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11739         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11740         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11741         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11742         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11743         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11744         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11745         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11746         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11747         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11748           gcorr3_turn(1,i)))
11749         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11750           gcorr3_turn_max=gcorr3_turn_norm
11751         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11752           gcorr4_turn(1,i)))
11753         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11754           gcorr4_turn_max=gcorr4_turn_norm
11755         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11756         if (gradcorr5_norm.gt.gradcorr5_max) &
11757           gradcorr5_max=gradcorr5_norm
11758         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11759         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11760         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11761           gcorr6_turn(1,i)))
11762         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11763           gcorr6_turn_max=gcorr6_turn_norm
11764         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11765         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11766         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11767         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11768         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11769         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11770         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11771         if (gradx_scp_norm.gt.gradx_scp_max) &
11772           gradx_scp_max=gradx_scp_norm
11773         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11774         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11775         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11776         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11777         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11778         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11779         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11780         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11781       enddo
11782       if (gradout) then
11783 #ifdef AIX
11784         open(istat,file=statname,position="append")
11785 #else
11786         open(istat,file=statname,access="append")
11787 #endif
11788         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11789            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11790            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11791            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11792            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11793            gsccorx_max,gsclocx_max
11794         close(istat)
11795         if (gvdwc_max.gt.1.0d4) then
11796           write (iout,*) "gvdwc gvdwx gradb gradbx"
11797           do i=nnt,nct
11798             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11799               gradb(j,i),gradbx(j,i),j=1,3)
11800           enddo
11801           call pdbout(0.0d0,'cipiszcze',iout)
11802           call flush(iout)
11803         endif
11804       endif
11805       endif
11806 !#define DEBUG
11807 #ifdef DEBUG
11808       write (iout,*) "gradc gradx gloc"
11809       do i=1,nres
11810         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11811          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11812       enddo
11813 #endif
11814 !#undef DEBUG
11815 #ifdef TIMING
11816       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11817 #endif
11818       return
11819       end subroutine sum_gradient
11820 !-----------------------------------------------------------------------------
11821       subroutine sc_grad
11822 !      implicit real*8 (a-h,o-z)
11823       use calc_data
11824 !      include 'DIMENSIONS'
11825 !      include 'COMMON.CHAIN'
11826 !      include 'COMMON.DERIV'
11827 !      include 'COMMON.CALC'
11828 !      include 'COMMON.IOUNITS'
11829       real(kind=8), dimension(3) :: dcosom1,dcosom2
11830 !      print *,"wchodze"
11831       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11832           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11833       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11834           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11835
11836       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11837            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11838            +dCAVdOM12+ dGCLdOM12
11839 ! diagnostics only
11840 !      eom1=0.0d0
11841 !      eom2=0.0d0
11842 !      eom12=evdwij*eps1_om12
11843 ! end diagnostics
11844 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11845 !       " sigder",sigder
11846 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11847 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11848 !C      print *,sss_ele_cut,'in sc_grad'
11849       do k=1,3
11850         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11851         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11852       enddo
11853       do k=1,3
11854         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11855 !C      print *,'gg',k,gg(k)
11856        enddo
11857 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11858 !      write (iout,*) "gg",(gg(k),k=1,3)
11859       do k=1,3
11860         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11861                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11862                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11863                   *sss_ele_cut
11864
11865         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11866                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11867                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11868                   *sss_ele_cut
11869
11870 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11871 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11872 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11873 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11874       enddo
11875 !
11876 ! Calculate the components of the gradient in DC and X
11877 !
11878 !grad      do k=i,j-1
11879 !grad        do l=1,3
11880 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11881 !grad        enddo
11882 !grad      enddo
11883       do l=1,3
11884         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11885         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11886       enddo
11887       return
11888       end subroutine sc_grad
11889 #ifdef CRYST_THETA
11890 !-----------------------------------------------------------------------------
11891       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11892
11893       use comm_calcthet
11894 !      implicit real*8 (a-h,o-z)
11895 !      include 'DIMENSIONS'
11896 !      include 'COMMON.LOCAL'
11897 !      include 'COMMON.IOUNITS'
11898 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11899 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11900 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11901       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11902       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11903 !el      integer :: it
11904 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11905 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11906 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11907 !el local variables
11908
11909       delthec=thetai-thet_pred_mean
11910       delthe0=thetai-theta0i
11911 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11912       t3 = thetai-thet_pred_mean
11913       t6 = t3**2
11914       t9 = term1
11915       t12 = t3*sigcsq
11916       t14 = t12+t6*sigsqtc
11917       t16 = 1.0d0
11918       t21 = thetai-theta0i
11919       t23 = t21**2
11920       t26 = term2
11921       t27 = t21*t26
11922       t32 = termexp
11923       t40 = t32**2
11924       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11925        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11926        *(-t12*t9-ak*sig0inv*t27)
11927       return
11928       end subroutine mixder
11929 #endif
11930 !-----------------------------------------------------------------------------
11931 ! cartder.F
11932 !-----------------------------------------------------------------------------
11933       subroutine cartder
11934 !-----------------------------------------------------------------------------
11935 ! This subroutine calculates the derivatives of the consecutive virtual
11936 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11937 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11938 ! in the angles alpha and omega, describing the location of a side chain
11939 ! in its local coordinate system.
11940 !
11941 ! The derivatives are stored in the following arrays:
11942 !
11943 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11944 ! The structure is as follows:
11945 !
11946 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11947 ! 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)
11948 !         . . . . . . . . . . . .  . . . . . .
11949 ! 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)
11950 !                          .
11951 !                          .
11952 !                          .
11953 ! 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)
11954 !
11955 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11956 ! The structure is same as above.
11957 !
11958 ! DCDS - the derivatives of the side chain vectors in the local spherical
11959 ! andgles alph and omega:
11960 !
11961 ! 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)
11962 ! 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)
11963 !                          .
11964 !                          .
11965 !                          .
11966 ! 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)
11967 !
11968 ! Version of March '95, based on an early version of November '91.
11969 !
11970 !**********************************************************************
11971 !      implicit real*8 (a-h,o-z)
11972 !      include 'DIMENSIONS'
11973 !      include 'COMMON.VAR'
11974 !      include 'COMMON.CHAIN'
11975 !      include 'COMMON.DERIV'
11976 !      include 'COMMON.GEO'
11977 !      include 'COMMON.LOCAL'
11978 !      include 'COMMON.INTERACT'
11979       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11980       real(kind=8),dimension(3,3) :: dp,temp
11981 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11982       real(kind=8),dimension(3) :: xx,xx1
11983 !el local variables
11984       integer :: i,k,l,j,m,ind,ind1,jjj
11985       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11986                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11987                  sint2,xp,yp,xxp,yyp,zzp,dj
11988
11989 !      common /przechowalnia/ fromto
11990       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11991 ! get the position of the jth ijth fragment of the chain coordinate system
11992 ! in the fromto array.
11993 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11994 !
11995 !      maxdim=(nres-1)*(nres-2)/2
11996 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11997 ! calculate the derivatives of transformation matrix elements in theta
11998 !
11999
12000 !el      call flush(iout) !el
12001       do i=1,nres-2
12002         rdt(1,1,i)=-rt(1,2,i)
12003         rdt(1,2,i)= rt(1,1,i)
12004         rdt(1,3,i)= 0.0d0
12005         rdt(2,1,i)=-rt(2,2,i)
12006         rdt(2,2,i)= rt(2,1,i)
12007         rdt(2,3,i)= 0.0d0
12008         rdt(3,1,i)=-rt(3,2,i)
12009         rdt(3,2,i)= rt(3,1,i)
12010         rdt(3,3,i)= 0.0d0
12011       enddo
12012 !
12013 ! derivatives in phi
12014 !
12015       do i=2,nres-2
12016         drt(1,1,i)= 0.0d0
12017         drt(1,2,i)= 0.0d0
12018         drt(1,3,i)= 0.0d0
12019         drt(2,1,i)= rt(3,1,i)
12020         drt(2,2,i)= rt(3,2,i)
12021         drt(2,3,i)= rt(3,3,i)
12022         drt(3,1,i)=-rt(2,1,i)
12023         drt(3,2,i)=-rt(2,2,i)
12024         drt(3,3,i)=-rt(2,3,i)
12025       enddo
12026 !
12027 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12028 !
12029       do i=2,nres-2
12030         ind=indmat(i,i+1)
12031         do k=1,3
12032           do l=1,3
12033             temp(k,l)=rt(k,l,i)
12034           enddo
12035         enddo
12036         do k=1,3
12037           do l=1,3
12038             fromto(k,l,ind)=temp(k,l)
12039           enddo
12040         enddo
12041         do j=i+1,nres-2
12042           ind=indmat(i,j+1)
12043           do k=1,3
12044             do l=1,3
12045               dpkl=0.0d0
12046               do m=1,3
12047                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12048               enddo
12049               dp(k,l)=dpkl
12050               fromto(k,l,ind)=dpkl
12051             enddo
12052           enddo
12053           do k=1,3
12054             do l=1,3
12055               temp(k,l)=dp(k,l)
12056             enddo
12057           enddo
12058         enddo
12059       enddo
12060 !
12061 ! Calculate derivatives.
12062 !
12063       ind1=0
12064       do i=1,nres-2
12065       ind1=ind1+1
12066 !
12067 ! Derivatives of DC(i+1) in theta(i+2)
12068 !
12069         do j=1,3
12070           do k=1,2
12071             dpjk=0.0D0
12072             do l=1,3
12073               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12074             enddo
12075             dp(j,k)=dpjk
12076             prordt(j,k,i)=dp(j,k)
12077           enddo
12078           dp(j,3)=0.0D0
12079           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12080         enddo
12081 !
12082 ! Derivatives of SC(i+1) in theta(i+2)
12083 !
12084         xx1(1)=-0.5D0*xloc(2,i+1)
12085         xx1(2)= 0.5D0*xloc(1,i+1)
12086         do j=1,3
12087           xj=0.0D0
12088           do k=1,2
12089             xj=xj+r(j,k,i)*xx1(k)
12090           enddo
12091           xx(j)=xj
12092         enddo
12093         do j=1,3
12094           rj=0.0D0
12095           do k=1,3
12096             rj=rj+prod(j,k,i)*xx(k)
12097           enddo
12098           dxdv(j,ind1)=rj
12099         enddo
12100 !
12101 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12102 ! than the other off-diagonal derivatives.
12103 !
12104         do j=1,3
12105           dxoiij=0.0D0
12106           do k=1,3
12107             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12108           enddo
12109           dxdv(j,ind1+1)=dxoiij
12110         enddo
12111 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12112 !
12113 ! Derivatives of DC(i+1) in phi(i+2)
12114 !
12115         do j=1,3
12116           do k=1,3
12117             dpjk=0.0
12118             do l=2,3
12119               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12120             enddo
12121             dp(j,k)=dpjk
12122             prodrt(j,k,i)=dp(j,k)
12123           enddo
12124           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12125         enddo
12126 !
12127 ! Derivatives of SC(i+1) in phi(i+2)
12128 !
12129         xx(1)= 0.0D0
12130         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12131         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12132         do j=1,3
12133           rj=0.0D0
12134           do k=2,3
12135             rj=rj+prod(j,k,i)*xx(k)
12136           enddo
12137           dxdv(j+3,ind1)=-rj
12138         enddo
12139 !
12140 ! Derivatives of SC(i+1) in phi(i+3).
12141 !
12142         do j=1,3
12143           dxoiij=0.0D0
12144           do k=1,3
12145             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12146           enddo
12147           dxdv(j+3,ind1+1)=dxoiij
12148         enddo
12149 !
12150 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12151 ! theta(nres) and phi(i+3) thru phi(nres).
12152 !
12153         do j=i+1,nres-2
12154         ind1=ind1+1
12155         ind=indmat(i+1,j+1)
12156 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12157           do k=1,3
12158             do l=1,3
12159               tempkl=0.0D0
12160               do m=1,2
12161                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12162               enddo
12163               temp(k,l)=tempkl
12164             enddo
12165           enddo
12166 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12167 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12168 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12169 ! Derivatives of virtual-bond vectors in theta
12170           do k=1,3
12171             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12172           enddo
12173 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12174 ! Derivatives of SC vectors in theta
12175           do k=1,3
12176             dxoijk=0.0D0
12177             do l=1,3
12178               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12179             enddo
12180             dxdv(k,ind1+1)=dxoijk
12181           enddo
12182 !
12183 !--- Calculate the derivatives in phi
12184 !
12185           do k=1,3
12186             do l=1,3
12187               tempkl=0.0D0
12188               do m=1,3
12189                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12190               enddo
12191               temp(k,l)=tempkl
12192             enddo
12193           enddo
12194           do k=1,3
12195             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12196         enddo
12197           do k=1,3
12198             dxoijk=0.0D0
12199             do l=1,3
12200               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12201             enddo
12202             dxdv(k+3,ind1+1)=dxoijk
12203           enddo
12204         enddo
12205       enddo
12206 !
12207 ! Derivatives in alpha and omega:
12208 !
12209       do i=2,nres-1
12210 !       dsci=dsc(itype(i,1))
12211         dsci=vbld(i+nres)
12212 #ifdef OSF
12213         alphi=alph(i)
12214         omegi=omeg(i)
12215         if(alphi.ne.alphi) alphi=100.0
12216         if(omegi.ne.omegi) omegi=-100.0
12217 #else
12218       alphi=alph(i)
12219       omegi=omeg(i)
12220 #endif
12221 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12222       cosalphi=dcos(alphi)
12223       sinalphi=dsin(alphi)
12224       cosomegi=dcos(omegi)
12225       sinomegi=dsin(omegi)
12226       temp(1,1)=-dsci*sinalphi
12227       temp(2,1)= dsci*cosalphi*cosomegi
12228       temp(3,1)=-dsci*cosalphi*sinomegi
12229       temp(1,2)=0.0D0
12230       temp(2,2)=-dsci*sinalphi*sinomegi
12231       temp(3,2)=-dsci*sinalphi*cosomegi
12232       theta2=pi-0.5D0*theta(i+1)
12233       cost2=dcos(theta2)
12234       sint2=dsin(theta2)
12235       jjj=0
12236 !d      print *,((temp(l,k),l=1,3),k=1,2)
12237         do j=1,2
12238         xp=temp(1,j)
12239         yp=temp(2,j)
12240         xxp= xp*cost2+yp*sint2
12241         yyp=-xp*sint2+yp*cost2
12242         zzp=temp(3,j)
12243         xx(1)=xxp
12244         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12245         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12246         do k=1,3
12247           dj=0.0D0
12248           do l=1,3
12249             dj=dj+prod(k,l,i-1)*xx(l)
12250             enddo
12251           dxds(jjj+k,i)=dj
12252           enddo
12253         jjj=jjj+3
12254       enddo
12255       enddo
12256       return
12257       end subroutine cartder
12258 !-----------------------------------------------------------------------------
12259 ! checkder_p.F
12260 !-----------------------------------------------------------------------------
12261       subroutine check_cartgrad
12262 ! Check the gradient of Cartesian coordinates in internal coordinates.
12263 !      implicit real*8 (a-h,o-z)
12264 !      include 'DIMENSIONS'
12265 !      include 'COMMON.IOUNITS'
12266 !      include 'COMMON.VAR'
12267 !      include 'COMMON.CHAIN'
12268 !      include 'COMMON.GEO'
12269 !      include 'COMMON.LOCAL'
12270 !      include 'COMMON.DERIV'
12271       real(kind=8),dimension(6,nres) :: temp
12272       real(kind=8),dimension(3) :: xx,gg
12273       integer :: i,k,j,ii
12274       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12275 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12276 !
12277 ! Check the gradient of the virtual-bond and SC vectors in the internal
12278 ! coordinates.
12279 !
12280       aincr=1.0d-6
12281       aincr2=5.0d-7
12282       call cartder
12283       write (iout,'(a)') '**************** dx/dalpha'
12284       write (iout,'(a)')
12285       do i=2,nres-1
12286       alphi=alph(i)
12287       alph(i)=alph(i)+aincr
12288       do k=1,3
12289         temp(k,i)=dc(k,nres+i)
12290         enddo
12291       call chainbuild
12292       do k=1,3
12293         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12294         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12295         enddo
12296         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12297         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12298         write (iout,'(a)')
12299       alph(i)=alphi
12300       call chainbuild
12301       enddo
12302       write (iout,'(a)')
12303       write (iout,'(a)') '**************** dx/domega'
12304       write (iout,'(a)')
12305       do i=2,nres-1
12306       omegi=omeg(i)
12307       omeg(i)=omeg(i)+aincr
12308       do k=1,3
12309         temp(k,i)=dc(k,nres+i)
12310         enddo
12311       call chainbuild
12312       do k=1,3
12313           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12314           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12315                 (aincr*dabs(dxds(k+3,i))+aincr))
12316         enddo
12317         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12318             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12319         write (iout,'(a)')
12320       omeg(i)=omegi
12321       call chainbuild
12322       enddo
12323       write (iout,'(a)')
12324       write (iout,'(a)') '**************** dx/dtheta'
12325       write (iout,'(a)')
12326       do i=3,nres
12327       theti=theta(i)
12328         theta(i)=theta(i)+aincr
12329         do j=i-1,nres-1
12330           do k=1,3
12331             temp(k,j)=dc(k,nres+j)
12332           enddo
12333         enddo
12334         call chainbuild
12335         do j=i-1,nres-1
12336         ii = indmat(i-2,j)
12337 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12338         do k=1,3
12339           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12340           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12341                   (aincr*dabs(dxdv(k,ii))+aincr))
12342           enddo
12343           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12344               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12345           write(iout,'(a)')
12346         enddo
12347         write (iout,'(a)')
12348         theta(i)=theti
12349         call chainbuild
12350       enddo
12351       write (iout,'(a)') '***************** dx/dphi'
12352       write (iout,'(a)')
12353       do i=4,nres
12354         phi(i)=phi(i)+aincr
12355         do j=i-1,nres-1
12356           do k=1,3
12357             temp(k,j)=dc(k,nres+j)
12358           enddo
12359         enddo
12360         call chainbuild
12361         do j=i-1,nres-1
12362         ii = indmat(i-2,j)
12363 !         print *,'ii=',ii
12364         do k=1,3
12365           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12366             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12367                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12368           enddo
12369           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12370               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12371           write(iout,'(a)')
12372         enddo
12373         phi(i)=phi(i)-aincr
12374         call chainbuild
12375       enddo
12376       write (iout,'(a)') '****************** ddc/dtheta'
12377       do i=1,nres-2
12378         thet=theta(i+2)
12379         theta(i+2)=thet+aincr
12380         do j=i,nres
12381           do k=1,3
12382             temp(k,j)=dc(k,j)
12383           enddo
12384         enddo
12385         call chainbuild
12386         do j=i+1,nres-1
12387         ii = indmat(i,j)
12388 !         print *,'ii=',ii
12389         do k=1,3
12390           gg(k)=(dc(k,j)-temp(k,j))/aincr
12391           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12392                  (aincr*dabs(dcdv(k,ii))+aincr))
12393           enddo
12394           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12395                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12396         write (iout,'(a)')
12397         enddo
12398         do j=1,nres
12399           do k=1,3
12400             dc(k,j)=temp(k,j)
12401           enddo
12402         enddo
12403         theta(i+2)=thet
12404       enddo
12405       write (iout,'(a)') '******************* ddc/dphi'
12406       do i=1,nres-3
12407         phii=phi(i+3)
12408         phi(i+3)=phii+aincr
12409         do j=1,nres
12410           do k=1,3
12411             temp(k,j)=dc(k,j)
12412           enddo
12413         enddo
12414         call chainbuild
12415         do j=i+2,nres-1
12416         ii = indmat(i+1,j)
12417 !         print *,'ii=',ii
12418         do k=1,3
12419           gg(k)=(dc(k,j)-temp(k,j))/aincr
12420             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12421                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12422           enddo
12423           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12424                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12425         write (iout,'(a)')
12426         enddo
12427         do j=1,nres
12428           do k=1,3
12429             dc(k,j)=temp(k,j)
12430           enddo
12431         enddo
12432         phi(i+3)=phii
12433       enddo
12434       return
12435       end subroutine check_cartgrad
12436 !-----------------------------------------------------------------------------
12437       subroutine check_ecart
12438 ! Check the gradient of the energy in Cartesian coordinates.
12439 !     implicit real*8 (a-h,o-z)
12440 !     include 'DIMENSIONS'
12441 !     include 'COMMON.CHAIN'
12442 !     include 'COMMON.DERIV'
12443 !     include 'COMMON.IOUNITS'
12444 !     include 'COMMON.VAR'
12445 !     include 'COMMON.CONTACTS'
12446       use comm_srutu
12447 !el      integer :: icall
12448 !el      common /srutu/ icall
12449       real(kind=8),dimension(6) :: ggg
12450       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12451       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12452       real(kind=8),dimension(6,nres) :: grad_s
12453       real(kind=8),dimension(0:n_ene) :: energia,energia1
12454       integer :: uiparm(1)
12455       real(kind=8) :: urparm(1)
12456 !EL      external fdum
12457       integer :: nf,i,j,k
12458       real(kind=8) :: aincr,etot,etot1
12459       icg=1
12460       nf=0
12461       nfl=0
12462       call zerograd
12463       aincr=1.0D-5
12464       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12465       nf=0
12466       icall=0
12467       call geom_to_var(nvar,x)
12468       call etotal(energia)
12469       etot=energia(0)
12470 !el      call enerprint(energia)
12471       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12472       icall =1
12473       do i=1,nres
12474         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12475       enddo
12476       do i=1,nres
12477       do j=1,3
12478         grad_s(j,i)=gradc(j,i,icg)
12479         grad_s(j+3,i)=gradx(j,i,icg)
12480         enddo
12481       enddo
12482       call flush(iout)
12483       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12484       do i=1,nres
12485         do j=1,3
12486         xx(j)=c(j,i+nres)
12487         ddc(j)=dc(j,i)
12488         ddx(j)=dc(j,i+nres)
12489         enddo
12490       do j=1,3
12491         dc(j,i)=dc(j,i)+aincr
12492         do k=i+1,nres
12493           c(j,k)=c(j,k)+aincr
12494           c(j,k+nres)=c(j,k+nres)+aincr
12495           enddo
12496           call zerograd
12497           call etotal(energia1)
12498           etot1=energia1(0)
12499         ggg(j)=(etot1-etot)/aincr
12500         dc(j,i)=ddc(j)
12501         do k=i+1,nres
12502           c(j,k)=c(j,k)-aincr
12503           c(j,k+nres)=c(j,k+nres)-aincr
12504           enddo
12505         enddo
12506       do j=1,3
12507         c(j,i+nres)=c(j,i+nres)+aincr
12508         dc(j,i+nres)=dc(j,i+nres)+aincr
12509           call zerograd
12510           call etotal(energia1)
12511           etot1=energia1(0)
12512         ggg(j+3)=(etot1-etot)/aincr
12513         c(j,i+nres)=xx(j)
12514         dc(j,i+nres)=ddx(j)
12515         enddo
12516       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12517          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12518       enddo
12519       return
12520       end subroutine check_ecart
12521 #ifdef CARGRAD
12522 !-----------------------------------------------------------------------------
12523       subroutine check_ecartint
12524 ! Check the gradient of the energy in Cartesian coordinates.
12525       use io_base, only: intout
12526 !      implicit real*8 (a-h,o-z)
12527 !      include 'DIMENSIONS'
12528 !      include 'COMMON.CONTROL'
12529 !      include 'COMMON.CHAIN'
12530 !      include 'COMMON.DERIV'
12531 !      include 'COMMON.IOUNITS'
12532 !      include 'COMMON.VAR'
12533 !      include 'COMMON.CONTACTS'
12534 !      include 'COMMON.MD'
12535 !      include 'COMMON.LOCAL'
12536 !      include 'COMMON.SPLITELE'
12537       use comm_srutu
12538 !el      integer :: icall
12539 !el      common /srutu/ icall
12540       real(kind=8),dimension(6) :: ggg,ggg1
12541       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12542       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12543       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12544       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12545       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12546       real(kind=8),dimension(0:n_ene) :: energia,energia1
12547       integer :: uiparm(1)
12548       real(kind=8) :: urparm(1)
12549 !EL      external fdum
12550       integer :: i,j,k,nf
12551       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12552                    etot21,etot22
12553       r_cut=2.0d0
12554       rlambd=0.3d0
12555       icg=1
12556       nf=0
12557       nfl=0
12558       call intout
12559 !      call intcartderiv
12560 !      call checkintcartgrad
12561       call zerograd
12562       aincr=1.0D-4
12563       write(iout,*) 'Calling CHECK_ECARTINT.'
12564       nf=0
12565       icall=0
12566       call geom_to_var(nvar,x)
12567       write (iout,*) "split_ene ",split_ene
12568       call flush(iout)
12569       if (.not.split_ene) then
12570         call zerograd
12571         call etotal(energia)
12572         etot=energia(0)
12573         call cartgrad
12574         icall =1
12575         do i=1,nres
12576           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12577         enddo
12578         do j=1,3
12579           grad_s(j,0)=gcart(j,0)
12580         enddo
12581         do i=1,nres
12582           do j=1,3
12583             grad_s(j,i)=gcart(j,i)
12584             grad_s(j+3,i)=gxcart(j,i)
12585           enddo
12586         enddo
12587       else
12588 !- split gradient check
12589         call zerograd
12590         call etotal_long(energia)
12591 !el        call enerprint(energia)
12592         call cartgrad
12593         icall =1
12594         do i=1,nres
12595           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12596           (gxcart(j,i),j=1,3)
12597         enddo
12598         do j=1,3
12599           grad_s(j,0)=gcart(j,0)
12600         enddo
12601         do i=1,nres
12602           do j=1,3
12603             grad_s(j,i)=gcart(j,i)
12604             grad_s(j+3,i)=gxcart(j,i)
12605           enddo
12606         enddo
12607         call zerograd
12608         call etotal_short(energia)
12609         call enerprint(energia)
12610         call cartgrad
12611         icall =1
12612         do i=1,nres
12613           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12614           (gxcart(j,i),j=1,3)
12615         enddo
12616         do j=1,3
12617           grad_s1(j,0)=gcart(j,0)
12618         enddo
12619         do i=1,nres
12620           do j=1,3
12621             grad_s1(j,i)=gcart(j,i)
12622             grad_s1(j+3,i)=gxcart(j,i)
12623           enddo
12624         enddo
12625       endif
12626       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12627 !      do i=1,nres
12628       do i=nnt,nct
12629         do j=1,3
12630           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12631           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12632         ddc(j)=c(j,i)
12633         ddx(j)=c(j,i+nres)
12634           dcnorm_safe1(j)=dc_norm(j,i-1)
12635           dcnorm_safe2(j)=dc_norm(j,i)
12636           dxnorm_safe(j)=dc_norm(j,i+nres)
12637         enddo
12638       do j=1,3
12639         c(j,i)=ddc(j)+aincr
12640           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12641           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12642           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12643           dc(j,i)=c(j,i+1)-c(j,i)
12644           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12645           call int_from_cart1(.false.)
12646           if (.not.split_ene) then
12647            call zerograd
12648             call etotal(energia1)
12649             etot1=energia1(0)
12650             write (iout,*) "ij",i,j," etot1",etot1
12651           else
12652 !- split gradient
12653             call etotal_long(energia1)
12654             etot11=energia1(0)
12655             call etotal_short(energia1)
12656             etot12=energia1(0)
12657           endif
12658 !- end split gradient
12659 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12660         c(j,i)=ddc(j)-aincr
12661           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12662           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12663           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12664           dc(j,i)=c(j,i+1)-c(j,i)
12665           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12666           call int_from_cart1(.false.)
12667           if (.not.split_ene) then
12668             call zerograd
12669             call etotal(energia1)
12670             etot2=energia1(0)
12671             write (iout,*) "ij",i,j," etot2",etot2
12672           ggg(j)=(etot1-etot2)/(2*aincr)
12673           else
12674 !- split gradient
12675             call etotal_long(energia1)
12676             etot21=energia1(0)
12677           ggg(j)=(etot11-etot21)/(2*aincr)
12678             call etotal_short(energia1)
12679             etot22=energia1(0)
12680           ggg1(j)=(etot12-etot22)/(2*aincr)
12681 !- end split gradient
12682 !            write (iout,*) "etot21",etot21," etot22",etot22
12683           endif
12684 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12685         c(j,i)=ddc(j)
12686           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12687           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12688           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12689           dc(j,i)=c(j,i+1)-c(j,i)
12690           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12691           dc_norm(j,i-1)=dcnorm_safe1(j)
12692           dc_norm(j,i)=dcnorm_safe2(j)
12693           dc_norm(j,i+nres)=dxnorm_safe(j)
12694         enddo
12695       do j=1,3
12696         c(j,i+nres)=ddx(j)+aincr
12697           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12698           call int_from_cart1(.false.)
12699           if (.not.split_ene) then
12700             call zerograd
12701             call etotal(energia1)
12702             etot1=energia1(0)
12703           else
12704 !- split gradient
12705             call etotal_long(energia1)
12706             etot11=energia1(0)
12707             call etotal_short(energia1)
12708             etot12=energia1(0)
12709           endif
12710 !- end split gradient
12711         c(j,i+nres)=ddx(j)-aincr
12712           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12713           call int_from_cart1(.false.)
12714           if (.not.split_ene) then
12715            call zerograd
12716            call etotal(energia1)
12717             etot2=energia1(0)
12718           ggg(j+3)=(etot1-etot2)/(2*aincr)
12719           else
12720 !- split gradient
12721             call etotal_long(energia1)
12722             etot21=energia1(0)
12723           ggg(j+3)=(etot11-etot21)/(2*aincr)
12724             call etotal_short(energia1)
12725             etot22=energia1(0)
12726           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12727 !- end split gradient
12728           endif
12729 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12730         c(j,i+nres)=ddx(j)
12731           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12732           dc_norm(j,i+nres)=dxnorm_safe(j)
12733           call int_from_cart1(.false.)
12734         enddo
12735       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12736          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12737         if (split_ene) then
12738           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12739          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12740          k=1,6)
12741          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12742          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12743          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12744         endif
12745       enddo
12746       return
12747       end subroutine check_ecartint
12748 #else
12749 !-----------------------------------------------------------------------------
12750       subroutine check_ecartint
12751 ! Check the gradient of the energy in Cartesian coordinates.
12752       use io_base, only: intout
12753 !      implicit real*8 (a-h,o-z)
12754 !      include 'DIMENSIONS'
12755 !      include 'COMMON.CONTROL'
12756 !      include 'COMMON.CHAIN'
12757 !      include 'COMMON.DERIV'
12758 !      include 'COMMON.IOUNITS'
12759 !      include 'COMMON.VAR'
12760 !      include 'COMMON.CONTACTS'
12761 !      include 'COMMON.MD'
12762 !      include 'COMMON.LOCAL'
12763 !      include 'COMMON.SPLITELE'
12764       use comm_srutu
12765 !el      integer :: icall
12766 !el      common /srutu/ icall
12767       real(kind=8),dimension(6) :: ggg,ggg1
12768       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12769       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12770       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12771       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12772       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12773       real(kind=8),dimension(0:n_ene) :: energia,energia1
12774       integer :: uiparm(1)
12775       real(kind=8) :: urparm(1)
12776 !EL      external fdum
12777       integer :: i,j,k,nf
12778       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12779                    etot21,etot22
12780       r_cut=2.0d0
12781       rlambd=0.3d0
12782       icg=1
12783       nf=0
12784       nfl=0
12785       call intout
12786 !      call intcartderiv
12787 !      call checkintcartgrad
12788       call zerograd
12789       aincr=1.0D-7
12790       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12791       nf=0
12792       icall=0
12793       call geom_to_var(nvar,x)
12794       if (.not.split_ene) then
12795         call etotal(energia)
12796         etot=energia(0)
12797 !el        call enerprint(energia)
12798         call cartgrad
12799         icall =1
12800         do i=1,nres
12801           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12802         enddo
12803         do j=1,3
12804           grad_s(j,0)=gcart(j,0)
12805         enddo
12806         do i=1,nres
12807           do j=1,3
12808             grad_s(j,i)=gcart(j,i)
12809 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12810
12811 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12812             grad_s(j+3,i)=gxcart(j,i)
12813           enddo
12814         enddo
12815       else
12816 !- split gradient check
12817         call zerograd
12818         call etotal_long(energia)
12819 !el        call enerprint(energia)
12820         call cartgrad
12821         icall =1
12822         do i=1,nres
12823           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12824           (gxcart(j,i),j=1,3)
12825         enddo
12826         do j=1,3
12827           grad_s(j,0)=gcart(j,0)
12828         enddo
12829         do i=1,nres
12830           do j=1,3
12831             grad_s(j,i)=gcart(j,i)
12832 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12833             grad_s(j+3,i)=gxcart(j,i)
12834           enddo
12835         enddo
12836         call zerograd
12837         call etotal_short(energia)
12838 !el        call enerprint(energia)
12839         call cartgrad
12840         icall =1
12841         do i=1,nres
12842           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12843           (gxcart(j,i),j=1,3)
12844         enddo
12845         do j=1,3
12846           grad_s1(j,0)=gcart(j,0)
12847         enddo
12848         do i=1,nres
12849           do j=1,3
12850             grad_s1(j,i)=gcart(j,i)
12851             grad_s1(j+3,i)=gxcart(j,i)
12852           enddo
12853         enddo
12854       endif
12855       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12856       do i=0,nres
12857         do j=1,3
12858         xx(j)=c(j,i+nres)
12859         ddc(j)=dc(j,i)
12860         ddx(j)=dc(j,i+nres)
12861           do k=1,3
12862             dcnorm_safe(k)=dc_norm(k,i)
12863             dxnorm_safe(k)=dc_norm(k,i+nres)
12864           enddo
12865         enddo
12866       do j=1,3
12867         dc(j,i)=ddc(j)+aincr
12868           call chainbuild_cart
12869 #ifdef MPI
12870 ! Broadcast the order to compute internal coordinates to the slaves.
12871 !          if (nfgtasks.gt.1)
12872 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12873 #endif
12874 !          call int_from_cart1(.false.)
12875           if (.not.split_ene) then
12876            call zerograd
12877             call etotal(energia1)
12878             etot1=energia1(0)
12879 !            call enerprint(energia1)
12880           else
12881 !- split gradient
12882             call etotal_long(energia1)
12883             etot11=energia1(0)
12884             call etotal_short(energia1)
12885             etot12=energia1(0)
12886 !            write (iout,*) "etot11",etot11," etot12",etot12
12887           endif
12888 !- end split gradient
12889 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12890         dc(j,i)=ddc(j)-aincr
12891           call chainbuild_cart
12892 !          call int_from_cart1(.false.)
12893           if (.not.split_ene) then
12894                   call zerograd
12895             call etotal(energia1)
12896             etot2=energia1(0)
12897           ggg(j)=(etot1-etot2)/(2*aincr)
12898           else
12899 !- split gradient
12900             call etotal_long(energia1)
12901             etot21=energia1(0)
12902           ggg(j)=(etot11-etot21)/(2*aincr)
12903             call etotal_short(energia1)
12904             etot22=energia1(0)
12905           ggg1(j)=(etot12-etot22)/(2*aincr)
12906 !- end split gradient
12907 !            write (iout,*) "etot21",etot21," etot22",etot22
12908           endif
12909 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12910         dc(j,i)=ddc(j)
12911           call chainbuild_cart
12912         enddo
12913       do j=1,3
12914         dc(j,i+nres)=ddx(j)+aincr
12915           call chainbuild_cart
12916 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12917 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12918 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12919 !          write (iout,*) "dxnormnorm",dsqrt(
12920 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12921 !          write (iout,*) "dxnormnormsafe",dsqrt(
12922 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12923 !          write (iout,*)
12924           if (.not.split_ene) then
12925             call zerograd
12926             call etotal(energia1)
12927             etot1=energia1(0)
12928           else
12929 !- split gradient
12930             call etotal_long(energia1)
12931             etot11=energia1(0)
12932             call etotal_short(energia1)
12933             etot12=energia1(0)
12934           endif
12935 !- end split gradient
12936 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12937         dc(j,i+nres)=ddx(j)-aincr
12938           call chainbuild_cart
12939 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12940 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12941 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12942 !          write (iout,*)
12943 !          write (iout,*) "dxnormnorm",dsqrt(
12944 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12945 !          write (iout,*) "dxnormnormsafe",dsqrt(
12946 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12947           if (.not.split_ene) then
12948             call zerograd
12949             call etotal(energia1)
12950             etot2=energia1(0)
12951           ggg(j+3)=(etot1-etot2)/(2*aincr)
12952           else
12953 !- split gradient
12954             call etotal_long(energia1)
12955             etot21=energia1(0)
12956           ggg(j+3)=(etot11-etot21)/(2*aincr)
12957             call etotal_short(energia1)
12958             etot22=energia1(0)
12959           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12960 !- end split gradient
12961           endif
12962 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12963         dc(j,i+nres)=ddx(j)
12964           call chainbuild_cart
12965         enddo
12966       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12967          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12968         if (split_ene) then
12969           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12970          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12971          k=1,6)
12972          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12973          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12974          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12975         endif
12976       enddo
12977       return
12978       end subroutine check_ecartint
12979 #endif
12980 !-----------------------------------------------------------------------------
12981       subroutine check_eint
12982 ! Check the gradient of energy in internal coordinates.
12983 !      implicit real*8 (a-h,o-z)
12984 !      include 'DIMENSIONS'
12985 !      include 'COMMON.CHAIN'
12986 !      include 'COMMON.DERIV'
12987 !      include 'COMMON.IOUNITS'
12988 !      include 'COMMON.VAR'
12989 !      include 'COMMON.GEO'
12990       use comm_srutu
12991 !el      integer :: icall
12992 !el      common /srutu/ icall
12993       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12994       integer :: uiparm(1)
12995       real(kind=8) :: urparm(1)
12996       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12997       character(len=6) :: key
12998 !EL      external fdum
12999       integer :: i,ii,nf
13000       real(kind=8) :: xi,aincr,etot,etot1,etot2
13001       call zerograd
13002       aincr=1.0D-7
13003       print '(a)','Calling CHECK_INT.'
13004       nf=0
13005       nfl=0
13006       icg=1
13007       call geom_to_var(nvar,x)
13008       call var_to_geom(nvar,x)
13009       call chainbuild
13010       icall=1
13011 !      print *,'ICG=',ICG
13012       call etotal(energia)
13013       etot = energia(0)
13014 !el      call enerprint(energia)
13015 !      print *,'ICG=',ICG
13016 #ifdef MPL
13017       if (MyID.ne.BossID) then
13018         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13019         nf=x(nvar+1)
13020         nfl=x(nvar+2)
13021         icg=x(nvar+3)
13022       endif
13023 #endif
13024       nf=1
13025       nfl=3
13026 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13027       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13028 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13029       icall=1
13030       do i=1,nvar
13031         xi=x(i)
13032         x(i)=xi-0.5D0*aincr
13033         call var_to_geom(nvar,x)
13034         call chainbuild
13035         call etotal(energia1)
13036         etot1=energia1(0)
13037         x(i)=xi+0.5D0*aincr
13038         call var_to_geom(nvar,x)
13039         call chainbuild
13040         call etotal(energia2)
13041         etot2=energia2(0)
13042         gg(i)=(etot2-etot1)/aincr
13043         write (iout,*) i,etot1,etot2
13044         x(i)=xi
13045       enddo
13046       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13047           '     RelDiff*100% '
13048       do i=1,nvar
13049         if (i.le.nphi) then
13050           ii=i
13051           key = ' phi'
13052         else if (i.le.nphi+ntheta) then
13053           ii=i-nphi
13054           key=' theta'
13055         else if (i.le.nphi+ntheta+nside) then
13056            ii=i-(nphi+ntheta)
13057            key=' alpha'
13058         else
13059            ii=i-(nphi+ntheta+nside)
13060            key=' omega'
13061         endif
13062         write (iout,'(i3,a,i3,3(1pd16.6))') &
13063        i,key,ii,gg(i),gana(i),&
13064        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13065       enddo
13066       return
13067       end subroutine check_eint
13068 !-----------------------------------------------------------------------------
13069 ! econstr_local.F
13070 !-----------------------------------------------------------------------------
13071       subroutine Econstr_back
13072 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13073 !      implicit real*8 (a-h,o-z)
13074 !      include 'DIMENSIONS'
13075 !      include 'COMMON.CONTROL'
13076 !      include 'COMMON.VAR'
13077 !      include 'COMMON.MD'
13078       use MD_data
13079 !#ifndef LANG0
13080 !      include 'COMMON.LANGEVIN'
13081 !#else
13082 !      include 'COMMON.LANGEVIN.lang0'
13083 !#endif
13084 !      include 'COMMON.CHAIN'
13085 !      include 'COMMON.DERIV'
13086 !      include 'COMMON.GEO'
13087 !      include 'COMMON.LOCAL'
13088 !      include 'COMMON.INTERACT'
13089 !      include 'COMMON.IOUNITS'
13090 !      include 'COMMON.NAMES'
13091 !      include 'COMMON.TIME1'
13092       integer :: i,j,ii,k
13093       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13094
13095       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13096       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13097       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13098
13099       Uconst_back=0.0d0
13100       do i=1,nres
13101         dutheta(i)=0.0d0
13102         dugamma(i)=0.0d0
13103         do j=1,3
13104           duscdiff(j,i)=0.0d0
13105           duscdiffx(j,i)=0.0d0
13106         enddo
13107       enddo
13108       do i=1,nfrag_back
13109         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13110 !
13111 ! Deviations from theta angles
13112 !
13113         utheta_i=0.0d0
13114         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13115           dtheta_i=theta(j)-thetaref(j)
13116           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13117           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13118         enddo
13119         utheta(i)=utheta_i/(ii-1)
13120 !
13121 ! Deviations from gamma angles
13122 !
13123         ugamma_i=0.0d0
13124         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13125           dgamma_i=pinorm(phi(j)-phiref(j))
13126 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13127           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13128           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13129 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13130         enddo
13131         ugamma(i)=ugamma_i/(ii-2)
13132 !
13133 ! Deviations from local SC geometry
13134 !
13135         uscdiff(i)=0.0d0
13136         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13137           dxx=xxtab(j)-xxref(j)
13138           dyy=yytab(j)-yyref(j)
13139           dzz=zztab(j)-zzref(j)
13140           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13141           do k=1,3
13142             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13143              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13144              (ii-1)
13145             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13146              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13147              (ii-1)
13148             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13149            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13150             /(ii-1)
13151           enddo
13152 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13153 !     &      xxref(j),yyref(j),zzref(j)
13154         enddo
13155         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13156 !        write (iout,*) i," uscdiff",uscdiff(i)
13157 !
13158 ! Put together deviations from local geometry
13159 !
13160         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13161           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13162 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13163 !     &   " uconst_back",uconst_back
13164         utheta(i)=dsqrt(utheta(i))
13165         ugamma(i)=dsqrt(ugamma(i))
13166         uscdiff(i)=dsqrt(uscdiff(i))
13167       enddo
13168       return
13169       end subroutine Econstr_back
13170 !-----------------------------------------------------------------------------
13171 ! energy_p_new-sep_barrier.F
13172 !-----------------------------------------------------------------------------
13173       real(kind=8) function sscale(r)
13174 !      include "COMMON.SPLITELE"
13175       real(kind=8) :: r,gamm
13176       if(r.lt.r_cut-rlamb) then
13177         sscale=1.0d0
13178       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13179         gamm=(r-(r_cut-rlamb))/rlamb
13180         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13181       else
13182         sscale=0d0
13183       endif
13184       return
13185       end function sscale
13186       real(kind=8) function sscale_grad(r)
13187 !      include "COMMON.SPLITELE"
13188       real(kind=8) :: r,gamm
13189       if(r.lt.r_cut-rlamb) then
13190         sscale_grad=0.0d0
13191       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13192         gamm=(r-(r_cut-rlamb))/rlamb
13193         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13194       else
13195         sscale_grad=0d0
13196       endif
13197       return
13198       end function sscale_grad
13199
13200 !!!!!!!!!! PBCSCALE
13201       real(kind=8) function sscale_ele(r)
13202 !      include "COMMON.SPLITELE"
13203       real(kind=8) :: r,gamm
13204       if(r.lt.r_cut_ele-rlamb_ele) then
13205         sscale_ele=1.0d0
13206       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13207         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13208         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13209       else
13210         sscale_ele=0d0
13211       endif
13212       return
13213       end function sscale_ele
13214
13215       real(kind=8)  function sscagrad_ele(r)
13216       real(kind=8) :: r,gamm
13217 !      include "COMMON.SPLITELE"
13218       if(r.lt.r_cut_ele-rlamb_ele) then
13219         sscagrad_ele=0.0d0
13220       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13221         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13222         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13223       else
13224         sscagrad_ele=0.0d0
13225       endif
13226       return
13227       end function sscagrad_ele
13228       real(kind=8) function sscalelip(r)
13229       real(kind=8) r,gamm
13230         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13231       return
13232       end function sscalelip
13233 !C-----------------------------------------------------------------------
13234       real(kind=8) function sscagradlip(r)
13235       real(kind=8) r,gamm
13236         sscagradlip=r*(6.0d0*r-6.0d0)
13237       return
13238       end function sscagradlip
13239
13240 !!!!!!!!!!!!!!!
13241 !-----------------------------------------------------------------------------
13242       subroutine elj_long(evdw)
13243 !
13244 ! This subroutine calculates the interaction energy of nonbonded side chains
13245 ! assuming the LJ potential of interaction.
13246 !
13247 !      implicit real*8 (a-h,o-z)
13248 !      include 'DIMENSIONS'
13249 !      include 'COMMON.GEO'
13250 !      include 'COMMON.VAR'
13251 !      include 'COMMON.LOCAL'
13252 !      include 'COMMON.CHAIN'
13253 !      include 'COMMON.DERIV'
13254 !      include 'COMMON.INTERACT'
13255 !      include 'COMMON.TORSION'
13256 !      include 'COMMON.SBRIDGE'
13257 !      include 'COMMON.NAMES'
13258 !      include 'COMMON.IOUNITS'
13259 !      include 'COMMON.CONTACTS'
13260       real(kind=8),parameter :: accur=1.0d-10
13261       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13262 !el local variables
13263       integer :: i,iint,j,k,itypi,itypi1,itypj
13264       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13265       real(kind=8) :: e1,e2,evdwij,evdw
13266 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13267       evdw=0.0D0
13268       do i=iatsc_s,iatsc_e
13269         itypi=itype(i,1)
13270         if (itypi.eq.ntyp1) cycle
13271         itypi1=itype(i+1,1)
13272         xi=c(1,nres+i)
13273         yi=c(2,nres+i)
13274         zi=c(3,nres+i)
13275 !
13276 ! Calculate SC interaction energy.
13277 !
13278         do iint=1,nint_gr(i)
13279 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13280 !d   &                  'iend=',iend(i,iint)
13281           do j=istart(i,iint),iend(i,iint)
13282             itypj=itype(j,1)
13283             if (itypj.eq.ntyp1) cycle
13284             xj=c(1,nres+j)-xi
13285             yj=c(2,nres+j)-yi
13286             zj=c(3,nres+j)-zi
13287             rij=xj*xj+yj*yj+zj*zj
13288             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13289             if (sss.lt.1.0d0) then
13290               rrij=1.0D0/rij
13291               eps0ij=eps(itypi,itypj)
13292               fac=rrij**expon2
13293               e1=fac*fac*aa_aq(itypi,itypj)
13294               e2=fac*bb_aq(itypi,itypj)
13295               evdwij=e1+e2
13296               evdw=evdw+(1.0d0-sss)*evdwij
13297 !
13298 ! Calculate the components of the gradient in DC and X
13299 !
13300               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13301               gg(1)=xj*fac
13302               gg(2)=yj*fac
13303               gg(3)=zj*fac
13304               do k=1,3
13305                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13306                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13307                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13308                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13309               enddo
13310             endif
13311           enddo      ! j
13312         enddo        ! iint
13313       enddo          ! i
13314       do i=1,nct
13315         do j=1,3
13316           gvdwc(j,i)=expon*gvdwc(j,i)
13317           gvdwx(j,i)=expon*gvdwx(j,i)
13318         enddo
13319       enddo
13320 !******************************************************************************
13321 !
13322 !                              N O T E !!!
13323 !
13324 ! To save time, the factor of EXPON has been extracted from ALL components
13325 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13326 ! use!
13327 !
13328 !******************************************************************************
13329       return
13330       end subroutine elj_long
13331 !-----------------------------------------------------------------------------
13332       subroutine elj_short(evdw)
13333 !
13334 ! This subroutine calculates the interaction energy of nonbonded side chains
13335 ! assuming the LJ potential of interaction.
13336 !
13337 !      implicit real*8 (a-h,o-z)
13338 !      include 'DIMENSIONS'
13339 !      include 'COMMON.GEO'
13340 !      include 'COMMON.VAR'
13341 !      include 'COMMON.LOCAL'
13342 !      include 'COMMON.CHAIN'
13343 !      include 'COMMON.DERIV'
13344 !      include 'COMMON.INTERACT'
13345 !      include 'COMMON.TORSION'
13346 !      include 'COMMON.SBRIDGE'
13347 !      include 'COMMON.NAMES'
13348 !      include 'COMMON.IOUNITS'
13349 !      include 'COMMON.CONTACTS'
13350       real(kind=8),parameter :: accur=1.0d-10
13351       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13352 !el local variables
13353       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13354       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13355       real(kind=8) :: e1,e2,evdwij,evdw
13356 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13357       evdw=0.0D0
13358       do i=iatsc_s,iatsc_e
13359         itypi=itype(i,1)
13360         if (itypi.eq.ntyp1) cycle
13361         itypi1=itype(i+1,1)
13362         xi=c(1,nres+i)
13363         yi=c(2,nres+i)
13364         zi=c(3,nres+i)
13365 ! Change 12/1/95
13366         num_conti=0
13367 !
13368 ! Calculate SC interaction energy.
13369 !
13370         do iint=1,nint_gr(i)
13371 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13372 !d   &                  'iend=',iend(i,iint)
13373           do j=istart(i,iint),iend(i,iint)
13374             itypj=itype(j,1)
13375             if (itypj.eq.ntyp1) cycle
13376             xj=c(1,nres+j)-xi
13377             yj=c(2,nres+j)-yi
13378             zj=c(3,nres+j)-zi
13379 ! Change 12/1/95 to calculate four-body interactions
13380             rij=xj*xj+yj*yj+zj*zj
13381             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13382             if (sss.gt.0.0d0) then
13383               rrij=1.0D0/rij
13384               eps0ij=eps(itypi,itypj)
13385               fac=rrij**expon2
13386               e1=fac*fac*aa_aq(itypi,itypj)
13387               e2=fac*bb_aq(itypi,itypj)
13388               evdwij=e1+e2
13389               evdw=evdw+sss*evdwij
13390 !
13391 ! Calculate the components of the gradient in DC and X
13392 !
13393               fac=-rrij*(e1+evdwij)*sss
13394               gg(1)=xj*fac
13395               gg(2)=yj*fac
13396               gg(3)=zj*fac
13397               do k=1,3
13398                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13399                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13400                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13401                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13402               enddo
13403             endif
13404           enddo      ! j
13405         enddo        ! iint
13406       enddo          ! i
13407       do i=1,nct
13408         do j=1,3
13409           gvdwc(j,i)=expon*gvdwc(j,i)
13410           gvdwx(j,i)=expon*gvdwx(j,i)
13411         enddo
13412       enddo
13413 !******************************************************************************
13414 !
13415 !                              N O T E !!!
13416 !
13417 ! To save time, the factor of EXPON has been extracted from ALL components
13418 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13419 ! use!
13420 !
13421 !******************************************************************************
13422       return
13423       end subroutine elj_short
13424 !-----------------------------------------------------------------------------
13425       subroutine eljk_long(evdw)
13426 !
13427 ! This subroutine calculates the interaction energy of nonbonded side chains
13428 ! assuming the LJK potential of interaction.
13429 !
13430 !      implicit real*8 (a-h,o-z)
13431 !      include 'DIMENSIONS'
13432 !      include 'COMMON.GEO'
13433 !      include 'COMMON.VAR'
13434 !      include 'COMMON.LOCAL'
13435 !      include 'COMMON.CHAIN'
13436 !      include 'COMMON.DERIV'
13437 !      include 'COMMON.INTERACT'
13438 !      include 'COMMON.IOUNITS'
13439 !      include 'COMMON.NAMES'
13440       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13441       logical :: scheck
13442 !el local variables
13443       integer :: i,iint,j,k,itypi,itypi1,itypj
13444       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13445                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13446 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13447       evdw=0.0D0
13448       do i=iatsc_s,iatsc_e
13449         itypi=itype(i,1)
13450         if (itypi.eq.ntyp1) cycle
13451         itypi1=itype(i+1,1)
13452         xi=c(1,nres+i)
13453         yi=c(2,nres+i)
13454         zi=c(3,nres+i)
13455 !
13456 ! Calculate SC interaction energy.
13457 !
13458         do iint=1,nint_gr(i)
13459           do j=istart(i,iint),iend(i,iint)
13460             itypj=itype(j,1)
13461             if (itypj.eq.ntyp1) cycle
13462             xj=c(1,nres+j)-xi
13463             yj=c(2,nres+j)-yi
13464             zj=c(3,nres+j)-zi
13465             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13466             fac_augm=rrij**expon
13467             e_augm=augm(itypi,itypj)*fac_augm
13468             r_inv_ij=dsqrt(rrij)
13469             rij=1.0D0/r_inv_ij
13470             sss=sscale(rij/sigma(itypi,itypj))
13471             if (sss.lt.1.0d0) then
13472               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13473               fac=r_shift_inv**expon
13474               e1=fac*fac*aa_aq(itypi,itypj)
13475               e2=fac*bb_aq(itypi,itypj)
13476               evdwij=e_augm+e1+e2
13477 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13478 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13479 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13480 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13481 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13482 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13483 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13484               evdw=evdw+(1.0d0-sss)*evdwij
13485 !
13486 ! Calculate the components of the gradient in DC and X
13487 !
13488               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13489               fac=fac*(1.0d0-sss)
13490               gg(1)=xj*fac
13491               gg(2)=yj*fac
13492               gg(3)=zj*fac
13493               do k=1,3
13494                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13495                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13496                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13497                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13498               enddo
13499             endif
13500           enddo      ! j
13501         enddo        ! iint
13502       enddo          ! i
13503       do i=1,nct
13504         do j=1,3
13505           gvdwc(j,i)=expon*gvdwc(j,i)
13506           gvdwx(j,i)=expon*gvdwx(j,i)
13507         enddo
13508       enddo
13509       return
13510       end subroutine eljk_long
13511 !-----------------------------------------------------------------------------
13512       subroutine eljk_short(evdw)
13513 !
13514 ! This subroutine calculates the interaction energy of nonbonded side chains
13515 ! assuming the LJK potential of interaction.
13516 !
13517 !      implicit real*8 (a-h,o-z)
13518 !      include 'DIMENSIONS'
13519 !      include 'COMMON.GEO'
13520 !      include 'COMMON.VAR'
13521 !      include 'COMMON.LOCAL'
13522 !      include 'COMMON.CHAIN'
13523 !      include 'COMMON.DERIV'
13524 !      include 'COMMON.INTERACT'
13525 !      include 'COMMON.IOUNITS'
13526 !      include 'COMMON.NAMES'
13527       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13528       logical :: scheck
13529 !el local variables
13530       integer :: i,iint,j,k,itypi,itypi1,itypj
13531       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13532                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13533 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13534       evdw=0.0D0
13535       do i=iatsc_s,iatsc_e
13536         itypi=itype(i,1)
13537         if (itypi.eq.ntyp1) cycle
13538         itypi1=itype(i+1,1)
13539         xi=c(1,nres+i)
13540         yi=c(2,nres+i)
13541         zi=c(3,nres+i)
13542 !
13543 ! Calculate SC interaction energy.
13544 !
13545         do iint=1,nint_gr(i)
13546           do j=istart(i,iint),iend(i,iint)
13547             itypj=itype(j,1)
13548             if (itypj.eq.ntyp1) cycle
13549             xj=c(1,nres+j)-xi
13550             yj=c(2,nres+j)-yi
13551             zj=c(3,nres+j)-zi
13552             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13553             fac_augm=rrij**expon
13554             e_augm=augm(itypi,itypj)*fac_augm
13555             r_inv_ij=dsqrt(rrij)
13556             rij=1.0D0/r_inv_ij
13557             sss=sscale(rij/sigma(itypi,itypj))
13558             if (sss.gt.0.0d0) then
13559               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13560               fac=r_shift_inv**expon
13561               e1=fac*fac*aa_aq(itypi,itypj)
13562               e2=fac*bb_aq(itypi,itypj)
13563               evdwij=e_augm+e1+e2
13564 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13565 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13566 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13567 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13568 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13569 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13570 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13571               evdw=evdw+sss*evdwij
13572 !
13573 ! Calculate the components of the gradient in DC and X
13574 !
13575               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13576               fac=fac*sss
13577               gg(1)=xj*fac
13578               gg(2)=yj*fac
13579               gg(3)=zj*fac
13580               do k=1,3
13581                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13582                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13583                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13584                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13585               enddo
13586             endif
13587           enddo      ! j
13588         enddo        ! iint
13589       enddo          ! i
13590       do i=1,nct
13591         do j=1,3
13592           gvdwc(j,i)=expon*gvdwc(j,i)
13593           gvdwx(j,i)=expon*gvdwx(j,i)
13594         enddo
13595       enddo
13596       return
13597       end subroutine eljk_short
13598 !-----------------------------------------------------------------------------
13599       subroutine ebp_long(evdw)
13600 !
13601 ! This subroutine calculates the interaction energy of nonbonded side chains
13602 ! assuming the Berne-Pechukas potential of interaction.
13603 !
13604       use calc_data
13605 !      implicit real*8 (a-h,o-z)
13606 !      include 'DIMENSIONS'
13607 !      include 'COMMON.GEO'
13608 !      include 'COMMON.VAR'
13609 !      include 'COMMON.LOCAL'
13610 !      include 'COMMON.CHAIN'
13611 !      include 'COMMON.DERIV'
13612 !      include 'COMMON.NAMES'
13613 !      include 'COMMON.INTERACT'
13614 !      include 'COMMON.IOUNITS'
13615 !      include 'COMMON.CALC'
13616       use comm_srutu
13617 !el      integer :: icall
13618 !el      common /srutu/ icall
13619 !     double precision rrsave(maxdim)
13620       logical :: lprn
13621 !el local variables
13622       integer :: iint,itypi,itypi1,itypj
13623       real(kind=8) :: rrij,xi,yi,zi,fac
13624       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13625       evdw=0.0D0
13626 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13627       evdw=0.0D0
13628 !     if (icall.eq.0) then
13629 !       lprn=.true.
13630 !     else
13631         lprn=.false.
13632 !     endif
13633 !el      ind=0
13634       do i=iatsc_s,iatsc_e
13635         itypi=itype(i,1)
13636         if (itypi.eq.ntyp1) cycle
13637         itypi1=itype(i+1,1)
13638         xi=c(1,nres+i)
13639         yi=c(2,nres+i)
13640         zi=c(3,nres+i)
13641         dxi=dc_norm(1,nres+i)
13642         dyi=dc_norm(2,nres+i)
13643         dzi=dc_norm(3,nres+i)
13644 !        dsci_inv=dsc_inv(itypi)
13645         dsci_inv=vbld_inv(i+nres)
13646 !
13647 ! Calculate SC interaction energy.
13648 !
13649         do iint=1,nint_gr(i)
13650           do j=istart(i,iint),iend(i,iint)
13651 !el            ind=ind+1
13652             itypj=itype(j,1)
13653             if (itypj.eq.ntyp1) cycle
13654 !            dscj_inv=dsc_inv(itypj)
13655             dscj_inv=vbld_inv(j+nres)
13656             chi1=chi(itypi,itypj)
13657             chi2=chi(itypj,itypi)
13658             chi12=chi1*chi2
13659             chip1=chip(itypi)
13660             chip2=chip(itypj)
13661             chip12=chip1*chip2
13662             alf1=alp(itypi)
13663             alf2=alp(itypj)
13664             alf12=0.5D0*(alf1+alf2)
13665             xj=c(1,nres+j)-xi
13666             yj=c(2,nres+j)-yi
13667             zj=c(3,nres+j)-zi
13668             dxj=dc_norm(1,nres+j)
13669             dyj=dc_norm(2,nres+j)
13670             dzj=dc_norm(3,nres+j)
13671             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13672             rij=dsqrt(rrij)
13673             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13674
13675             if (sss.lt.1.0d0) then
13676
13677 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13678               call sc_angular
13679 ! Calculate whole angle-dependent part of epsilon and contributions
13680 ! to its derivatives
13681               fac=(rrij*sigsq)**expon2
13682               e1=fac*fac*aa_aq(itypi,itypj)
13683               e2=fac*bb_aq(itypi,itypj)
13684               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13685               eps2der=evdwij*eps3rt
13686               eps3der=evdwij*eps2rt
13687               evdwij=evdwij*eps2rt*eps3rt
13688               evdw=evdw+evdwij*(1.0d0-sss)
13689               if (lprn) then
13690               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13691               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13692 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13693 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13694 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13695 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13696 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13697 !d     &          evdwij
13698               endif
13699 ! Calculate gradient components.
13700               e1=e1*eps1*eps2rt**2*eps3rt**2
13701               fac=-expon*(e1+evdwij)
13702               sigder=fac/sigsq
13703               fac=rrij*fac
13704 ! Calculate radial part of the gradient
13705               gg(1)=xj*fac
13706               gg(2)=yj*fac
13707               gg(3)=zj*fac
13708 ! Calculate the angular part of the gradient and sum add the contributions
13709 ! to the appropriate components of the Cartesian gradient.
13710               call sc_grad_scale(1.0d0-sss)
13711             endif
13712           enddo      ! j
13713         enddo        ! iint
13714       enddo          ! i
13715 !     stop
13716       return
13717       end subroutine ebp_long
13718 !-----------------------------------------------------------------------------
13719       subroutine ebp_short(evdw)
13720 !
13721 ! This subroutine calculates the interaction energy of nonbonded side chains
13722 ! assuming the Berne-Pechukas potential of interaction.
13723 !
13724       use calc_data
13725 !      implicit real*8 (a-h,o-z)
13726 !      include 'DIMENSIONS'
13727 !      include 'COMMON.GEO'
13728 !      include 'COMMON.VAR'
13729 !      include 'COMMON.LOCAL'
13730 !      include 'COMMON.CHAIN'
13731 !      include 'COMMON.DERIV'
13732 !      include 'COMMON.NAMES'
13733 !      include 'COMMON.INTERACT'
13734 !      include 'COMMON.IOUNITS'
13735 !      include 'COMMON.CALC'
13736       use comm_srutu
13737 !el      integer :: icall
13738 !el      common /srutu/ icall
13739 !     double precision rrsave(maxdim)
13740       logical :: lprn
13741 !el local variables
13742       integer :: iint,itypi,itypi1,itypj
13743       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13744       real(kind=8) :: sss,e1,e2,evdw
13745       evdw=0.0D0
13746 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13747       evdw=0.0D0
13748 !     if (icall.eq.0) then
13749 !       lprn=.true.
13750 !     else
13751         lprn=.false.
13752 !     endif
13753 !el      ind=0
13754       do i=iatsc_s,iatsc_e
13755         itypi=itype(i,1)
13756         if (itypi.eq.ntyp1) cycle
13757         itypi1=itype(i+1,1)
13758         xi=c(1,nres+i)
13759         yi=c(2,nres+i)
13760         zi=c(3,nres+i)
13761         dxi=dc_norm(1,nres+i)
13762         dyi=dc_norm(2,nres+i)
13763         dzi=dc_norm(3,nres+i)
13764 !        dsci_inv=dsc_inv(itypi)
13765         dsci_inv=vbld_inv(i+nres)
13766 !
13767 ! Calculate SC interaction energy.
13768 !
13769         do iint=1,nint_gr(i)
13770           do j=istart(i,iint),iend(i,iint)
13771 !el            ind=ind+1
13772             itypj=itype(j,1)
13773             if (itypj.eq.ntyp1) cycle
13774 !            dscj_inv=dsc_inv(itypj)
13775             dscj_inv=vbld_inv(j+nres)
13776             chi1=chi(itypi,itypj)
13777             chi2=chi(itypj,itypi)
13778             chi12=chi1*chi2
13779             chip1=chip(itypi)
13780             chip2=chip(itypj)
13781             chip12=chip1*chip2
13782             alf1=alp(itypi)
13783             alf2=alp(itypj)
13784             alf12=0.5D0*(alf1+alf2)
13785             xj=c(1,nres+j)-xi
13786             yj=c(2,nres+j)-yi
13787             zj=c(3,nres+j)-zi
13788             dxj=dc_norm(1,nres+j)
13789             dyj=dc_norm(2,nres+j)
13790             dzj=dc_norm(3,nres+j)
13791             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13792             rij=dsqrt(rrij)
13793             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13794
13795             if (sss.gt.0.0d0) then
13796
13797 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13798               call sc_angular
13799 ! Calculate whole angle-dependent part of epsilon and contributions
13800 ! to its derivatives
13801               fac=(rrij*sigsq)**expon2
13802               e1=fac*fac*aa_aq(itypi,itypj)
13803               e2=fac*bb_aq(itypi,itypj)
13804               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13805               eps2der=evdwij*eps3rt
13806               eps3der=evdwij*eps2rt
13807               evdwij=evdwij*eps2rt*eps3rt
13808               evdw=evdw+evdwij*sss
13809               if (lprn) then
13810               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13811               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13812 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13813 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13814 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13815 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13816 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13817 !d     &          evdwij
13818               endif
13819 ! Calculate gradient components.
13820               e1=e1*eps1*eps2rt**2*eps3rt**2
13821               fac=-expon*(e1+evdwij)
13822               sigder=fac/sigsq
13823               fac=rrij*fac
13824 ! Calculate radial part of the gradient
13825               gg(1)=xj*fac
13826               gg(2)=yj*fac
13827               gg(3)=zj*fac
13828 ! Calculate the angular part of the gradient and sum add the contributions
13829 ! to the appropriate components of the Cartesian gradient.
13830               call sc_grad_scale(sss)
13831             endif
13832           enddo      ! j
13833         enddo        ! iint
13834       enddo          ! i
13835 !     stop
13836       return
13837       end subroutine ebp_short
13838 !-----------------------------------------------------------------------------
13839       subroutine egb_long(evdw)
13840 !
13841 ! This subroutine calculates the interaction energy of nonbonded side chains
13842 ! assuming the Gay-Berne potential of interaction.
13843 !
13844       use calc_data
13845 !      implicit real*8 (a-h,o-z)
13846 !      include 'DIMENSIONS'
13847 !      include 'COMMON.GEO'
13848 !      include 'COMMON.VAR'
13849 !      include 'COMMON.LOCAL'
13850 !      include 'COMMON.CHAIN'
13851 !      include 'COMMON.DERIV'
13852 !      include 'COMMON.NAMES'
13853 !      include 'COMMON.INTERACT'
13854 !      include 'COMMON.IOUNITS'
13855 !      include 'COMMON.CALC'
13856 !      include 'COMMON.CONTROL'
13857       logical :: lprn
13858 !el local variables
13859       integer :: iint,itypi,itypi1,itypj,subchap
13860       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13861       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13862       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13863                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13864                     ssgradlipi,ssgradlipj
13865
13866
13867       evdw=0.0D0
13868 !cccc      energy_dec=.false.
13869 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13870       evdw=0.0D0
13871       lprn=.false.
13872 !     if (icall.eq.0) lprn=.false.
13873 !el      ind=0
13874       do i=iatsc_s,iatsc_e
13875         itypi=itype(i,1)
13876         if (itypi.eq.ntyp1) cycle
13877         itypi1=itype(i+1,1)
13878         xi=c(1,nres+i)
13879         yi=c(2,nres+i)
13880         zi=c(3,nres+i)
13881           xi=mod(xi,boxxsize)
13882           if (xi.lt.0) xi=xi+boxxsize
13883           yi=mod(yi,boxysize)
13884           if (yi.lt.0) yi=yi+boxysize
13885           zi=mod(zi,boxzsize)
13886           if (zi.lt.0) zi=zi+boxzsize
13887        if ((zi.gt.bordlipbot)    &
13888         .and.(zi.lt.bordliptop)) then
13889 !C the energy transfer exist
13890         if (zi.lt.buflipbot) then
13891 !C what fraction I am in
13892          fracinbuf=1.0d0-    &
13893              ((zi-bordlipbot)/lipbufthick)
13894 !C lipbufthick is thickenes of lipid buffore
13895          sslipi=sscalelip(fracinbuf)
13896          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13897         elseif (zi.gt.bufliptop) then
13898          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13899          sslipi=sscalelip(fracinbuf)
13900          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13901         else
13902          sslipi=1.0d0
13903          ssgradlipi=0.0
13904         endif
13905        else
13906          sslipi=0.0d0
13907          ssgradlipi=0.0
13908        endif
13909
13910         dxi=dc_norm(1,nres+i)
13911         dyi=dc_norm(2,nres+i)
13912         dzi=dc_norm(3,nres+i)
13913 !        dsci_inv=dsc_inv(itypi)
13914         dsci_inv=vbld_inv(i+nres)
13915 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13916 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13917 !
13918 ! Calculate SC interaction energy.
13919 !
13920         do iint=1,nint_gr(i)
13921           do j=istart(i,iint),iend(i,iint)
13922             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13923 !              call dyn_ssbond_ene(i,j,evdwij)
13924 !              evdw=evdw+evdwij
13925 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13926 !                              'evdw',i,j,evdwij,' ss'
13927 !              if (energy_dec) write (iout,*) &
13928 !                              'evdw',i,j,evdwij,' ss'
13929 !             do k=j+1,iend(i,iint)
13930 !C search over all next residues
13931 !              if (dyn_ss_mask(k)) then
13932 !C check if they are cysteins
13933 !C              write(iout,*) 'k=',k
13934
13935 !c              write(iout,*) "PRZED TRI", evdwij
13936 !               evdwij_przed_tri=evdwij
13937 !              call triple_ssbond_ene(i,j,k,evdwij)
13938 !c               if(evdwij_przed_tri.ne.evdwij) then
13939 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13940 !c               endif
13941
13942 !c              write(iout,*) "PO TRI", evdwij
13943 !C call the energy function that removes the artifical triple disulfide
13944 !C bond the soubroutine is located in ssMD.F
13945 !              evdw=evdw+evdwij
13946               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13947                             'evdw',i,j,evdwij,'tss'
13948 !              endif!dyn_ss_mask(k)
13949 !             enddo! k
13950
13951             ELSE
13952 !el            ind=ind+1
13953             itypj=itype(j,1)
13954             if (itypj.eq.ntyp1) cycle
13955 !            dscj_inv=dsc_inv(itypj)
13956             dscj_inv=vbld_inv(j+nres)
13957 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13958 !     &       1.0d0/vbld(j+nres)
13959 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13960             sig0ij=sigma(itypi,itypj)
13961             chi1=chi(itypi,itypj)
13962             chi2=chi(itypj,itypi)
13963             chi12=chi1*chi2
13964             chip1=chip(itypi)
13965             chip2=chip(itypj)
13966             chip12=chip1*chip2
13967             alf1=alp(itypi)
13968             alf2=alp(itypj)
13969             alf12=0.5D0*(alf1+alf2)
13970             xj=c(1,nres+j)
13971             yj=c(2,nres+j)
13972             zj=c(3,nres+j)
13973 ! Searching for nearest neighbour
13974           xj=mod(xj,boxxsize)
13975           if (xj.lt.0) xj=xj+boxxsize
13976           yj=mod(yj,boxysize)
13977           if (yj.lt.0) yj=yj+boxysize
13978           zj=mod(zj,boxzsize)
13979           if (zj.lt.0) zj=zj+boxzsize
13980        if ((zj.gt.bordlipbot)   &
13981       .and.(zj.lt.bordliptop)) then
13982 !C the energy transfer exist
13983         if (zj.lt.buflipbot) then
13984 !C what fraction I am in
13985          fracinbuf=1.0d0-  &
13986              ((zj-bordlipbot)/lipbufthick)
13987 !C lipbufthick is thickenes of lipid buffore
13988          sslipj=sscalelip(fracinbuf)
13989          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13990         elseif (zj.gt.bufliptop) then
13991          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13992          sslipj=sscalelip(fracinbuf)
13993          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13994         else
13995          sslipj=1.0d0
13996          ssgradlipj=0.0
13997         endif
13998        else
13999          sslipj=0.0d0
14000          ssgradlipj=0.0
14001        endif
14002       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14003        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14004       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14005        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14006
14007           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14008           xj_safe=xj
14009           yj_safe=yj
14010           zj_safe=zj
14011           subchap=0
14012           do xshift=-1,1
14013           do yshift=-1,1
14014           do zshift=-1,1
14015           xj=xj_safe+xshift*boxxsize
14016           yj=yj_safe+yshift*boxysize
14017           zj=zj_safe+zshift*boxzsize
14018           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14019           if(dist_temp.lt.dist_init) then
14020             dist_init=dist_temp
14021             xj_temp=xj
14022             yj_temp=yj
14023             zj_temp=zj
14024             subchap=1
14025           endif
14026           enddo
14027           enddo
14028           enddo
14029           if (subchap.eq.1) then
14030           xj=xj_temp-xi
14031           yj=yj_temp-yi
14032           zj=zj_temp-zi
14033           else
14034           xj=xj_safe-xi
14035           yj=yj_safe-yi
14036           zj=zj_safe-zi
14037           endif
14038
14039             dxj=dc_norm(1,nres+j)
14040             dyj=dc_norm(2,nres+j)
14041             dzj=dc_norm(3,nres+j)
14042             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14043             rij=dsqrt(rrij)
14044             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14045             sss_ele_cut=sscale_ele(1.0d0/(rij))
14046             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14047             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14048             if (sss_ele_cut.le.0.0) cycle
14049             if (sss.lt.1.0d0) then
14050
14051 ! Calculate angle-dependent terms of energy and contributions to their
14052 ! derivatives.
14053               call sc_angular
14054               sigsq=1.0D0/sigsq
14055               sig=sig0ij*dsqrt(sigsq)
14056               rij_shift=1.0D0/rij-sig+sig0ij
14057 ! for diagnostics; uncomment
14058 !              rij_shift=1.2*sig0ij
14059 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14060               if (rij_shift.le.0.0D0) then
14061                 evdw=1.0D20
14062 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14063 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14064 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14065                 return
14066               endif
14067               sigder=-sig*sigsq
14068 !---------------------------------------------------------------
14069               rij_shift=1.0D0/rij_shift
14070               fac=rij_shift**expon
14071               e1=fac*fac*aa
14072               e2=fac*bb
14073               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14074               eps2der=evdwij*eps3rt
14075               eps3der=evdwij*eps2rt
14076 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14077 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14078               evdwij=evdwij*eps2rt*eps3rt
14079               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14080               if (lprn) then
14081               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14082               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14083               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14084                 restyp(itypi,1),i,restyp(itypj,1),j,&
14085                 epsi,sigm,chi1,chi2,chip1,chip2,&
14086                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14087                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14088                 evdwij
14089               endif
14090
14091               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14092                               'evdw',i,j,evdwij
14093 !              if (energy_dec) write (iout,*) &
14094 !                              'evdw',i,j,evdwij,"egb_long"
14095
14096 ! Calculate gradient components.
14097               e1=e1*eps1*eps2rt**2*eps3rt**2
14098               fac=-expon*(e1+evdwij)*rij_shift
14099               sigder=fac*sigder
14100               fac=rij*fac
14101               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14102               *rij-sss_grad/(1.0-sss)*rij  &
14103             /sigmaii(itypi,itypj))
14104 !              fac=0.0d0
14105 ! Calculate the radial part of the gradient
14106               gg(1)=xj*fac
14107               gg(2)=yj*fac
14108               gg(3)=zj*fac
14109 ! Calculate angular part of the gradient.
14110               call sc_grad_scale(1.0d0-sss)
14111             ENDIF    !mask_dyn_ss
14112             endif
14113           enddo      ! j
14114         enddo        ! iint
14115       enddo          ! i
14116 !      write (iout,*) "Number of loop steps in EGB:",ind
14117 !ccc      energy_dec=.false.
14118       return
14119       end subroutine egb_long
14120 !-----------------------------------------------------------------------------
14121       subroutine egb_short(evdw)
14122 !
14123 ! This subroutine calculates the interaction energy of nonbonded side chains
14124 ! assuming the Gay-Berne potential of interaction.
14125 !
14126       use calc_data
14127 !      implicit real*8 (a-h,o-z)
14128 !      include 'DIMENSIONS'
14129 !      include 'COMMON.GEO'
14130 !      include 'COMMON.VAR'
14131 !      include 'COMMON.LOCAL'
14132 !      include 'COMMON.CHAIN'
14133 !      include 'COMMON.DERIV'
14134 !      include 'COMMON.NAMES'
14135 !      include 'COMMON.INTERACT'
14136 !      include 'COMMON.IOUNITS'
14137 !      include 'COMMON.CALC'
14138 !      include 'COMMON.CONTROL'
14139       logical :: lprn
14140 !el local variables
14141       integer :: iint,itypi,itypi1,itypj,subchap
14142       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14143       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14144       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14145                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14146                     ssgradlipi,ssgradlipj
14147       evdw=0.0D0
14148 !cccc      energy_dec=.false.
14149 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14150       evdw=0.0D0
14151       lprn=.false.
14152 !     if (icall.eq.0) lprn=.false.
14153 !el      ind=0
14154       do i=iatsc_s,iatsc_e
14155         itypi=itype(i,1)
14156         if (itypi.eq.ntyp1) cycle
14157         itypi1=itype(i+1,1)
14158         xi=c(1,nres+i)
14159         yi=c(2,nres+i)
14160         zi=c(3,nres+i)
14161           xi=mod(xi,boxxsize)
14162           if (xi.lt.0) xi=xi+boxxsize
14163           yi=mod(yi,boxysize)
14164           if (yi.lt.0) yi=yi+boxysize
14165           zi=mod(zi,boxzsize)
14166           if (zi.lt.0) zi=zi+boxzsize
14167        if ((zi.gt.bordlipbot)    &
14168         .and.(zi.lt.bordliptop)) then
14169 !C the energy transfer exist
14170         if (zi.lt.buflipbot) then
14171 !C what fraction I am in
14172          fracinbuf=1.0d0-    &
14173              ((zi-bordlipbot)/lipbufthick)
14174 !C lipbufthick is thickenes of lipid buffore
14175          sslipi=sscalelip(fracinbuf)
14176          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14177         elseif (zi.gt.bufliptop) then
14178          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14179          sslipi=sscalelip(fracinbuf)
14180          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14181         else
14182          sslipi=1.0d0
14183          ssgradlipi=0.0
14184         endif
14185        else
14186          sslipi=0.0d0
14187          ssgradlipi=0.0
14188        endif
14189
14190         dxi=dc_norm(1,nres+i)
14191         dyi=dc_norm(2,nres+i)
14192         dzi=dc_norm(3,nres+i)
14193 !        dsci_inv=dsc_inv(itypi)
14194         dsci_inv=vbld_inv(i+nres)
14195
14196         dxi=dc_norm(1,nres+i)
14197         dyi=dc_norm(2,nres+i)
14198         dzi=dc_norm(3,nres+i)
14199 !        dsci_inv=dsc_inv(itypi)
14200         dsci_inv=vbld_inv(i+nres)
14201 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14202 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14203 !
14204 ! Calculate SC interaction energy.
14205 !
14206         do iint=1,nint_gr(i)
14207           do j=istart(i,iint),iend(i,iint)
14208             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14209               call dyn_ssbond_ene(i,j,evdwij)
14210               evdw=evdw+evdwij
14211               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14212                               'evdw',i,j,evdwij,' ss'
14213              do k=j+1,iend(i,iint)
14214 !C search over all next residues
14215               if (dyn_ss_mask(k)) then
14216 !C check if they are cysteins
14217 !C              write(iout,*) 'k=',k
14218
14219 !c              write(iout,*) "PRZED TRI", evdwij
14220 !               evdwij_przed_tri=evdwij
14221               call triple_ssbond_ene(i,j,k,evdwij)
14222 !c               if(evdwij_przed_tri.ne.evdwij) then
14223 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14224 !c               endif
14225
14226 !c              write(iout,*) "PO TRI", evdwij
14227 !C call the energy function that removes the artifical triple disulfide
14228 !C bond the soubroutine is located in ssMD.F
14229               evdw=evdw+evdwij
14230               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14231                             'evdw',i,j,evdwij,'tss'
14232               endif!dyn_ss_mask(k)
14233              enddo! k
14234
14235 !              if (energy_dec) write (iout,*) &
14236 !                              'evdw',i,j,evdwij,' ss'
14237             ELSE
14238 !el            ind=ind+1
14239             itypj=itype(j,1)
14240             if (itypj.eq.ntyp1) cycle
14241 !            dscj_inv=dsc_inv(itypj)
14242             dscj_inv=vbld_inv(j+nres)
14243 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14244 !     &       1.0d0/vbld(j+nres)
14245 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14246             sig0ij=sigma(itypi,itypj)
14247             chi1=chi(itypi,itypj)
14248             chi2=chi(itypj,itypi)
14249             chi12=chi1*chi2
14250             chip1=chip(itypi)
14251             chip2=chip(itypj)
14252             chip12=chip1*chip2
14253             alf1=alp(itypi)
14254             alf2=alp(itypj)
14255             alf12=0.5D0*(alf1+alf2)
14256 !            xj=c(1,nres+j)-xi
14257 !            yj=c(2,nres+j)-yi
14258 !            zj=c(3,nres+j)-zi
14259             xj=c(1,nres+j)
14260             yj=c(2,nres+j)
14261             zj=c(3,nres+j)
14262 ! Searching for nearest neighbour
14263           xj=mod(xj,boxxsize)
14264           if (xj.lt.0) xj=xj+boxxsize
14265           yj=mod(yj,boxysize)
14266           if (yj.lt.0) yj=yj+boxysize
14267           zj=mod(zj,boxzsize)
14268           if (zj.lt.0) zj=zj+boxzsize
14269        if ((zj.gt.bordlipbot)   &
14270       .and.(zj.lt.bordliptop)) then
14271 !C the energy transfer exist
14272         if (zj.lt.buflipbot) then
14273 !C what fraction I am in
14274          fracinbuf=1.0d0-  &
14275              ((zj-bordlipbot)/lipbufthick)
14276 !C lipbufthick is thickenes of lipid buffore
14277          sslipj=sscalelip(fracinbuf)
14278          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14279         elseif (zj.gt.bufliptop) then
14280          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14281          sslipj=sscalelip(fracinbuf)
14282          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14283         else
14284          sslipj=1.0d0
14285          ssgradlipj=0.0
14286         endif
14287        else
14288          sslipj=0.0d0
14289          ssgradlipj=0.0
14290        endif
14291       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14292        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14293       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14294        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14295
14296           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14297           xj_safe=xj
14298           yj_safe=yj
14299           zj_safe=zj
14300           subchap=0
14301
14302           do xshift=-1,1
14303           do yshift=-1,1
14304           do zshift=-1,1
14305           xj=xj_safe+xshift*boxxsize
14306           yj=yj_safe+yshift*boxysize
14307           zj=zj_safe+zshift*boxzsize
14308           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14309           if(dist_temp.lt.dist_init) then
14310             dist_init=dist_temp
14311             xj_temp=xj
14312             yj_temp=yj
14313             zj_temp=zj
14314             subchap=1
14315           endif
14316           enddo
14317           enddo
14318           enddo
14319           if (subchap.eq.1) then
14320           xj=xj_temp-xi
14321           yj=yj_temp-yi
14322           zj=zj_temp-zi
14323           else
14324           xj=xj_safe-xi
14325           yj=yj_safe-yi
14326           zj=zj_safe-zi
14327           endif
14328
14329             dxj=dc_norm(1,nres+j)
14330             dyj=dc_norm(2,nres+j)
14331             dzj=dc_norm(3,nres+j)
14332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14333             rij=dsqrt(rrij)
14334             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14335             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14336             sss_ele_cut=sscale_ele(1.0d0/(rij))
14337             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14338             if (sss_ele_cut.le.0.0) cycle
14339
14340             if (sss.gt.0.0d0) then
14341
14342 ! Calculate angle-dependent terms of energy and contributions to their
14343 ! derivatives.
14344               call sc_angular
14345               sigsq=1.0D0/sigsq
14346               sig=sig0ij*dsqrt(sigsq)
14347               rij_shift=1.0D0/rij-sig+sig0ij
14348 ! for diagnostics; uncomment
14349 !              rij_shift=1.2*sig0ij
14350 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14351               if (rij_shift.le.0.0D0) then
14352                 evdw=1.0D20
14353 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14354 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14355 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14356                 return
14357               endif
14358               sigder=-sig*sigsq
14359 !---------------------------------------------------------------
14360               rij_shift=1.0D0/rij_shift
14361               fac=rij_shift**expon
14362               e1=fac*fac*aa
14363               e2=fac*bb
14364               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14365               eps2der=evdwij*eps3rt
14366               eps3der=evdwij*eps2rt
14367 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14368 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14369               evdwij=evdwij*eps2rt*eps3rt
14370               evdw=evdw+evdwij*sss*sss_ele_cut
14371               if (lprn) then
14372               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14373               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14374               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14375                 restyp(itypi,1),i,restyp(itypj,1),j,&
14376                 epsi,sigm,chi1,chi2,chip1,chip2,&
14377                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14378                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14379                 evdwij
14380               endif
14381
14382               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14383                               'evdw',i,j,evdwij
14384 !              if (energy_dec) write (iout,*) &
14385 !                              'evdw',i,j,evdwij,"egb_short"
14386
14387 ! Calculate gradient components.
14388               e1=e1*eps1*eps2rt**2*eps3rt**2
14389               fac=-expon*(e1+evdwij)*rij_shift
14390               sigder=fac*sigder
14391               fac=rij*fac
14392               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14393             *rij+sss_grad/sss*rij  &
14394             /sigmaii(itypi,itypj))
14395
14396 !              fac=0.0d0
14397 ! Calculate the radial part of the gradient
14398               gg(1)=xj*fac
14399               gg(2)=yj*fac
14400               gg(3)=zj*fac
14401 ! Calculate angular part of the gradient.
14402               call sc_grad_scale(sss)
14403             endif
14404           ENDIF !mask_dyn_ss
14405           enddo      ! j
14406         enddo        ! iint
14407       enddo          ! i
14408 !      write (iout,*) "Number of loop steps in EGB:",ind
14409 !ccc      energy_dec=.false.
14410       return
14411       end subroutine egb_short
14412 !-----------------------------------------------------------------------------
14413       subroutine egbv_long(evdw)
14414 !
14415 ! This subroutine calculates the interaction energy of nonbonded side chains
14416 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14417 !
14418       use calc_data
14419 !      implicit real*8 (a-h,o-z)
14420 !      include 'DIMENSIONS'
14421 !      include 'COMMON.GEO'
14422 !      include 'COMMON.VAR'
14423 !      include 'COMMON.LOCAL'
14424 !      include 'COMMON.CHAIN'
14425 !      include 'COMMON.DERIV'
14426 !      include 'COMMON.NAMES'
14427 !      include 'COMMON.INTERACT'
14428 !      include 'COMMON.IOUNITS'
14429 !      include 'COMMON.CALC'
14430       use comm_srutu
14431 !el      integer :: icall
14432 !el      common /srutu/ icall
14433       logical :: lprn
14434 !el local variables
14435       integer :: iint,itypi,itypi1,itypj
14436       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14437       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14438       evdw=0.0D0
14439 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14440       evdw=0.0D0
14441       lprn=.false.
14442 !     if (icall.eq.0) lprn=.true.
14443 !el      ind=0
14444       do i=iatsc_s,iatsc_e
14445         itypi=itype(i,1)
14446         if (itypi.eq.ntyp1) cycle
14447         itypi1=itype(i+1,1)
14448         xi=c(1,nres+i)
14449         yi=c(2,nres+i)
14450         zi=c(3,nres+i)
14451         dxi=dc_norm(1,nres+i)
14452         dyi=dc_norm(2,nres+i)
14453         dzi=dc_norm(3,nres+i)
14454 !        dsci_inv=dsc_inv(itypi)
14455         dsci_inv=vbld_inv(i+nres)
14456 !
14457 ! Calculate SC interaction energy.
14458 !
14459         do iint=1,nint_gr(i)
14460           do j=istart(i,iint),iend(i,iint)
14461 !el            ind=ind+1
14462             itypj=itype(j,1)
14463             if (itypj.eq.ntyp1) cycle
14464 !            dscj_inv=dsc_inv(itypj)
14465             dscj_inv=vbld_inv(j+nres)
14466             sig0ij=sigma(itypi,itypj)
14467             r0ij=r0(itypi,itypj)
14468             chi1=chi(itypi,itypj)
14469             chi2=chi(itypj,itypi)
14470             chi12=chi1*chi2
14471             chip1=chip(itypi)
14472             chip2=chip(itypj)
14473             chip12=chip1*chip2
14474             alf1=alp(itypi)
14475             alf2=alp(itypj)
14476             alf12=0.5D0*(alf1+alf2)
14477             xj=c(1,nres+j)-xi
14478             yj=c(2,nres+j)-yi
14479             zj=c(3,nres+j)-zi
14480             dxj=dc_norm(1,nres+j)
14481             dyj=dc_norm(2,nres+j)
14482             dzj=dc_norm(3,nres+j)
14483             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14484             rij=dsqrt(rrij)
14485
14486             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14487
14488             if (sss.lt.1.0d0) then
14489
14490 ! Calculate angle-dependent terms of energy and contributions to their
14491 ! derivatives.
14492               call sc_angular
14493               sigsq=1.0D0/sigsq
14494               sig=sig0ij*dsqrt(sigsq)
14495               rij_shift=1.0D0/rij-sig+r0ij
14496 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14497               if (rij_shift.le.0.0D0) then
14498                 evdw=1.0D20
14499                 return
14500               endif
14501               sigder=-sig*sigsq
14502 !---------------------------------------------------------------
14503               rij_shift=1.0D0/rij_shift
14504               fac=rij_shift**expon
14505               e1=fac*fac*aa_aq(itypi,itypj)
14506               e2=fac*bb_aq(itypi,itypj)
14507               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14508               eps2der=evdwij*eps3rt
14509               eps3der=evdwij*eps2rt
14510               fac_augm=rrij**expon
14511               e_augm=augm(itypi,itypj)*fac_augm
14512               evdwij=evdwij*eps2rt*eps3rt
14513               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14514               if (lprn) then
14515               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14516               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14517               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14518                 restyp(itypi,1),i,restyp(itypj,1),j,&
14519                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14520                 chi1,chi2,chip1,chip2,&
14521                 eps1,eps2rt**2,eps3rt**2,&
14522                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14523                 evdwij+e_augm
14524               endif
14525 ! Calculate gradient components.
14526               e1=e1*eps1*eps2rt**2*eps3rt**2
14527               fac=-expon*(e1+evdwij)*rij_shift
14528               sigder=fac*sigder
14529               fac=rij*fac-2*expon*rrij*e_augm
14530 ! Calculate the radial part of the gradient
14531               gg(1)=xj*fac
14532               gg(2)=yj*fac
14533               gg(3)=zj*fac
14534 ! Calculate angular part of the gradient.
14535               call sc_grad_scale(1.0d0-sss)
14536             endif
14537           enddo      ! j
14538         enddo        ! iint
14539       enddo          ! i
14540       end subroutine egbv_long
14541 !-----------------------------------------------------------------------------
14542       subroutine egbv_short(evdw)
14543 !
14544 ! This subroutine calculates the interaction energy of nonbonded side chains
14545 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14546 !
14547       use calc_data
14548 !      implicit real*8 (a-h,o-z)
14549 !      include 'DIMENSIONS'
14550 !      include 'COMMON.GEO'
14551 !      include 'COMMON.VAR'
14552 !      include 'COMMON.LOCAL'
14553 !      include 'COMMON.CHAIN'
14554 !      include 'COMMON.DERIV'
14555 !      include 'COMMON.NAMES'
14556 !      include 'COMMON.INTERACT'
14557 !      include 'COMMON.IOUNITS'
14558 !      include 'COMMON.CALC'
14559       use comm_srutu
14560 !el      integer :: icall
14561 !el      common /srutu/ icall
14562       logical :: lprn
14563 !el local variables
14564       integer :: iint,itypi,itypi1,itypj
14565       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14566       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14567       evdw=0.0D0
14568 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14569       evdw=0.0D0
14570       lprn=.false.
14571 !     if (icall.eq.0) lprn=.true.
14572 !el      ind=0
14573       do i=iatsc_s,iatsc_e
14574         itypi=itype(i,1)
14575         if (itypi.eq.ntyp1) cycle
14576         itypi1=itype(i+1,1)
14577         xi=c(1,nres+i)
14578         yi=c(2,nres+i)
14579         zi=c(3,nres+i)
14580         dxi=dc_norm(1,nres+i)
14581         dyi=dc_norm(2,nres+i)
14582         dzi=dc_norm(3,nres+i)
14583 !        dsci_inv=dsc_inv(itypi)
14584         dsci_inv=vbld_inv(i+nres)
14585 !
14586 ! Calculate SC interaction energy.
14587 !
14588         do iint=1,nint_gr(i)
14589           do j=istart(i,iint),iend(i,iint)
14590 !el            ind=ind+1
14591             itypj=itype(j,1)
14592             if (itypj.eq.ntyp1) cycle
14593 !            dscj_inv=dsc_inv(itypj)
14594             dscj_inv=vbld_inv(j+nres)
14595             sig0ij=sigma(itypi,itypj)
14596             r0ij=r0(itypi,itypj)
14597             chi1=chi(itypi,itypj)
14598             chi2=chi(itypj,itypi)
14599             chi12=chi1*chi2
14600             chip1=chip(itypi)
14601             chip2=chip(itypj)
14602             chip12=chip1*chip2
14603             alf1=alp(itypi)
14604             alf2=alp(itypj)
14605             alf12=0.5D0*(alf1+alf2)
14606             xj=c(1,nres+j)-xi
14607             yj=c(2,nres+j)-yi
14608             zj=c(3,nres+j)-zi
14609             dxj=dc_norm(1,nres+j)
14610             dyj=dc_norm(2,nres+j)
14611             dzj=dc_norm(3,nres+j)
14612             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14613             rij=dsqrt(rrij)
14614
14615             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14616
14617             if (sss.gt.0.0d0) then
14618
14619 ! Calculate angle-dependent terms of energy and contributions to their
14620 ! derivatives.
14621               call sc_angular
14622               sigsq=1.0D0/sigsq
14623               sig=sig0ij*dsqrt(sigsq)
14624               rij_shift=1.0D0/rij-sig+r0ij
14625 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14626               if (rij_shift.le.0.0D0) then
14627                 evdw=1.0D20
14628                 return
14629               endif
14630               sigder=-sig*sigsq
14631 !---------------------------------------------------------------
14632               rij_shift=1.0D0/rij_shift
14633               fac=rij_shift**expon
14634               e1=fac*fac*aa_aq(itypi,itypj)
14635               e2=fac*bb_aq(itypi,itypj)
14636               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14637               eps2der=evdwij*eps3rt
14638               eps3der=evdwij*eps2rt
14639               fac_augm=rrij**expon
14640               e_augm=augm(itypi,itypj)*fac_augm
14641               evdwij=evdwij*eps2rt*eps3rt
14642               evdw=evdw+(evdwij+e_augm)*sss
14643               if (lprn) then
14644               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14645               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14646               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14647                 restyp(itypi,1),i,restyp(itypj,1),j,&
14648                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14649                 chi1,chi2,chip1,chip2,&
14650                 eps1,eps2rt**2,eps3rt**2,&
14651                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14652                 evdwij+e_augm
14653               endif
14654 ! Calculate gradient components.
14655               e1=e1*eps1*eps2rt**2*eps3rt**2
14656               fac=-expon*(e1+evdwij)*rij_shift
14657               sigder=fac*sigder
14658               fac=rij*fac-2*expon*rrij*e_augm
14659 ! Calculate the radial part of the gradient
14660               gg(1)=xj*fac
14661               gg(2)=yj*fac
14662               gg(3)=zj*fac
14663 ! Calculate angular part of the gradient.
14664               call sc_grad_scale(sss)
14665             endif
14666           enddo      ! j
14667         enddo        ! iint
14668       enddo          ! i
14669       end subroutine egbv_short
14670 !-----------------------------------------------------------------------------
14671       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14672 !
14673 ! This subroutine calculates the average interaction energy and its gradient
14674 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14675 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14676 ! The potential depends both on the distance of peptide-group centers and on
14677 ! the orientation of the CA-CA virtual bonds.
14678 !
14679 !      implicit real*8 (a-h,o-z)
14680
14681       use comm_locel
14682 #ifdef MPI
14683       include 'mpif.h'
14684 #endif
14685 !      include 'DIMENSIONS'
14686 !      include 'COMMON.CONTROL'
14687 !      include 'COMMON.SETUP'
14688 !      include 'COMMON.IOUNITS'
14689 !      include 'COMMON.GEO'
14690 !      include 'COMMON.VAR'
14691 !      include 'COMMON.LOCAL'
14692 !      include 'COMMON.CHAIN'
14693 !      include 'COMMON.DERIV'
14694 !      include 'COMMON.INTERACT'
14695 !      include 'COMMON.CONTACTS'
14696 !      include 'COMMON.TORSION'
14697 !      include 'COMMON.VECTORS'
14698 !      include 'COMMON.FFIELD'
14699 !      include 'COMMON.TIME1'
14700       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14701       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14702       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14703 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14704       real(kind=8),dimension(4) :: muij
14705 !el      integer :: num_conti,j1,j2
14706 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14707 !el                   dz_normi,xmedi,ymedi,zmedi
14708 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14709 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14710 !el          num_conti,j1,j2
14711 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14712 #ifdef MOMENT
14713       real(kind=8) :: scal_el=1.0d0
14714 #else
14715       real(kind=8) :: scal_el=0.5d0
14716 #endif
14717 ! 12/13/98
14718 ! 13-go grudnia roku pamietnego...
14719       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14720                                              0.0d0,1.0d0,0.0d0,&
14721                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14722 !el local variables
14723       integer :: i,j,k
14724       real(kind=8) :: fac
14725       real(kind=8) :: dxj,dyj,dzj
14726       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14727
14728 !      allocate(num_cont_hb(nres)) !(maxres)
14729 !d      write(iout,*) 'In EELEC'
14730 !d      do i=1,nloctyp
14731 !d        write(iout,*) 'Type',i
14732 !d        write(iout,*) 'B1',B1(:,i)
14733 !d        write(iout,*) 'B2',B2(:,i)
14734 !d        write(iout,*) 'CC',CC(:,:,i)
14735 !d        write(iout,*) 'DD',DD(:,:,i)
14736 !d        write(iout,*) 'EE',EE(:,:,i)
14737 !d      enddo
14738 !d      call check_vecgrad
14739 !d      stop
14740       if (icheckgrad.eq.1) then
14741         do i=1,nres-1
14742           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14743           do k=1,3
14744             dc_norm(k,i)=dc(k,i)*fac
14745           enddo
14746 !          write (iout,*) 'i',i,' fac',fac
14747         enddo
14748       endif
14749       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14750           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14751           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14752 !        call vec_and_deriv
14753 #ifdef TIMING
14754         time01=MPI_Wtime()
14755 #endif
14756 !        print *, "before set matrices"
14757         call set_matrices
14758 !        print *,"after set martices"
14759 #ifdef TIMING
14760         time_mat=time_mat+MPI_Wtime()-time01
14761 #endif
14762       endif
14763 !d      do i=1,nres-1
14764 !d        write (iout,*) 'i=',i
14765 !d        do k=1,3
14766 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14767 !d        enddo
14768 !d        do k=1,3
14769 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14770 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14771 !d        enddo
14772 !d      enddo
14773       t_eelecij=0.0d0
14774       ees=0.0D0
14775       evdw1=0.0D0
14776       eel_loc=0.0d0
14777       eello_turn3=0.0d0
14778       eello_turn4=0.0d0
14779 !el      ind=0
14780       do i=1,nres
14781         num_cont_hb(i)=0
14782       enddo
14783 !d      print '(a)','Enter EELEC'
14784 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14785 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14786 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14787       do i=1,nres
14788         gel_loc_loc(i)=0.0d0
14789         gcorr_loc(i)=0.0d0
14790       enddo
14791 !
14792 !
14793 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14794 !
14795 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14796 !
14797       do i=iturn3_start,iturn3_end
14798         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14799         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14800         dxi=dc(1,i)
14801         dyi=dc(2,i)
14802         dzi=dc(3,i)
14803         dx_normi=dc_norm(1,i)
14804         dy_normi=dc_norm(2,i)
14805         dz_normi=dc_norm(3,i)
14806         xmedi=c(1,i)+0.5d0*dxi
14807         ymedi=c(2,i)+0.5d0*dyi
14808         zmedi=c(3,i)+0.5d0*dzi
14809           xmedi=dmod(xmedi,boxxsize)
14810           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14811           ymedi=dmod(ymedi,boxysize)
14812           if (ymedi.lt.0) ymedi=ymedi+boxysize
14813           zmedi=dmod(zmedi,boxzsize)
14814           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14815         num_conti=0
14816         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14817         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14818         num_cont_hb(i)=num_conti
14819       enddo
14820       do i=iturn4_start,iturn4_end
14821         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14822           .or. itype(i+3,1).eq.ntyp1 &
14823           .or. itype(i+4,1).eq.ntyp1) cycle
14824         dxi=dc(1,i)
14825         dyi=dc(2,i)
14826         dzi=dc(3,i)
14827         dx_normi=dc_norm(1,i)
14828         dy_normi=dc_norm(2,i)
14829         dz_normi=dc_norm(3,i)
14830         xmedi=c(1,i)+0.5d0*dxi
14831         ymedi=c(2,i)+0.5d0*dyi
14832         zmedi=c(3,i)+0.5d0*dzi
14833           xmedi=dmod(xmedi,boxxsize)
14834           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14835           ymedi=dmod(ymedi,boxysize)
14836           if (ymedi.lt.0) ymedi=ymedi+boxysize
14837           zmedi=dmod(zmedi,boxzsize)
14838           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14839         num_conti=num_cont_hb(i)
14840         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14841         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14842           call eturn4(i,eello_turn4)
14843         num_cont_hb(i)=num_conti
14844       enddo   ! i
14845 !
14846 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14847 !
14848       do i=iatel_s,iatel_e
14849         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14850         dxi=dc(1,i)
14851         dyi=dc(2,i)
14852         dzi=dc(3,i)
14853         dx_normi=dc_norm(1,i)
14854         dy_normi=dc_norm(2,i)
14855         dz_normi=dc_norm(3,i)
14856         xmedi=c(1,i)+0.5d0*dxi
14857         ymedi=c(2,i)+0.5d0*dyi
14858         zmedi=c(3,i)+0.5d0*dzi
14859           xmedi=dmod(xmedi,boxxsize)
14860           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14861           ymedi=dmod(ymedi,boxysize)
14862           if (ymedi.lt.0) ymedi=ymedi+boxysize
14863           zmedi=dmod(zmedi,boxzsize)
14864           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14865 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14866         num_conti=num_cont_hb(i)
14867         do j=ielstart(i),ielend(i)
14868           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14869           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14870         enddo ! j
14871         num_cont_hb(i)=num_conti
14872       enddo   ! i
14873 !      write (iout,*) "Number of loop steps in EELEC:",ind
14874 !d      do i=1,nres
14875 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14876 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14877 !d      enddo
14878 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14879 !cc      eel_loc=eel_loc+eello_turn3
14880 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14881       return
14882       end subroutine eelec_scale
14883 !-----------------------------------------------------------------------------
14884       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14885 !      implicit real*8 (a-h,o-z)
14886
14887       use comm_locel
14888 !      include 'DIMENSIONS'
14889 #ifdef MPI
14890       include "mpif.h"
14891 #endif
14892 !      include 'COMMON.CONTROL'
14893 !      include 'COMMON.IOUNITS'
14894 !      include 'COMMON.GEO'
14895 !      include 'COMMON.VAR'
14896 !      include 'COMMON.LOCAL'
14897 !      include 'COMMON.CHAIN'
14898 !      include 'COMMON.DERIV'
14899 !      include 'COMMON.INTERACT'
14900 !      include 'COMMON.CONTACTS'
14901 !      include 'COMMON.TORSION'
14902 !      include 'COMMON.VECTORS'
14903 !      include 'COMMON.FFIELD'
14904 !      include 'COMMON.TIME1'
14905       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14906       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14907       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14908 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14909       real(kind=8),dimension(4) :: muij
14910       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14911                     dist_temp, dist_init,sss_grad
14912       integer xshift,yshift,zshift
14913
14914 !el      integer :: num_conti,j1,j2
14915 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14916 !el                   dz_normi,xmedi,ymedi,zmedi
14917 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14918 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14919 !el          num_conti,j1,j2
14920 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14921 #ifdef MOMENT
14922       real(kind=8) :: scal_el=1.0d0
14923 #else
14924       real(kind=8) :: scal_el=0.5d0
14925 #endif
14926 ! 12/13/98
14927 ! 13-go grudnia roku pamietnego...
14928       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14929                                              0.0d0,1.0d0,0.0d0,&
14930                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14931 !el local variables
14932       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14933       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14934       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14935       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14936       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14937       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14938       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14939                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14940                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14941                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14942                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14943                   ecosam,ecosbm,ecosgm,ghalf,time00
14944 !      integer :: maxconts
14945 !      maxconts = nres/4
14946 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14947 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14948 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14949 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14950 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14951 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14952 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14953 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14954 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14955 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14956 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14957 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14958 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14959
14960 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14961 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14962
14963 #ifdef MPI
14964           time00=MPI_Wtime()
14965 #endif
14966 !d      write (iout,*) "eelecij",i,j
14967 !el          ind=ind+1
14968           iteli=itel(i)
14969           itelj=itel(j)
14970           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14971           aaa=app(iteli,itelj)
14972           bbb=bpp(iteli,itelj)
14973           ael6i=ael6(iteli,itelj)
14974           ael3i=ael3(iteli,itelj)
14975           dxj=dc(1,j)
14976           dyj=dc(2,j)
14977           dzj=dc(3,j)
14978           dx_normj=dc_norm(1,j)
14979           dy_normj=dc_norm(2,j)
14980           dz_normj=dc_norm(3,j)
14981 !          xj=c(1,j)+0.5D0*dxj-xmedi
14982 !          yj=c(2,j)+0.5D0*dyj-ymedi
14983 !          zj=c(3,j)+0.5D0*dzj-zmedi
14984           xj=c(1,j)+0.5D0*dxj
14985           yj=c(2,j)+0.5D0*dyj
14986           zj=c(3,j)+0.5D0*dzj
14987           xj=mod(xj,boxxsize)
14988           if (xj.lt.0) xj=xj+boxxsize
14989           yj=mod(yj,boxysize)
14990           if (yj.lt.0) yj=yj+boxysize
14991           zj=mod(zj,boxzsize)
14992           if (zj.lt.0) zj=zj+boxzsize
14993       isubchap=0
14994       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14995       xj_safe=xj
14996       yj_safe=yj
14997       zj_safe=zj
14998       do xshift=-1,1
14999       do yshift=-1,1
15000       do zshift=-1,1
15001           xj=xj_safe+xshift*boxxsize
15002           yj=yj_safe+yshift*boxysize
15003           zj=zj_safe+zshift*boxzsize
15004           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15005           if(dist_temp.lt.dist_init) then
15006             dist_init=dist_temp
15007             xj_temp=xj
15008             yj_temp=yj
15009             zj_temp=zj
15010             isubchap=1
15011           endif
15012        enddo
15013        enddo
15014        enddo
15015        if (isubchap.eq.1) then
15016 !C          print *,i,j
15017           xj=xj_temp-xmedi
15018           yj=yj_temp-ymedi
15019           zj=zj_temp-zmedi
15020        else
15021           xj=xj_safe-xmedi
15022           yj=yj_safe-ymedi
15023           zj=zj_safe-zmedi
15024        endif
15025
15026           rij=xj*xj+yj*yj+zj*zj
15027           rrmij=1.0D0/rij
15028           rij=dsqrt(rij)
15029           rmij=1.0D0/rij
15030 ! For extracting the short-range part of Evdwpp
15031           sss=sscale(rij/rpp(iteli,itelj))
15032             sss_ele_cut=sscale_ele(rij)
15033             sss_ele_grad=sscagrad_ele(rij)
15034             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15035 !             sss_ele_cut=1.0d0
15036 !             sss_ele_grad=0.0d0
15037             if (sss_ele_cut.le.0.0) go to 128
15038
15039           r3ij=rrmij*rmij
15040           r6ij=r3ij*r3ij
15041           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15042           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15043           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15044           fac=cosa-3.0D0*cosb*cosg
15045           ev1=aaa*r6ij*r6ij
15046 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15047           if (j.eq.i+2) ev1=scal_el*ev1
15048           ev2=bbb*r6ij
15049           fac3=ael6i*r6ij
15050           fac4=ael3i*r3ij
15051           evdwij=ev1+ev2
15052           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15053           el2=fac4*fac
15054           eesij=el1+el2
15055 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15056           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15057           ees=ees+eesij*sss_ele_cut
15058           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15059 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15060 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15061 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15062 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15063
15064           if (energy_dec) then
15065               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15066               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15067           endif
15068
15069 !
15070 ! Calculate contributions to the Cartesian gradient.
15071 !
15072 #ifdef SPLITELE
15073           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15074           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15075           fac1=fac
15076           erij(1)=xj*rmij
15077           erij(2)=yj*rmij
15078           erij(3)=zj*rmij
15079 !
15080 ! Radial derivatives. First process both termini of the fragment (i,j)
15081 !
15082           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15083           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15084           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15085 !          do k=1,3
15086 !            ghalf=0.5D0*ggg(k)
15087 !            gelc(k,i)=gelc(k,i)+ghalf
15088 !            gelc(k,j)=gelc(k,j)+ghalf
15089 !          enddo
15090 ! 9/28/08 AL Gradient compotents will be summed only at the end
15091           do k=1,3
15092             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15093             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15094           enddo
15095 !
15096 ! Loop over residues i+1 thru j-1.
15097 !
15098 !grad          do k=i+1,j-1
15099 !grad            do l=1,3
15100 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15101 !grad            enddo
15102 !grad          enddo
15103           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15104           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15105           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15106           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15107           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15108           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15109 !          do k=1,3
15110 !            ghalf=0.5D0*ggg(k)
15111 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15112 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15113 !          enddo
15114 ! 9/28/08 AL Gradient compotents will be summed only at the end
15115           do k=1,3
15116             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15117             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15118           enddo
15119 !
15120 ! Loop over residues i+1 thru j-1.
15121 !
15122 !grad          do k=i+1,j-1
15123 !grad            do l=1,3
15124 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15125 !grad            enddo
15126 !grad          enddo
15127 #else
15128           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15129           facel=(el1+eesij)*sss_ele_cut
15130           fac1=fac
15131           fac=-3*rrmij*(facvdw+facvdw+facel)
15132           erij(1)=xj*rmij
15133           erij(2)=yj*rmij
15134           erij(3)=zj*rmij
15135 !
15136 ! Radial derivatives. First process both termini of the fragment (i,j)
15137 !
15138           ggg(1)=fac*xj
15139           ggg(2)=fac*yj
15140           ggg(3)=fac*zj
15141 !          do k=1,3
15142 !            ghalf=0.5D0*ggg(k)
15143 !            gelc(k,i)=gelc(k,i)+ghalf
15144 !            gelc(k,j)=gelc(k,j)+ghalf
15145 !          enddo
15146 ! 9/28/08 AL Gradient compotents will be summed only at the end
15147           do k=1,3
15148             gelc_long(k,j)=gelc(k,j)+ggg(k)
15149             gelc_long(k,i)=gelc(k,i)-ggg(k)
15150           enddo
15151 !
15152 ! Loop over residues i+1 thru j-1.
15153 !
15154 !grad          do k=i+1,j-1
15155 !grad            do l=1,3
15156 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15157 !grad            enddo
15158 !grad          enddo
15159 ! 9/28/08 AL Gradient compotents will be summed only at the end
15160           ggg(1)=facvdw*xj
15161           ggg(2)=facvdw*yj
15162           ggg(3)=facvdw*zj
15163           do k=1,3
15164             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15165             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15166           enddo
15167 #endif
15168 !
15169 ! Angular part
15170 !
15171           ecosa=2.0D0*fac3*fac1+fac4
15172           fac4=-3.0D0*fac4
15173           fac3=-6.0D0*fac3
15174           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15175           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15176           do k=1,3
15177             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15178             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15179           enddo
15180 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15181 !d   &          (dcosg(k),k=1,3)
15182           do k=1,3
15183             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15184           enddo
15185 !          do k=1,3
15186 !            ghalf=0.5D0*ggg(k)
15187 !            gelc(k,i)=gelc(k,i)+ghalf
15188 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15189 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15190 !            gelc(k,j)=gelc(k,j)+ghalf
15191 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15192 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15193 !          enddo
15194 !grad          do k=i+1,j-1
15195 !grad            do l=1,3
15196 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15197 !grad            enddo
15198 !grad          enddo
15199           do k=1,3
15200             gelc(k,i)=gelc(k,i) &
15201                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15202                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15203                      *sss_ele_cut
15204             gelc(k,j)=gelc(k,j) &
15205                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15206                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15207                      *sss_ele_cut
15208             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15209             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15210           enddo
15211           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15212               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15213               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15214 !
15215 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15216 !   energy of a peptide unit is assumed in the form of a second-order
15217 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15218 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15219 !   are computed for EVERY pair of non-contiguous peptide groups.
15220 !
15221           if (j.lt.nres-1) then
15222             j1=j+1
15223             j2=j-1
15224           else
15225             j1=j-1
15226             j2=j-2
15227           endif
15228           kkk=0
15229           do k=1,2
15230             do l=1,2
15231               kkk=kkk+1
15232               muij(kkk)=mu(k,i)*mu(l,j)
15233             enddo
15234           enddo
15235 !d         write (iout,*) 'EELEC: i',i,' j',j
15236 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15237 !d          write(iout,*) 'muij',muij
15238           ury=scalar(uy(1,i),erij)
15239           urz=scalar(uz(1,i),erij)
15240           vry=scalar(uy(1,j),erij)
15241           vrz=scalar(uz(1,j),erij)
15242           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15243           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15244           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15245           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15246           fac=dsqrt(-ael6i)*r3ij
15247           a22=a22*fac
15248           a23=a23*fac
15249           a32=a32*fac
15250           a33=a33*fac
15251 !d          write (iout,'(4i5,4f10.5)')
15252 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15253 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15254 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15255 !d     &      uy(:,j),uz(:,j)
15256 !d          write (iout,'(4f10.5)')
15257 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15258 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15259 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15260 !d           write (iout,'(9f10.5/)')
15261 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15262 ! Derivatives of the elements of A in virtual-bond vectors
15263           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15264           do k=1,3
15265             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15266             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15267             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15268             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15269             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15270             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15271             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15272             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15273             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15274             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15275             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15276             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15277           enddo
15278 ! Compute radial contributions to the gradient
15279           facr=-3.0d0*rrmij
15280           a22der=a22*facr
15281           a23der=a23*facr
15282           a32der=a32*facr
15283           a33der=a33*facr
15284           agg(1,1)=a22der*xj
15285           agg(2,1)=a22der*yj
15286           agg(3,1)=a22der*zj
15287           agg(1,2)=a23der*xj
15288           agg(2,2)=a23der*yj
15289           agg(3,2)=a23der*zj
15290           agg(1,3)=a32der*xj
15291           agg(2,3)=a32der*yj
15292           agg(3,3)=a32der*zj
15293           agg(1,4)=a33der*xj
15294           agg(2,4)=a33der*yj
15295           agg(3,4)=a33der*zj
15296 ! Add the contributions coming from er
15297           fac3=-3.0d0*fac
15298           do k=1,3
15299             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15300             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15301             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15302             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15303           enddo
15304           do k=1,3
15305 ! Derivatives in DC(i)
15306 !grad            ghalf1=0.5d0*agg(k,1)
15307 !grad            ghalf2=0.5d0*agg(k,2)
15308 !grad            ghalf3=0.5d0*agg(k,3)
15309 !grad            ghalf4=0.5d0*agg(k,4)
15310             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15311             -3.0d0*uryg(k,2)*vry)!+ghalf1
15312             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15313             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15314             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15315             -3.0d0*urzg(k,2)*vry)!+ghalf3
15316             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15317             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15318 ! Derivatives in DC(i+1)
15319             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15320             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15321             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15322             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15323             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15324             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15325             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15326             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15327 ! Derivatives in DC(j)
15328             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15329             -3.0d0*vryg(k,2)*ury)!+ghalf1
15330             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15331             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15332             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15333             -3.0d0*vryg(k,2)*urz)!+ghalf3
15334             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15335             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15336 ! Derivatives in DC(j+1) or DC(nres-1)
15337             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15338             -3.0d0*vryg(k,3)*ury)
15339             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15340             -3.0d0*vrzg(k,3)*ury)
15341             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15342             -3.0d0*vryg(k,3)*urz)
15343             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15344             -3.0d0*vrzg(k,3)*urz)
15345 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15346 !grad              do l=1,4
15347 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15348 !grad              enddo
15349 !grad            endif
15350           enddo
15351           acipa(1,1)=a22
15352           acipa(1,2)=a23
15353           acipa(2,1)=a32
15354           acipa(2,2)=a33
15355           a22=-a22
15356           a23=-a23
15357           do l=1,2
15358             do k=1,3
15359               agg(k,l)=-agg(k,l)
15360               aggi(k,l)=-aggi(k,l)
15361               aggi1(k,l)=-aggi1(k,l)
15362               aggj(k,l)=-aggj(k,l)
15363               aggj1(k,l)=-aggj1(k,l)
15364             enddo
15365           enddo
15366           if (j.lt.nres-1) then
15367             a22=-a22
15368             a32=-a32
15369             do l=1,3,2
15370               do k=1,3
15371                 agg(k,l)=-agg(k,l)
15372                 aggi(k,l)=-aggi(k,l)
15373                 aggi1(k,l)=-aggi1(k,l)
15374                 aggj(k,l)=-aggj(k,l)
15375                 aggj1(k,l)=-aggj1(k,l)
15376               enddo
15377             enddo
15378           else
15379             a22=-a22
15380             a23=-a23
15381             a32=-a32
15382             a33=-a33
15383             do l=1,4
15384               do k=1,3
15385                 agg(k,l)=-agg(k,l)
15386                 aggi(k,l)=-aggi(k,l)
15387                 aggi1(k,l)=-aggi1(k,l)
15388                 aggj(k,l)=-aggj(k,l)
15389                 aggj1(k,l)=-aggj1(k,l)
15390               enddo
15391             enddo
15392           endif
15393           ENDIF ! WCORR
15394           IF (wel_loc.gt.0.0d0) THEN
15395 ! Contribution to the local-electrostatic energy coming from the i-j pair
15396           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15397            +a33*muij(4)
15398 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15399 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15400           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15401                   'eelloc',i,j,eel_loc_ij
15402 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15403
15404           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15405 ! Partial derivatives in virtual-bond dihedral angles gamma
15406           if (i.gt.1) &
15407           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15408                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15409                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15410                  *sss_ele_cut
15411           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15412                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15413                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15414                  *sss_ele_cut
15415            xtemp(1)=xj
15416            xtemp(2)=yj
15417            xtemp(3)=zj
15418
15419 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15420           do l=1,3
15421             ggg(l)=(agg(l,1)*muij(1)+ &
15422                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15423             *sss_ele_cut &
15424              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15425
15426             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15427             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15428 !grad            ghalf=0.5d0*ggg(l)
15429 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15430 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15431           enddo
15432 !grad          do k=i+1,j2
15433 !grad            do l=1,3
15434 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15435 !grad            enddo
15436 !grad          enddo
15437 ! Remaining derivatives of eello
15438           do l=1,3
15439             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15440                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15441             *sss_ele_cut
15442
15443             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15444                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15445             *sss_ele_cut
15446
15447             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15448                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15449             *sss_ele_cut
15450
15451             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15452                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15453             *sss_ele_cut
15454
15455           enddo
15456           ENDIF
15457 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15458 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15459           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15460              .and. num_conti.le.maxconts) then
15461 !            write (iout,*) i,j," entered corr"
15462 !
15463 ! Calculate the contact function. The ith column of the array JCONT will
15464 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15465 ! greater than I). The arrays FACONT and GACONT will contain the values of
15466 ! the contact function and its derivative.
15467 !           r0ij=1.02D0*rpp(iteli,itelj)
15468 !           r0ij=1.11D0*rpp(iteli,itelj)
15469             r0ij=2.20D0*rpp(iteli,itelj)
15470 !           r0ij=1.55D0*rpp(iteli,itelj)
15471             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15472 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15473             if (fcont.gt.0.0D0) then
15474               num_conti=num_conti+1
15475               if (num_conti.gt.maxconts) then
15476 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15477                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15478                                ' will skip next contacts for this conf.',num_conti
15479               else
15480                 jcont_hb(num_conti,i)=j
15481 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15482 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15483                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15484                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15485 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15486 !  terms.
15487                 d_cont(num_conti,i)=rij
15488 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15489 !     --- Electrostatic-interaction matrix ---
15490                 a_chuj(1,1,num_conti,i)=a22
15491                 a_chuj(1,2,num_conti,i)=a23
15492                 a_chuj(2,1,num_conti,i)=a32
15493                 a_chuj(2,2,num_conti,i)=a33
15494 !     --- Gradient of rij
15495                 do kkk=1,3
15496                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15497                 enddo
15498                 kkll=0
15499                 do k=1,2
15500                   do l=1,2
15501                     kkll=kkll+1
15502                     do m=1,3
15503                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15504                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15505                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15506                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15507                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15508                     enddo
15509                   enddo
15510                 enddo
15511                 ENDIF
15512                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15513 ! Calculate contact energies
15514                 cosa4=4.0D0*cosa
15515                 wij=cosa-3.0D0*cosb*cosg
15516                 cosbg1=cosb+cosg
15517                 cosbg2=cosb-cosg
15518 !               fac3=dsqrt(-ael6i)/r0ij**3
15519                 fac3=dsqrt(-ael6i)*r3ij
15520 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15521                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15522                 if (ees0tmp.gt.0) then
15523                   ees0pij=dsqrt(ees0tmp)
15524                 else
15525                   ees0pij=0
15526                 endif
15527 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15528                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15529                 if (ees0tmp.gt.0) then
15530                   ees0mij=dsqrt(ees0tmp)
15531                 else
15532                   ees0mij=0
15533                 endif
15534 !               ees0mij=0.0D0
15535                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15536                      *sss_ele_cut
15537
15538                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15539                      *sss_ele_cut
15540
15541 ! Diagnostics. Comment out or remove after debugging!
15542 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15543 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15544 !               ees0m(num_conti,i)=0.0D0
15545 ! End diagnostics.
15546 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15547 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15548 ! Angular derivatives of the contact function
15549                 ees0pij1=fac3/ees0pij
15550                 ees0mij1=fac3/ees0mij
15551                 fac3p=-3.0D0*fac3*rrmij
15552                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15553                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15554 !               ees0mij1=0.0D0
15555                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15556                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15557                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15558                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15559                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15560                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15561                 ecosap=ecosa1+ecosa2
15562                 ecosbp=ecosb1+ecosb2
15563                 ecosgp=ecosg1+ecosg2
15564                 ecosam=ecosa1-ecosa2
15565                 ecosbm=ecosb1-ecosb2
15566                 ecosgm=ecosg1-ecosg2
15567 ! Diagnostics
15568 !               ecosap=ecosa1
15569 !               ecosbp=ecosb1
15570 !               ecosgp=ecosg1
15571 !               ecosam=0.0D0
15572 !               ecosbm=0.0D0
15573 !               ecosgm=0.0D0
15574 ! End diagnostics
15575                 facont_hb(num_conti,i)=fcont
15576                 fprimcont=fprimcont/rij
15577 !d              facont_hb(num_conti,i)=1.0D0
15578 ! Following line is for diagnostics.
15579 !d              fprimcont=0.0D0
15580                 do k=1,3
15581                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15582                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15583                 enddo
15584                 do k=1,3
15585                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15586                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15587                 enddo
15588 !                gggp(1)=gggp(1)+ees0pijp*xj
15589 !                gggp(2)=gggp(2)+ees0pijp*yj
15590 !                gggp(3)=gggp(3)+ees0pijp*zj
15591 !                gggm(1)=gggm(1)+ees0mijp*xj
15592 !                gggm(2)=gggm(2)+ees0mijp*yj
15593 !                gggm(3)=gggm(3)+ees0mijp*zj
15594                 gggp(1)=gggp(1)+ees0pijp*xj &
15595                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15596                 gggp(2)=gggp(2)+ees0pijp*yj &
15597                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15598                 gggp(3)=gggp(3)+ees0pijp*zj &
15599                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15600
15601                 gggm(1)=gggm(1)+ees0mijp*xj &
15602                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15603
15604                 gggm(2)=gggm(2)+ees0mijp*yj &
15605                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15606
15607                 gggm(3)=gggm(3)+ees0mijp*zj &
15608                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15609
15610 ! Derivatives due to the contact function
15611                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15612                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15613                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15614                 do k=1,3
15615 !
15616 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15617 !          following the change of gradient-summation algorithm.
15618 !
15619 !grad                  ghalfp=0.5D0*gggp(k)
15620 !grad                  ghalfm=0.5D0*gggm(k)
15621 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15622 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15623 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15624 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15625 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15626 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15627 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15628 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15629 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15630 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15631 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15632 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15633 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15634 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15635                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15636                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15637                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15638                      *sss_ele_cut
15639
15640                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15641                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15642                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15643                      *sss_ele_cut
15644
15645                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15646                      *sss_ele_cut
15647
15648                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15649                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15650                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15651                      *sss_ele_cut
15652
15653                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15654                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15655                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15656                      *sss_ele_cut
15657
15658                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15659                      *sss_ele_cut
15660
15661                 enddo
15662               ENDIF ! wcorr
15663               endif  ! num_conti.le.maxconts
15664             endif  ! fcont.gt.0
15665           endif    ! j.gt.i+1
15666           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15667             do k=1,4
15668               do l=1,3
15669                 ghalf=0.5d0*agg(l,k)
15670                 aggi(l,k)=aggi(l,k)+ghalf
15671                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15672                 aggj(l,k)=aggj(l,k)+ghalf
15673               enddo
15674             enddo
15675             if (j.eq.nres-1 .and. i.lt.j-2) then
15676               do k=1,4
15677                 do l=1,3
15678                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15679                 enddo
15680               enddo
15681             endif
15682           endif
15683  128      continue
15684 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15685       return
15686       end subroutine eelecij_scale
15687 !-----------------------------------------------------------------------------
15688       subroutine evdwpp_short(evdw1)
15689 !
15690 ! Compute Evdwpp
15691 !
15692 !      implicit real*8 (a-h,o-z)
15693 !      include 'DIMENSIONS'
15694 !      include 'COMMON.CONTROL'
15695 !      include 'COMMON.IOUNITS'
15696 !      include 'COMMON.GEO'
15697 !      include 'COMMON.VAR'
15698 !      include 'COMMON.LOCAL'
15699 !      include 'COMMON.CHAIN'
15700 !      include 'COMMON.DERIV'
15701 !      include 'COMMON.INTERACT'
15702 !      include 'COMMON.CONTACTS'
15703 !      include 'COMMON.TORSION'
15704 !      include 'COMMON.VECTORS'
15705 !      include 'COMMON.FFIELD'
15706       real(kind=8),dimension(3) :: ggg
15707 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15708 #ifdef MOMENT
15709       real(kind=8) :: scal_el=1.0d0
15710 #else
15711       real(kind=8) :: scal_el=0.5d0
15712 #endif
15713 !el local variables
15714       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15715       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15716       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15717                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15718                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15719       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15720                     dist_temp, dist_init,sss_grad
15721       integer xshift,yshift,zshift
15722
15723
15724       evdw1=0.0D0
15725 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15726 !     & " iatel_e_vdw",iatel_e_vdw
15727       call flush(iout)
15728       do i=iatel_s_vdw,iatel_e_vdw
15729         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15730         dxi=dc(1,i)
15731         dyi=dc(2,i)
15732         dzi=dc(3,i)
15733         dx_normi=dc_norm(1,i)
15734         dy_normi=dc_norm(2,i)
15735         dz_normi=dc_norm(3,i)
15736         xmedi=c(1,i)+0.5d0*dxi
15737         ymedi=c(2,i)+0.5d0*dyi
15738         zmedi=c(3,i)+0.5d0*dzi
15739           xmedi=dmod(xmedi,boxxsize)
15740           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15741           ymedi=dmod(ymedi,boxysize)
15742           if (ymedi.lt.0) ymedi=ymedi+boxysize
15743           zmedi=dmod(zmedi,boxzsize)
15744           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15745         num_conti=0
15746 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15747 !     &   ' ielend',ielend_vdw(i)
15748         call flush(iout)
15749         do j=ielstart_vdw(i),ielend_vdw(i)
15750           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15751 !el          ind=ind+1
15752           iteli=itel(i)
15753           itelj=itel(j)
15754           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15755           aaa=app(iteli,itelj)
15756           bbb=bpp(iteli,itelj)
15757           dxj=dc(1,j)
15758           dyj=dc(2,j)
15759           dzj=dc(3,j)
15760           dx_normj=dc_norm(1,j)
15761           dy_normj=dc_norm(2,j)
15762           dz_normj=dc_norm(3,j)
15763 !          xj=c(1,j)+0.5D0*dxj-xmedi
15764 !          yj=c(2,j)+0.5D0*dyj-ymedi
15765 !          zj=c(3,j)+0.5D0*dzj-zmedi
15766           xj=c(1,j)+0.5D0*dxj
15767           yj=c(2,j)+0.5D0*dyj
15768           zj=c(3,j)+0.5D0*dzj
15769           xj=mod(xj,boxxsize)
15770           if (xj.lt.0) xj=xj+boxxsize
15771           yj=mod(yj,boxysize)
15772           if (yj.lt.0) yj=yj+boxysize
15773           zj=mod(zj,boxzsize)
15774           if (zj.lt.0) zj=zj+boxzsize
15775       isubchap=0
15776       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15777       xj_safe=xj
15778       yj_safe=yj
15779       zj_safe=zj
15780       do xshift=-1,1
15781       do yshift=-1,1
15782       do zshift=-1,1
15783           xj=xj_safe+xshift*boxxsize
15784           yj=yj_safe+yshift*boxysize
15785           zj=zj_safe+zshift*boxzsize
15786           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15787           if(dist_temp.lt.dist_init) then
15788             dist_init=dist_temp
15789             xj_temp=xj
15790             yj_temp=yj
15791             zj_temp=zj
15792             isubchap=1
15793           endif
15794        enddo
15795        enddo
15796        enddo
15797        if (isubchap.eq.1) then
15798 !C          print *,i,j
15799           xj=xj_temp-xmedi
15800           yj=yj_temp-ymedi
15801           zj=zj_temp-zmedi
15802        else
15803           xj=xj_safe-xmedi
15804           yj=yj_safe-ymedi
15805           zj=zj_safe-zmedi
15806        endif
15807
15808           rij=xj*xj+yj*yj+zj*zj
15809           rrmij=1.0D0/rij
15810           rij=dsqrt(rij)
15811           sss=sscale(rij/rpp(iteli,itelj))
15812             sss_ele_cut=sscale_ele(rij)
15813             sss_ele_grad=sscagrad_ele(rij)
15814             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15815             if (sss_ele_cut.le.0.0) cycle
15816           if (sss.gt.0.0d0) then
15817             rmij=1.0D0/rij
15818             r3ij=rrmij*rmij
15819             r6ij=r3ij*r3ij
15820             ev1=aaa*r6ij*r6ij
15821 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15822             if (j.eq.i+2) ev1=scal_el*ev1
15823             ev2=bbb*r6ij
15824             evdwij=ev1+ev2
15825             if (energy_dec) then
15826               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15827             endif
15828             evdw1=evdw1+evdwij*sss*sss_ele_cut
15829 !
15830 ! Calculate contributions to the Cartesian gradient.
15831 !
15832             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15833 !            ggg(1)=facvdw*xj
15834 !            ggg(2)=facvdw*yj
15835 !            ggg(3)=facvdw*zj
15836           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15837           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15838           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15839           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15840           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15841           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15842
15843             do k=1,3
15844               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15845               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15846             enddo
15847           endif
15848         enddo ! j
15849       enddo   ! i
15850       return
15851       end subroutine evdwpp_short
15852 !-----------------------------------------------------------------------------
15853       subroutine escp_long(evdw2,evdw2_14)
15854 !
15855 ! This subroutine calculates the excluded-volume interaction energy between
15856 ! peptide-group centers and side chains and its gradient in virtual-bond and
15857 ! side-chain vectors.
15858 !
15859 !      implicit real*8 (a-h,o-z)
15860 !      include 'DIMENSIONS'
15861 !      include 'COMMON.GEO'
15862 !      include 'COMMON.VAR'
15863 !      include 'COMMON.LOCAL'
15864 !      include 'COMMON.CHAIN'
15865 !      include 'COMMON.DERIV'
15866 !      include 'COMMON.INTERACT'
15867 !      include 'COMMON.FFIELD'
15868 !      include 'COMMON.IOUNITS'
15869 !      include 'COMMON.CONTROL'
15870       real(kind=8),dimension(3) :: ggg
15871 !el local variables
15872       integer :: i,iint,j,k,iteli,itypj,subchap
15873       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15874       real(kind=8) :: evdw2,evdw2_14,evdwij
15875       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15876                     dist_temp, dist_init
15877
15878       evdw2=0.0D0
15879       evdw2_14=0.0d0
15880 !d    print '(a)','Enter ESCP'
15881 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15882       do i=iatscp_s,iatscp_e
15883         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15884         iteli=itel(i)
15885         xi=0.5D0*(c(1,i)+c(1,i+1))
15886         yi=0.5D0*(c(2,i)+c(2,i+1))
15887         zi=0.5D0*(c(3,i)+c(3,i+1))
15888           xi=mod(xi,boxxsize)
15889           if (xi.lt.0) xi=xi+boxxsize
15890           yi=mod(yi,boxysize)
15891           if (yi.lt.0) yi=yi+boxysize
15892           zi=mod(zi,boxzsize)
15893           if (zi.lt.0) zi=zi+boxzsize
15894
15895         do iint=1,nscp_gr(i)
15896
15897         do j=iscpstart(i,iint),iscpend(i,iint)
15898           itypj=itype(j,1)
15899           if (itypj.eq.ntyp1) cycle
15900 ! Uncomment following three lines for SC-p interactions
15901 !         xj=c(1,nres+j)-xi
15902 !         yj=c(2,nres+j)-yi
15903 !         zj=c(3,nres+j)-zi
15904 ! Uncomment following three lines for Ca-p interactions
15905           xj=c(1,j)
15906           yj=c(2,j)
15907           zj=c(3,j)
15908           xj=mod(xj,boxxsize)
15909           if (xj.lt.0) xj=xj+boxxsize
15910           yj=mod(yj,boxysize)
15911           if (yj.lt.0) yj=yj+boxysize
15912           zj=mod(zj,boxzsize)
15913           if (zj.lt.0) zj=zj+boxzsize
15914       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15915       xj_safe=xj
15916       yj_safe=yj
15917       zj_safe=zj
15918       subchap=0
15919       do xshift=-1,1
15920       do yshift=-1,1
15921       do zshift=-1,1
15922           xj=xj_safe+xshift*boxxsize
15923           yj=yj_safe+yshift*boxysize
15924           zj=zj_safe+zshift*boxzsize
15925           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15926           if(dist_temp.lt.dist_init) then
15927             dist_init=dist_temp
15928             xj_temp=xj
15929             yj_temp=yj
15930             zj_temp=zj
15931             subchap=1
15932           endif
15933        enddo
15934        enddo
15935        enddo
15936        if (subchap.eq.1) then
15937           xj=xj_temp-xi
15938           yj=yj_temp-yi
15939           zj=zj_temp-zi
15940        else
15941           xj=xj_safe-xi
15942           yj=yj_safe-yi
15943           zj=zj_safe-zi
15944        endif
15945           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15946
15947           rij=dsqrt(1.0d0/rrij)
15948             sss_ele_cut=sscale_ele(rij)
15949             sss_ele_grad=sscagrad_ele(rij)
15950 !            print *,sss_ele_cut,sss_ele_grad,&
15951 !            (rij),r_cut_ele,rlamb_ele
15952             if (sss_ele_cut.le.0.0) cycle
15953           sss=sscale((rij/rscp(itypj,iteli)))
15954           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15955           if (sss.lt.1.0d0) then
15956
15957             fac=rrij**expon2
15958             e1=fac*fac*aad(itypj,iteli)
15959             e2=fac*bad(itypj,iteli)
15960             if (iabs(j-i) .le. 2) then
15961               e1=scal14*e1
15962               e2=scal14*e2
15963               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15964             endif
15965             evdwij=e1+e2
15966             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15967             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15968                 'evdw2',i,j,sss,evdwij
15969 !
15970 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15971 !
15972             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15973             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15974             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15975             ggg(1)=xj*fac
15976             ggg(2)=yj*fac
15977             ggg(3)=zj*fac
15978 ! Uncomment following three lines for SC-p interactions
15979 !           do k=1,3
15980 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15981 !           enddo
15982 ! Uncomment following line for SC-p interactions
15983 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15984             do k=1,3
15985               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15986               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15987             enddo
15988           endif
15989         enddo
15990
15991         enddo ! iint
15992       enddo ! i
15993       do i=1,nct
15994         do j=1,3
15995           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15996           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15997           gradx_scp(j,i)=expon*gradx_scp(j,i)
15998         enddo
15999       enddo
16000 !******************************************************************************
16001 !
16002 !                              N O T E !!!
16003 !
16004 ! To save time the factor EXPON has been extracted from ALL components
16005 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16006 ! use!
16007 !
16008 !******************************************************************************
16009       return
16010       end subroutine escp_long
16011 !-----------------------------------------------------------------------------
16012       subroutine escp_short(evdw2,evdw2_14)
16013 !
16014 ! This subroutine calculates the excluded-volume interaction energy between
16015 ! peptide-group centers and side chains and its gradient in virtual-bond and
16016 ! side-chain vectors.
16017 !
16018 !      implicit real*8 (a-h,o-z)
16019 !      include 'DIMENSIONS'
16020 !      include 'COMMON.GEO'
16021 !      include 'COMMON.VAR'
16022 !      include 'COMMON.LOCAL'
16023 !      include 'COMMON.CHAIN'
16024 !      include 'COMMON.DERIV'
16025 !      include 'COMMON.INTERACT'
16026 !      include 'COMMON.FFIELD'
16027 !      include 'COMMON.IOUNITS'
16028 !      include 'COMMON.CONTROL'
16029       real(kind=8),dimension(3) :: ggg
16030 !el local variables
16031       integer :: i,iint,j,k,iteli,itypj,subchap
16032       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16033       real(kind=8) :: evdw2,evdw2_14,evdwij
16034       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16035                     dist_temp, dist_init
16036
16037       evdw2=0.0D0
16038       evdw2_14=0.0d0
16039 !d    print '(a)','Enter ESCP'
16040 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16041       do i=iatscp_s,iatscp_e
16042         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16043         iteli=itel(i)
16044         xi=0.5D0*(c(1,i)+c(1,i+1))
16045         yi=0.5D0*(c(2,i)+c(2,i+1))
16046         zi=0.5D0*(c(3,i)+c(3,i+1))
16047           xi=mod(xi,boxxsize)
16048           if (xi.lt.0) xi=xi+boxxsize
16049           yi=mod(yi,boxysize)
16050           if (yi.lt.0) yi=yi+boxysize
16051           zi=mod(zi,boxzsize)
16052           if (zi.lt.0) zi=zi+boxzsize
16053
16054         do iint=1,nscp_gr(i)
16055
16056         do j=iscpstart(i,iint),iscpend(i,iint)
16057           itypj=itype(j,1)
16058           if (itypj.eq.ntyp1) cycle
16059 ! Uncomment following three lines for SC-p interactions
16060 !         xj=c(1,nres+j)-xi
16061 !         yj=c(2,nres+j)-yi
16062 !         zj=c(3,nres+j)-zi
16063 ! Uncomment following three lines for Ca-p interactions
16064 !          xj=c(1,j)-xi
16065 !          yj=c(2,j)-yi
16066 !          zj=c(3,j)-zi
16067           xj=c(1,j)
16068           yj=c(2,j)
16069           zj=c(3,j)
16070           xj=mod(xj,boxxsize)
16071           if (xj.lt.0) xj=xj+boxxsize
16072           yj=mod(yj,boxysize)
16073           if (yj.lt.0) yj=yj+boxysize
16074           zj=mod(zj,boxzsize)
16075           if (zj.lt.0) zj=zj+boxzsize
16076       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16077       xj_safe=xj
16078       yj_safe=yj
16079       zj_safe=zj
16080       subchap=0
16081       do xshift=-1,1
16082       do yshift=-1,1
16083       do zshift=-1,1
16084           xj=xj_safe+xshift*boxxsize
16085           yj=yj_safe+yshift*boxysize
16086           zj=zj_safe+zshift*boxzsize
16087           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16088           if(dist_temp.lt.dist_init) then
16089             dist_init=dist_temp
16090             xj_temp=xj
16091             yj_temp=yj
16092             zj_temp=zj
16093             subchap=1
16094           endif
16095        enddo
16096        enddo
16097        enddo
16098        if (subchap.eq.1) then
16099           xj=xj_temp-xi
16100           yj=yj_temp-yi
16101           zj=zj_temp-zi
16102        else
16103           xj=xj_safe-xi
16104           yj=yj_safe-yi
16105           zj=zj_safe-zi
16106        endif
16107
16108           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16109           rij=dsqrt(1.0d0/rrij)
16110             sss_ele_cut=sscale_ele(rij)
16111             sss_ele_grad=sscagrad_ele(rij)
16112 !            print *,sss_ele_cut,sss_ele_grad,&
16113 !            (rij),r_cut_ele,rlamb_ele
16114             if (sss_ele_cut.le.0.0) cycle
16115           sss=sscale(rij/rscp(itypj,iteli))
16116           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16117           if (sss.gt.0.0d0) then
16118
16119             fac=rrij**expon2
16120             e1=fac*fac*aad(itypj,iteli)
16121             e2=fac*bad(itypj,iteli)
16122             if (iabs(j-i) .le. 2) then
16123               e1=scal14*e1
16124               e2=scal14*e2
16125               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16126             endif
16127             evdwij=e1+e2
16128             evdw2=evdw2+evdwij*sss*sss_ele_cut
16129             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16130                 'evdw2',i,j,sss,evdwij
16131 !
16132 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16133 !
16134             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16135             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16136             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16137
16138             ggg(1)=xj*fac
16139             ggg(2)=yj*fac
16140             ggg(3)=zj*fac
16141 ! Uncomment following three lines for SC-p interactions
16142 !           do k=1,3
16143 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16144 !           enddo
16145 ! Uncomment following line for SC-p interactions
16146 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16147             do k=1,3
16148               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16149               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16150             enddo
16151           endif
16152         enddo
16153
16154         enddo ! iint
16155       enddo ! i
16156       do i=1,nct
16157         do j=1,3
16158           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16159           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16160           gradx_scp(j,i)=expon*gradx_scp(j,i)
16161         enddo
16162       enddo
16163 !******************************************************************************
16164 !
16165 !                              N O T E !!!
16166 !
16167 ! To save time the factor EXPON has been extracted from ALL components
16168 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16169 ! use!
16170 !
16171 !******************************************************************************
16172       return
16173       end subroutine escp_short
16174 !-----------------------------------------------------------------------------
16175 ! energy_p_new-sep_barrier.F
16176 !-----------------------------------------------------------------------------
16177       subroutine sc_grad_scale(scalfac)
16178 !      implicit real*8 (a-h,o-z)
16179       use calc_data
16180 !      include 'DIMENSIONS'
16181 !      include 'COMMON.CHAIN'
16182 !      include 'COMMON.DERIV'
16183 !      include 'COMMON.CALC'
16184 !      include 'COMMON.IOUNITS'
16185       real(kind=8),dimension(3) :: dcosom1,dcosom2
16186       real(kind=8) :: scalfac
16187 !el local variables
16188 !      integer :: i,j,k,l
16189
16190       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16191       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16192       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16193            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16194 ! diagnostics only
16195 !      eom1=0.0d0
16196 !      eom2=0.0d0
16197 !      eom12=evdwij*eps1_om12
16198 ! end diagnostics
16199 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16200 !     &  " sigder",sigder
16201 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16202 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16203       do k=1,3
16204         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16205         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16206       enddo
16207       do k=1,3
16208         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16209          *sss_ele_cut
16210       enddo
16211 !      write (iout,*) "gg",(gg(k),k=1,3)
16212       do k=1,3
16213         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16214                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16215                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16216                  *sss_ele_cut
16217         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16218                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16219                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16220          *sss_ele_cut
16221 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16222 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16223 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16224 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16225       enddo
16226 !
16227 ! Calculate the components of the gradient in DC and X
16228 !
16229       do l=1,3
16230         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16231         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16232       enddo
16233       return
16234       end subroutine sc_grad_scale
16235 !-----------------------------------------------------------------------------
16236 ! energy_split-sep.F
16237 !-----------------------------------------------------------------------------
16238       subroutine etotal_long(energia)
16239 !
16240 ! Compute the long-range slow-varying contributions to the energy
16241 !
16242 !      implicit real*8 (a-h,o-z)
16243 !      include 'DIMENSIONS'
16244       use MD_data, only: totT,usampl,eq_time
16245 #ifndef ISNAN
16246       external proc_proc
16247 #ifdef WINPGI
16248 !MS$ATTRIBUTES C ::  proc_proc
16249 #endif
16250 #endif
16251 #ifdef MPI
16252       include "mpif.h"
16253       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16254 #endif
16255 !      include 'COMMON.SETUP'
16256 !      include 'COMMON.IOUNITS'
16257 !      include 'COMMON.FFIELD'
16258 !      include 'COMMON.DERIV'
16259 !      include 'COMMON.INTERACT'
16260 !      include 'COMMON.SBRIDGE'
16261 !      include 'COMMON.CHAIN'
16262 !      include 'COMMON.VAR'
16263 !      include 'COMMON.LOCAL'
16264 !      include 'COMMON.MD'
16265       real(kind=8),dimension(0:n_ene) :: energia
16266 !el local variables
16267       integer :: i,n_corr,n_corr1,ierror,ierr
16268       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16269                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16270                   ecorr,ecorr5,ecorr6,eturn6,time00
16271 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16272 !elwrite(iout,*)"in etotal long"
16273
16274       if (modecalc.eq.12.or.modecalc.eq.14) then
16275 #ifdef MPI
16276 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16277 #else
16278         call int_from_cart1(.false.)
16279 #endif
16280       endif
16281 !elwrite(iout,*)"in etotal long"
16282
16283 #ifdef MPI
16284 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16285 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16286       call flush(iout)
16287       if (nfgtasks.gt.1) then
16288         time00=MPI_Wtime()
16289 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16290         if (fg_rank.eq.0) then
16291           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16292 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16293 !          call flush(iout)
16294 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16295 ! FG slaves as WEIGHTS array.
16296           weights_(1)=wsc
16297           weights_(2)=wscp
16298           weights_(3)=welec
16299           weights_(4)=wcorr
16300           weights_(5)=wcorr5
16301           weights_(6)=wcorr6
16302           weights_(7)=wel_loc
16303           weights_(8)=wturn3
16304           weights_(9)=wturn4
16305           weights_(10)=wturn6
16306           weights_(11)=wang
16307           weights_(12)=wscloc
16308           weights_(13)=wtor
16309           weights_(14)=wtor_d
16310           weights_(15)=wstrain
16311           weights_(16)=wvdwpp
16312           weights_(17)=wbond
16313           weights_(18)=scal14
16314           weights_(21)=wsccor
16315 ! FG Master broadcasts the WEIGHTS_ array
16316           call MPI_Bcast(weights_(1),n_ene,&
16317               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16318         else
16319 ! FG slaves receive the WEIGHTS array
16320           call MPI_Bcast(weights(1),n_ene,&
16321               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16322           wsc=weights(1)
16323           wscp=weights(2)
16324           welec=weights(3)
16325           wcorr=weights(4)
16326           wcorr5=weights(5)
16327           wcorr6=weights(6)
16328           wel_loc=weights(7)
16329           wturn3=weights(8)
16330           wturn4=weights(9)
16331           wturn6=weights(10)
16332           wang=weights(11)
16333           wscloc=weights(12)
16334           wtor=weights(13)
16335           wtor_d=weights(14)
16336           wstrain=weights(15)
16337           wvdwpp=weights(16)
16338           wbond=weights(17)
16339           scal14=weights(18)
16340           wsccor=weights(21)
16341         endif
16342         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16343           king,FG_COMM,IERR)
16344          time_Bcast=time_Bcast+MPI_Wtime()-time00
16345          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16346 !        call chainbuild_cart
16347 !        call int_from_cart1(.false.)
16348       endif
16349 !      write (iout,*) 'Processor',myrank,
16350 !     &  ' calling etotal_short ipot=',ipot
16351 !      call flush(iout)
16352 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16353 #endif
16354 !d    print *,'nnt=',nnt,' nct=',nct
16355 !
16356 !elwrite(iout,*)"in etotal long"
16357 ! Compute the side-chain and electrostatic interaction energy
16358 !
16359       goto (101,102,103,104,105,106) ipot
16360 ! Lennard-Jones potential.
16361   101 call elj_long(evdw)
16362 !d    print '(a)','Exit ELJ'
16363       goto 107
16364 ! Lennard-Jones-Kihara potential (shifted).
16365   102 call eljk_long(evdw)
16366       goto 107
16367 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16368   103 call ebp_long(evdw)
16369       goto 107
16370 ! Gay-Berne potential (shifted LJ, angular dependence).
16371   104 call egb_long(evdw)
16372       goto 107
16373 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16374   105 call egbv_long(evdw)
16375       goto 107
16376 ! Soft-sphere potential
16377   106 call e_softsphere(evdw)
16378 !
16379 ! Calculate electrostatic (H-bonding) energy of the main chain.
16380 !
16381   107 continue
16382       call vec_and_deriv
16383       if (ipot.lt.6) then
16384 #ifdef SPLITELE
16385          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16386              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16387              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16388              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16389 #else
16390          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16391              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16392              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16393              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16394 #endif
16395            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16396          else
16397             ees=0
16398             evdw1=0
16399             eel_loc=0
16400             eello_turn3=0
16401             eello_turn4=0
16402          endif
16403       else
16404 !        write (iout,*) "Soft-spheer ELEC potential"
16405         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16406          eello_turn4)
16407       endif
16408 !
16409 ! Calculate excluded-volume interaction energy between peptide groups
16410 ! and side chains.
16411 !
16412       if (ipot.lt.6) then
16413        if(wscp.gt.0d0) then
16414         call escp_long(evdw2,evdw2_14)
16415        else
16416         evdw2=0
16417         evdw2_14=0
16418        endif
16419       else
16420         call escp_soft_sphere(evdw2,evdw2_14)
16421       endif
16422 !
16423 ! 12/1/95 Multi-body terms
16424 !
16425       n_corr=0
16426       n_corr1=0
16427       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16428           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16429          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16430 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16431 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16432       else
16433          ecorr=0.0d0
16434          ecorr5=0.0d0
16435          ecorr6=0.0d0
16436          eturn6=0.0d0
16437       endif
16438       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16439          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16440       endif
16441 !
16442 ! If performing constraint dynamics, call the constraint energy
16443 !  after the equilibration time
16444       if(usampl.and.totT.gt.eq_time) then
16445          call EconstrQ
16446          call Econstr_back
16447       else
16448          Uconst=0.0d0
16449          Uconst_back=0.0d0
16450       endif
16451 !
16452 ! Sum the energies
16453 !
16454       do i=1,n_ene
16455         energia(i)=0.0d0
16456       enddo
16457       energia(1)=evdw
16458 #ifdef SCP14
16459       energia(2)=evdw2-evdw2_14
16460       energia(18)=evdw2_14
16461 #else
16462       energia(2)=evdw2
16463       energia(18)=0.0d0
16464 #endif
16465 #ifdef SPLITELE
16466       energia(3)=ees
16467       energia(16)=evdw1
16468 #else
16469       energia(3)=ees+evdw1
16470       energia(16)=0.0d0
16471 #endif
16472       energia(4)=ecorr
16473       energia(5)=ecorr5
16474       energia(6)=ecorr6
16475       energia(7)=eel_loc
16476       energia(8)=eello_turn3
16477       energia(9)=eello_turn4
16478       energia(10)=eturn6
16479       energia(20)=Uconst+Uconst_back
16480       call sum_energy(energia,.true.)
16481 !      write (iout,*) "Exit ETOTAL_LONG"
16482       call flush(iout)
16483       return
16484       end subroutine etotal_long
16485 !-----------------------------------------------------------------------------
16486       subroutine etotal_short(energia)
16487 !
16488 ! Compute the short-range fast-varying contributions to the energy
16489 !
16490 !      implicit real*8 (a-h,o-z)
16491 !      include 'DIMENSIONS'
16492 #ifndef ISNAN
16493       external proc_proc
16494 #ifdef WINPGI
16495 !MS$ATTRIBUTES C ::  proc_proc
16496 #endif
16497 #endif
16498 #ifdef MPI
16499       include "mpif.h"
16500       integer :: ierror,ierr
16501       real(kind=8),dimension(n_ene) :: weights_
16502       real(kind=8) :: time00
16503 #endif
16504 !      include 'COMMON.SETUP'
16505 !      include 'COMMON.IOUNITS'
16506 !      include 'COMMON.FFIELD'
16507 !      include 'COMMON.DERIV'
16508 !      include 'COMMON.INTERACT'
16509 !      include 'COMMON.SBRIDGE'
16510 !      include 'COMMON.CHAIN'
16511 !      include 'COMMON.VAR'
16512 !      include 'COMMON.LOCAL'
16513       real(kind=8),dimension(0:n_ene) :: energia
16514 !el local variables
16515       integer :: i,nres6
16516       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16517       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16518       nres6=6*nres
16519
16520 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16521 !      call flush(iout)
16522       if (modecalc.eq.12.or.modecalc.eq.14) then
16523 #ifdef MPI
16524         if (fg_rank.eq.0) call int_from_cart1(.false.)
16525 #else
16526         call int_from_cart1(.false.)
16527 #endif
16528       endif
16529 #ifdef MPI
16530 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16531 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16532 !      call flush(iout)
16533       if (nfgtasks.gt.1) then
16534         time00=MPI_Wtime()
16535 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16536         if (fg_rank.eq.0) then
16537           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16538 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16539 !          call flush(iout)
16540 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16541 ! FG slaves as WEIGHTS array.
16542           weights_(1)=wsc
16543           weights_(2)=wscp
16544           weights_(3)=welec
16545           weights_(4)=wcorr
16546           weights_(5)=wcorr5
16547           weights_(6)=wcorr6
16548           weights_(7)=wel_loc
16549           weights_(8)=wturn3
16550           weights_(9)=wturn4
16551           weights_(10)=wturn6
16552           weights_(11)=wang
16553           weights_(12)=wscloc
16554           weights_(13)=wtor
16555           weights_(14)=wtor_d
16556           weights_(15)=wstrain
16557           weights_(16)=wvdwpp
16558           weights_(17)=wbond
16559           weights_(18)=scal14
16560           weights_(21)=wsccor
16561 ! FG Master broadcasts the WEIGHTS_ array
16562           call MPI_Bcast(weights_(1),n_ene,&
16563               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16564         else
16565 ! FG slaves receive the WEIGHTS array
16566           call MPI_Bcast(weights(1),n_ene,&
16567               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16568           wsc=weights(1)
16569           wscp=weights(2)
16570           welec=weights(3)
16571           wcorr=weights(4)
16572           wcorr5=weights(5)
16573           wcorr6=weights(6)
16574           wel_loc=weights(7)
16575           wturn3=weights(8)
16576           wturn4=weights(9)
16577           wturn6=weights(10)
16578           wang=weights(11)
16579           wscloc=weights(12)
16580           wtor=weights(13)
16581           wtor_d=weights(14)
16582           wstrain=weights(15)
16583           wvdwpp=weights(16)
16584           wbond=weights(17)
16585           scal14=weights(18)
16586           wsccor=weights(21)
16587         endif
16588 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16589         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16590           king,FG_COMM,IERR)
16591 !        write (iout,*) "Processor",myrank," BROADCAST c"
16592         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16593           king,FG_COMM,IERR)
16594 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16595         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16596           king,FG_COMM,IERR)
16597 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16598         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16599           king,FG_COMM,IERR)
16600 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16601         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16602           king,FG_COMM,IERR)
16603 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16604         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16605           king,FG_COMM,IERR)
16606 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16607         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16608           king,FG_COMM,IERR)
16609 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16610         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16611           king,FG_COMM,IERR)
16612 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16613         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16614           king,FG_COMM,IERR)
16615          time_Bcast=time_Bcast+MPI_Wtime()-time00
16616 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16617       endif
16618 !      write (iout,*) 'Processor',myrank,
16619 !     &  ' calling etotal_short ipot=',ipot
16620 !      call flush(iout)
16621 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16622 #endif
16623 !      call int_from_cart1(.false.)
16624 !
16625 ! Compute the side-chain and electrostatic interaction energy
16626 !
16627       goto (101,102,103,104,105,106) ipot
16628 ! Lennard-Jones potential.
16629   101 call elj_short(evdw)
16630 !d    print '(a)','Exit ELJ'
16631       goto 107
16632 ! Lennard-Jones-Kihara potential (shifted).
16633   102 call eljk_short(evdw)
16634       goto 107
16635 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16636   103 call ebp_short(evdw)
16637       goto 107
16638 ! Gay-Berne potential (shifted LJ, angular dependence).
16639   104 call egb_short(evdw)
16640       goto 107
16641 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16642   105 call egbv_short(evdw)
16643       goto 107
16644 ! Soft-sphere potential - already dealt with in the long-range part
16645   106 evdw=0.0d0
16646 !  106 call e_softsphere_short(evdw)
16647 !
16648 ! Calculate electrostatic (H-bonding) energy of the main chain.
16649 !
16650   107 continue
16651 !
16652 ! Calculate the short-range part of Evdwpp
16653 !
16654       call evdwpp_short(evdw1)
16655 !
16656 ! Calculate the short-range part of ESCp
16657 !
16658       if (ipot.lt.6) then
16659         call escp_short(evdw2,evdw2_14)
16660       endif
16661 !
16662 ! Calculate the bond-stretching energy
16663 !
16664       call ebond(estr)
16665 !
16666 ! Calculate the disulfide-bridge and other energy and the contributions
16667 ! from other distance constraints.
16668       call edis(ehpb)
16669 !
16670 ! Calculate the virtual-bond-angle energy.
16671 !
16672 ! Calculate the SC local energy.
16673 !
16674       call vec_and_deriv
16675       call esc(escloc)
16676 !
16677       if (wang.gt.0d0) then
16678        if (tor_mode.eq.0) then
16679          call ebend(ebe)
16680        else
16681 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16682 !C energy function
16683          call ebend_kcc(ebe)
16684        endif
16685       else
16686         ebe=0.0d0
16687       endif
16688       ethetacnstr=0.0d0
16689       if (with_theta_constr) call etheta_constr(ethetacnstr)
16690
16691 !       write(iout,*) "in etotal afer ebe",ipot
16692
16693 !      print *,"Processor",myrank," computed UB"
16694 !
16695 ! Calculate the SC local energy.
16696 !
16697       call esc(escloc)
16698 !elwrite(iout,*) "in etotal afer esc",ipot
16699 !      print *,"Processor",myrank," computed USC"
16700 !
16701 ! Calculate the virtual-bond torsional energy.
16702 !
16703 !d    print *,'nterm=',nterm
16704 !      if (wtor.gt.0) then
16705 !       call etor(etors,edihcnstr)
16706 !      else
16707 !       etors=0
16708 !       edihcnstr=0
16709 !      endif
16710       if (wtor.gt.0.0d0) then
16711          if (tor_mode.eq.0) then
16712            call etor(etors)
16713          else
16714 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16715 !C energy function
16716            call etor_kcc(etors)
16717          endif
16718       else
16719         etors=0.0d0
16720       endif
16721       edihcnstr=0.0d0
16722       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16723
16724 ! Calculate the virtual-bond torsional energy.
16725 !
16726 !
16727 ! 6/23/01 Calculate double-torsional energy
16728 !
16729       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16730       call etor_d(etors_d)
16731       endif
16732 !
16733 ! 21/5/07 Calculate local sicdechain correlation energy
16734 !
16735       if (wsccor.gt.0.0d0) then
16736         call eback_sc_corr(esccor)
16737       else
16738         esccor=0.0d0
16739       endif
16740 !
16741 ! Put energy components into an array
16742 !
16743       do i=1,n_ene
16744         energia(i)=0.0d0
16745       enddo
16746       energia(1)=evdw
16747 #ifdef SCP14
16748       energia(2)=evdw2-evdw2_14
16749       energia(18)=evdw2_14
16750 #else
16751       energia(2)=evdw2
16752       energia(18)=0.0d0
16753 #endif
16754 #ifdef SPLITELE
16755       energia(16)=evdw1
16756 #else
16757       energia(3)=evdw1
16758 #endif
16759       energia(11)=ebe
16760       energia(12)=escloc
16761       energia(13)=etors
16762       energia(14)=etors_d
16763       energia(15)=ehpb
16764       energia(17)=estr
16765       energia(19)=edihcnstr
16766       energia(21)=esccor
16767 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16768       call flush(iout)
16769       call sum_energy(energia,.true.)
16770 !      write (iout,*) "Exit ETOTAL_SHORT"
16771       call flush(iout)
16772       return
16773       end subroutine etotal_short
16774 !-----------------------------------------------------------------------------
16775 ! gnmr1.f
16776 !-----------------------------------------------------------------------------
16777       real(kind=8) function gnmr1(y,ymin,ymax)
16778 !      implicit none
16779       real(kind=8) :: y,ymin,ymax
16780       real(kind=8) :: wykl=4.0d0
16781       if (y.lt.ymin) then
16782         gnmr1=(ymin-y)**wykl/wykl
16783       else if (y.gt.ymax) then
16784         gnmr1=(y-ymax)**wykl/wykl
16785       else
16786         gnmr1=0.0d0
16787       endif
16788       return
16789       end function gnmr1
16790 !-----------------------------------------------------------------------------
16791       real(kind=8) function gnmr1prim(y,ymin,ymax)
16792 !      implicit none
16793       real(kind=8) :: y,ymin,ymax
16794       real(kind=8) :: wykl=4.0d0
16795       if (y.lt.ymin) then
16796         gnmr1prim=-(ymin-y)**(wykl-1)
16797       else if (y.gt.ymax) then
16798         gnmr1prim=(y-ymax)**(wykl-1)
16799       else
16800         gnmr1prim=0.0d0
16801       endif
16802       return
16803       end function gnmr1prim
16804 !----------------------------------------------------------------------------
16805       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16806       real(kind=8) y,ymin,ymax,sigma
16807       real(kind=8) wykl /4.0d0/
16808       if (y.lt.ymin) then
16809         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16810       else if (y.gt.ymax) then
16811         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16812       else
16813         rlornmr1=0.0d0
16814       endif
16815       return
16816       end function rlornmr1
16817 !------------------------------------------------------------------------------
16818       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16819       real(kind=8) y,ymin,ymax,sigma
16820       real(kind=8) wykl /4.0d0/
16821       if (y.lt.ymin) then
16822         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16823         ((ymin-y)**wykl+sigma**wykl)**2
16824       else if (y.gt.ymax) then
16825         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16826         ((y-ymax)**wykl+sigma**wykl)**2
16827       else
16828         rlornmr1prim=0.0d0
16829       endif
16830       return
16831       end function rlornmr1prim
16832
16833       real(kind=8) function harmonic(y,ymax)
16834 !      implicit none
16835       real(kind=8) :: y,ymax
16836       real(kind=8) :: wykl=2.0d0
16837       harmonic=(y-ymax)**wykl
16838       return
16839       end function harmonic
16840 !-----------------------------------------------------------------------------
16841       real(kind=8) function harmonicprim(y,ymax)
16842       real(kind=8) :: y,ymin,ymax
16843       real(kind=8) :: wykl=2.0d0
16844       harmonicprim=(y-ymax)*wykl
16845       return
16846       end function harmonicprim
16847 !-----------------------------------------------------------------------------
16848 ! gradient_p.F
16849 !-----------------------------------------------------------------------------
16850       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16851
16852       use io_base, only:intout,briefout
16853 !      implicit real*8 (a-h,o-z)
16854 !      include 'DIMENSIONS'
16855 !      include 'COMMON.CHAIN'
16856 !      include 'COMMON.DERIV'
16857 !      include 'COMMON.VAR'
16858 !      include 'COMMON.INTERACT'
16859 !      include 'COMMON.FFIELD'
16860 !      include 'COMMON.MD'
16861 !      include 'COMMON.IOUNITS'
16862       real(kind=8),external :: ufparm
16863       integer :: uiparm(1)
16864       real(kind=8) :: urparm(1)
16865       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16866       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16867       integer :: n,nf,ind,ind1,i,k,j
16868 !
16869 ! This subroutine calculates total internal coordinate gradient.
16870 ! Depending on the number of function evaluations, either whole energy
16871 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16872 ! internal coordinates are reevaluated or only the cartesian-in-internal
16873 ! coordinate derivatives are evaluated. The subroutine was designed to work
16874 ! with SUMSL.
16875 !
16876 !
16877       icg=mod(nf,2)+1
16878
16879 !d      print *,'grad',nf,icg
16880       if (nf-nfl+1) 20,30,40
16881    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16882 !    write (iout,*) 'grad 20'
16883       if (nf.eq.0) return
16884       goto 40
16885    30 call var_to_geom(n,x)
16886       call chainbuild
16887 !    write (iout,*) 'grad 30'
16888 !
16889 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16890 !
16891    40 call cartder
16892 !     write (iout,*) 'grad 40'
16893 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16894 !
16895 ! Convert the Cartesian gradient into internal-coordinate gradient.
16896 !
16897       ind=0
16898       ind1=0
16899       do i=1,nres-2
16900       gthetai=0.0D0
16901       gphii=0.0D0
16902       do j=i+1,nres-1
16903           ind=ind+1
16904 !         ind=indmat(i,j)
16905 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16906         do k=1,3
16907             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16908           enddo
16909         do k=1,3
16910           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16911           enddo
16912         enddo
16913       do j=i+1,nres-1
16914           ind1=ind1+1
16915 !         ind1=indmat(i,j)
16916 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16917         do k=1,3
16918           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16919           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16920           enddo
16921         enddo
16922       if (i.gt.1) g(i-1)=gphii
16923       if (n.gt.nphi) g(nphi+i)=gthetai
16924       enddo
16925       if (n.le.nphi+ntheta) goto 10
16926       do i=2,nres-1
16927       if (itype(i,1).ne.10) then
16928           galphai=0.0D0
16929         gomegai=0.0D0
16930         do k=1,3
16931           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16932           enddo
16933         do k=1,3
16934           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16935           enddo
16936           g(ialph(i,1))=galphai
16937         g(ialph(i,1)+nside)=gomegai
16938         endif
16939       enddo
16940 !
16941 ! Add the components corresponding to local energy terms.
16942 !
16943    10 continue
16944       do i=1,nvar
16945 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16946         g(i)=g(i)+gloc(i,icg)
16947       enddo
16948 ! Uncomment following three lines for diagnostics.
16949 !d    call intout
16950 !elwrite(iout,*) "in gradient after calling intout"
16951 !d    call briefout(0,0.0d0)
16952 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16953       return
16954       end subroutine gradient
16955 !-----------------------------------------------------------------------------
16956       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16957
16958       use comm_chu
16959 !      implicit real*8 (a-h,o-z)
16960 !      include 'DIMENSIONS'
16961 !      include 'COMMON.DERIV'
16962 !      include 'COMMON.IOUNITS'
16963 !      include 'COMMON.GEO'
16964       integer :: n,nf
16965 !el      integer :: jjj
16966 !el      common /chuju/ jjj
16967       real(kind=8) :: energia(0:n_ene)
16968       integer :: uiparm(1)
16969       real(kind=8) :: urparm(1)
16970       real(kind=8) :: f
16971       real(kind=8),external :: ufparm
16972       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16973 !     if (jjj.gt.0) then
16974 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16975 !     endif
16976       nfl=nf
16977       icg=mod(nf,2)+1
16978 !d      print *,'func',nf,nfl,icg
16979       call var_to_geom(n,x)
16980       call zerograd
16981       call chainbuild
16982 !d    write (iout,*) 'ETOTAL called from FUNC'
16983       call etotal(energia)
16984       call sum_gradient
16985       f=energia(0)
16986 !     if (jjj.gt.0) then
16987 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16988 !       write (iout,*) 'f=',etot
16989 !       jjj=0
16990 !     endif
16991       return
16992       end subroutine func
16993 !-----------------------------------------------------------------------------
16994       subroutine cartgrad
16995 !      implicit real*8 (a-h,o-z)
16996 !      include 'DIMENSIONS'
16997       use energy_data
16998       use MD_data, only: totT,usampl,eq_time
16999 #ifdef MPI
17000       include 'mpif.h'
17001 #endif
17002 !      include 'COMMON.CHAIN'
17003 !      include 'COMMON.DERIV'
17004 !      include 'COMMON.VAR'
17005 !      include 'COMMON.INTERACT'
17006 !      include 'COMMON.FFIELD'
17007 !      include 'COMMON.MD'
17008 !      include 'COMMON.IOUNITS'
17009 !      include 'COMMON.TIME1'
17010 !
17011       integer :: i,j
17012
17013 ! This subrouting calculates total Cartesian coordinate gradient.
17014 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17015 !
17016 !#define DEBUG
17017 #ifdef TIMING
17018       time00=MPI_Wtime()
17019 #endif
17020       icg=1
17021       call sum_gradient
17022 #ifdef TIMING
17023 #endif
17024 !#define DEBUG
17025 !el      write (iout,*) "After sum_gradient"
17026 #ifdef DEBUG
17027 !el      write (iout,*) "After sum_gradient"
17028       do i=1,nres-1
17029         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17030         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17031       enddo
17032 #endif
17033 !#undef DEBUG
17034 ! If performing constraint dynamics, add the gradients of the constraint energy
17035       if(usampl.and.totT.gt.eq_time) then
17036          do i=1,nct
17037            do j=1,3
17038              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17039              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17040            enddo
17041          enddo
17042          do i=1,nres-3
17043            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17044          enddo
17045          do i=1,nres-2
17046            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17047          enddo
17048       endif
17049 !elwrite (iout,*) "After sum_gradient"
17050 #ifdef TIMING
17051       time01=MPI_Wtime()
17052 #endif
17053       call intcartderiv
17054 !elwrite (iout,*) "After sum_gradient"
17055 #ifdef TIMING
17056       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17057 #endif
17058 !     call checkintcartgrad
17059 !     write(iout,*) 'calling int_to_cart'
17060 !#define DEBUG
17061 #ifdef DEBUG
17062       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17063 #endif
17064       do i=0,nct
17065         do j=1,3
17066           gcart(j,i)=gradc(j,i,icg)
17067           gxcart(j,i)=gradx(j,i,icg)
17068 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17069         enddo
17070 #ifdef DEBUG
17071         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17072           (gxcart(j,i),j=1,3),gloc(i,icg)
17073 #endif
17074       enddo
17075 #ifdef TIMING
17076       time01=MPI_Wtime()
17077 #endif
17078 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17079       call int_to_cart
17080 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17081
17082 #ifdef TIMING
17083             time_inttocart=time_inttocart+MPI_Wtime()-time01
17084 #endif
17085 #ifdef DEBUG
17086             write (iout,*) "gcart and gxcart after int_to_cart"
17087             do i=0,nres-1
17088             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17089                 (gxcart(j,i),j=1,3)
17090             enddo
17091 #endif
17092 !#undef DEBUG
17093 #ifdef CARGRAD
17094 #ifdef DEBUG
17095             write (iout,*) "CARGRAD"
17096 #endif
17097             do i=nres,0,-1
17098             do j=1,3
17099               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17100       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17101             enddo
17102       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17103       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17104             enddo
17105       ! Correction: dummy residues
17106             if (nnt.gt.1) then
17107               do j=1,3
17108       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17109                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17110               enddo
17111             endif
17112             if (nct.lt.nres) then
17113               do j=1,3
17114       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17115                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17116               enddo
17117             endif
17118 #endif
17119 #ifdef TIMING
17120             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17121 #endif
17122 !#undef DEBUG
17123             return
17124             end subroutine cartgrad
17125       !-----------------------------------------------------------------------------
17126             subroutine zerograd
17127       !      implicit real*8 (a-h,o-z)
17128       !      include 'DIMENSIONS'
17129       !      include 'COMMON.DERIV'
17130       !      include 'COMMON.CHAIN'
17131       !      include 'COMMON.VAR'
17132       !      include 'COMMON.MD'
17133       !      include 'COMMON.SCCOR'
17134       !
17135       !el local variables
17136             integer :: i,j,intertyp,k
17137       ! Initialize Cartesian-coordinate gradient
17138       !
17139       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17140       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17141
17142       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17143       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17144       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17145       !      allocate(gradcorr_long(3,nres))
17146       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17147       !      allocate(gcorr6_turn_long(3,nres))
17148       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17149
17150       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17151
17152       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17153       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17154
17155       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17156       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17157
17158       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17159       !      allocate(gscloc(3,nres)) !(3,maxres)
17160       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17161
17162
17163
17164       !      common /deriv_scloc/
17165       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17166       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17167       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17168       !      common /mpgrad/
17169       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17170
17171
17172
17173       !          gradc(j,i,icg)=0.0d0
17174       !          gradx(j,i,icg)=0.0d0
17175
17176       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17177       !elwrite(iout,*) "icg",icg
17178             do i=-1,nres
17179             do j=1,3
17180               gvdwx(j,i)=0.0D0
17181               gradx_scp(j,i)=0.0D0
17182               gvdwc(j,i)=0.0D0
17183               gvdwc_scp(j,i)=0.0D0
17184               gvdwc_scpp(j,i)=0.0d0
17185               gelc(j,i)=0.0D0
17186               gelc_long(j,i)=0.0D0
17187               gradb(j,i)=0.0d0
17188               gradbx(j,i)=0.0d0
17189               gvdwpp(j,i)=0.0d0
17190               gel_loc(j,i)=0.0d0
17191               gel_loc_long(j,i)=0.0d0
17192               ghpbc(j,i)=0.0D0
17193               ghpbx(j,i)=0.0D0
17194               gcorr3_turn(j,i)=0.0d0
17195               gcorr4_turn(j,i)=0.0d0
17196               gradcorr(j,i)=0.0d0
17197               gradcorr_long(j,i)=0.0d0
17198               gradcorr5_long(j,i)=0.0d0
17199               gradcorr6_long(j,i)=0.0d0
17200               gcorr6_turn_long(j,i)=0.0d0
17201               gradcorr5(j,i)=0.0d0
17202               gradcorr6(j,i)=0.0d0
17203               gcorr6_turn(j,i)=0.0d0
17204               gsccorc(j,i)=0.0d0
17205               gsccorx(j,i)=0.0d0
17206               gradc(j,i,icg)=0.0d0
17207               gradx(j,i,icg)=0.0d0
17208               gscloc(j,i)=0.0d0
17209               gsclocx(j,i)=0.0d0
17210               gliptran(j,i)=0.0d0
17211               gliptranx(j,i)=0.0d0
17212               gliptranc(j,i)=0.0d0
17213               gshieldx(j,i)=0.0d0
17214               gshieldc(j,i)=0.0d0
17215               gshieldc_loc(j,i)=0.0d0
17216               gshieldx_ec(j,i)=0.0d0
17217               gshieldc_ec(j,i)=0.0d0
17218               gshieldc_loc_ec(j,i)=0.0d0
17219               gshieldx_t3(j,i)=0.0d0
17220               gshieldc_t3(j,i)=0.0d0
17221               gshieldc_loc_t3(j,i)=0.0d0
17222               gshieldx_t4(j,i)=0.0d0
17223               gshieldc_t4(j,i)=0.0d0
17224               gshieldc_loc_t4(j,i)=0.0d0
17225               gshieldx_ll(j,i)=0.0d0
17226               gshieldc_ll(j,i)=0.0d0
17227               gshieldc_loc_ll(j,i)=0.0d0
17228               gg_tube(j,i)=0.0d0
17229               gg_tube_sc(j,i)=0.0d0
17230               gradafm(j,i)=0.0d0
17231               gradb_nucl(j,i)=0.0d0
17232               gradbx_nucl(j,i)=0.0d0
17233               gvdwpp_nucl(j,i)=0.0d0
17234               gvdwpp(j,i)=0.0d0
17235               gelpp(j,i)=0.0d0
17236               gvdwpsb(j,i)=0.0d0
17237               gvdwpsb1(j,i)=0.0d0
17238               gvdwsbc(j,i)=0.0d0
17239               gvdwsbx(j,i)=0.0d0
17240               gelsbc(j,i)=0.0d0
17241               gradcorr_nucl(j,i)=0.0d0
17242               gradcorr3_nucl(j,i)=0.0d0
17243               gradxorr_nucl(j,i)=0.0d0
17244               gradxorr3_nucl(j,i)=0.0d0
17245               gelsbx(j,i)=0.0d0
17246               gsbloc(j,i)=0.0d0
17247               gsblocx(j,i)=0.0d0
17248               gradpepcat(j,i)=0.0d0
17249               gradpepcatx(j,i)=0.0d0
17250               gradcatcat(j,i)=0.0d0
17251               gvdwx_scbase(j,i)=0.0d0
17252               gvdwc_scbase(j,i)=0.0d0
17253               gvdwx_pepbase(j,i)=0.0d0
17254               gvdwc_pepbase(j,i)=0.0d0
17255               gvdwx_scpho(j,i)=0.0d0
17256               gvdwc_scpho(j,i)=0.0d0
17257               gvdwc_peppho(j,i)=0.0d0
17258             enddo
17259              enddo
17260             do i=0,nres
17261             do j=1,3
17262               do intertyp=1,3
17263                gloc_sc(intertyp,i,icg)=0.0d0
17264               enddo
17265             enddo
17266             enddo
17267             do i=1,nres
17268              do j=1,maxcontsshi
17269              shield_list(j,i)=0
17270             do k=1,3
17271       !C           print *,i,j,k
17272                grad_shield_side(k,j,i)=0.0d0
17273                grad_shield_loc(k,j,i)=0.0d0
17274              enddo
17275              enddo
17276              ishield_list(i)=0
17277             enddo
17278
17279       !
17280       ! Initialize the gradient of local energy terms.
17281       !
17282       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17283       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17284       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17285       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17286       !      allocate(gel_loc_turn3(nres))
17287       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17288       !      allocate(gsccor_loc(nres))      !(maxres)
17289
17290             do i=1,4*nres
17291             gloc(i,icg)=0.0D0
17292             enddo
17293             do i=1,nres
17294             gel_loc_loc(i)=0.0d0
17295             gcorr_loc(i)=0.0d0
17296             g_corr5_loc(i)=0.0d0
17297             g_corr6_loc(i)=0.0d0
17298             gel_loc_turn3(i)=0.0d0
17299             gel_loc_turn4(i)=0.0d0
17300             gel_loc_turn6(i)=0.0d0
17301             gsccor_loc(i)=0.0d0
17302             enddo
17303       ! initialize gcart and gxcart
17304       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17305             do i=0,nres
17306             do j=1,3
17307               gcart(j,i)=0.0d0
17308               gxcart(j,i)=0.0d0
17309             enddo
17310             enddo
17311             return
17312             end subroutine zerograd
17313       !-----------------------------------------------------------------------------
17314             real(kind=8) function fdum()
17315             fdum=0.0D0
17316             return
17317             end function fdum
17318       !-----------------------------------------------------------------------------
17319       ! intcartderiv.F
17320       !-----------------------------------------------------------------------------
17321             subroutine intcartderiv
17322       !      implicit real*8 (a-h,o-z)
17323       !      include 'DIMENSIONS'
17324 #ifdef MPI
17325             include 'mpif.h'
17326 #endif
17327       !      include 'COMMON.SETUP'
17328       !      include 'COMMON.CHAIN'
17329       !      include 'COMMON.VAR'
17330       !      include 'COMMON.GEO'
17331       !      include 'COMMON.INTERACT'
17332       !      include 'COMMON.DERIV'
17333       !      include 'COMMON.IOUNITS'
17334       !      include 'COMMON.LOCAL'
17335       !      include 'COMMON.SCCOR'
17336             real(kind=8) :: pi4,pi34
17337             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17338             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17339                       dcosomega,dsinomega !(3,3,maxres)
17340             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17341
17342             integer :: i,j,k
17343             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17344                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17345                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17346                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17347             integer :: nres2
17348             nres2=2*nres
17349
17350       !el from module energy-------------
17351       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17352       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17353       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17354
17355       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17356       !el      allocate(dsintau(3,3,3,0:nres2))
17357       !el      allocate(dtauangle(3,3,3,0:nres2))
17358       !el      allocate(domicron(3,2,2,0:nres2))
17359       !el      allocate(dcosomicron(3,2,2,0:nres2))
17360
17361
17362
17363 #if defined(MPI) && defined(PARINTDER)
17364             if (nfgtasks.gt.1 .and. me.eq.king) &
17365             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17366 #endif
17367             pi4 = 0.5d0*pipol
17368             pi34 = 3*pi4
17369
17370       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17371       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17372
17373       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17374             do i=1,nres
17375             do j=1,3
17376               dtheta(j,1,i)=0.0d0
17377               dtheta(j,2,i)=0.0d0
17378               dphi(j,1,i)=0.0d0
17379               dphi(j,2,i)=0.0d0
17380               dphi(j,3,i)=0.0d0
17381             enddo
17382             enddo
17383       ! Derivatives of theta's
17384 #if defined(MPI) && defined(PARINTDER)
17385       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17386             do i=max0(ithet_start-1,3),ithet_end
17387 #else
17388             do i=3,nres
17389 #endif
17390             cost=dcos(theta(i))
17391             sint=sqrt(1-cost*cost)
17392             do j=1,3
17393               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17394               vbld(i-1)
17395               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17396               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17397               vbld(i)
17398               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17399             enddo
17400             enddo
17401 #if defined(MPI) && defined(PARINTDER)
17402       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17403             do i=max0(ithet_start-1,3),ithet_end
17404 #else
17405             do i=3,nres
17406 #endif
17407             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17408             cost1=dcos(omicron(1,i))
17409             sint1=sqrt(1-cost1*cost1)
17410             cost2=dcos(omicron(2,i))
17411             sint2=sqrt(1-cost2*cost2)
17412              do j=1,3
17413       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17414               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17415               cost1*dc_norm(j,i-2))/ &
17416               vbld(i-1)
17417               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17418               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17419               +cost1*(dc_norm(j,i-1+nres)))/ &
17420               vbld(i-1+nres)
17421               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17422       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17423       !C Looks messy but better than if in loop
17424               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17425               +cost2*dc_norm(j,i-1))/ &
17426               vbld(i)
17427               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17428               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17429                +cost2*(-dc_norm(j,i-1+nres)))/ &
17430               vbld(i-1+nres)
17431       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17432               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17433             enddo
17434              endif
17435             enddo
17436       !elwrite(iout,*) "after vbld write"
17437       ! Derivatives of phi:
17438       ! If phi is 0 or 180 degrees, then the formulas
17439       ! have to be derived by power series expansion of the
17440       ! conventional formulas around 0 and 180.
17441 #ifdef PARINTDER
17442             do i=iphi1_start,iphi1_end
17443 #else
17444             do i=4,nres
17445 #endif
17446       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17447       ! the conventional case
17448             sint=dsin(theta(i))
17449             sint1=dsin(theta(i-1))
17450             sing=dsin(phi(i))
17451             cost=dcos(theta(i))
17452             cost1=dcos(theta(i-1))
17453             cosg=dcos(phi(i))
17454             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17455             fac0=1.0d0/(sint1*sint)
17456             fac1=cost*fac0
17457             fac2=cost1*fac0
17458             fac3=cosg*cost1/(sint1*sint1)
17459             fac4=cosg*cost/(sint*sint)
17460       !    Obtaining the gamma derivatives from sine derivative
17461              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17462                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17463                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17464              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17465              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17466              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17467              do j=1,3
17468                 ctgt=cost/sint
17469                 ctgt1=cost1/sint1
17470                 cosg_inv=1.0d0/cosg
17471                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17472                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17473                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17474                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17475                 dsinphi(j,2,i)= &
17476                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17477                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17478                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17479                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17480                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17481       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17482                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17483                 endif
17484       ! Bug fixed 3/24/05 (AL)
17485              enddo
17486       !   Obtaining the gamma derivatives from cosine derivative
17487             else
17488                do j=1,3
17489                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17490                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17491                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17492                dc_norm(j,i-3))/vbld(i-2)
17493                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17494                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17495                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17496                dcostheta(j,1,i)
17497                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17498                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17499                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17500                dc_norm(j,i-1))/vbld(i)
17501                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17502 !#define DEBUG
17503 #ifdef DEBUG
17504                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17505 #endif
17506 !#undef DEBUG
17507                endif
17508              enddo
17509             endif
17510             enddo
17511       !alculate derivative of Tauangle
17512 #ifdef PARINTDER
17513             do i=itau_start,itau_end
17514 #else
17515             do i=3,nres
17516       !elwrite(iout,*) " vecpr",i,nres
17517 #endif
17518              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17519       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17520       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17521       !c dtauangle(j,intertyp,dervityp,residue number)
17522       !c INTERTYP=1 SC...Ca...Ca..Ca
17523       ! the conventional case
17524             sint=dsin(theta(i))
17525             sint1=dsin(omicron(2,i-1))
17526             sing=dsin(tauangle(1,i))
17527             cost=dcos(theta(i))
17528             cost1=dcos(omicron(2,i-1))
17529             cosg=dcos(tauangle(1,i))
17530       !elwrite(iout,*) " vecpr5",i,nres
17531             do j=1,3
17532       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17533       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17534             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17535       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17536             enddo
17537             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17538             fac0=1.0d0/(sint1*sint)
17539             fac1=cost*fac0
17540             fac2=cost1*fac0
17541             fac3=cosg*cost1/(sint1*sint1)
17542             fac4=cosg*cost/(sint*sint)
17543       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17544       !    Obtaining the gamma derivatives from sine derivative
17545              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17546                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17547                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17548              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17549              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17550              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17551             do j=1,3
17552                 ctgt=cost/sint
17553                 ctgt1=cost1/sint1
17554                 cosg_inv=1.0d0/cosg
17555                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17556              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17557              *vbld_inv(i-2+nres)
17558                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17559                 dsintau(j,1,2,i)= &
17560                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17561                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17562       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17563                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17564       ! Bug fixed 3/24/05 (AL)
17565                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17566                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17567       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17568                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17569              enddo
17570       !   Obtaining the gamma derivatives from cosine derivative
17571             else
17572                do j=1,3
17573                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17574                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17575                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17576                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17577                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17578                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17579                dcostheta(j,1,i)
17580                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17581                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17582                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17583                dc_norm(j,i-1))/vbld(i)
17584                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17585       !         write (iout,*) "else",i
17586              enddo
17587             endif
17588       !        do k=1,3
17589       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17590       !        enddo
17591             enddo
17592       !C Second case Ca...Ca...Ca...SC
17593 #ifdef PARINTDER
17594             do i=itau_start,itau_end
17595 #else
17596             do i=4,nres
17597 #endif
17598              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17599               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17600       ! the conventional case
17601             sint=dsin(omicron(1,i))
17602             sint1=dsin(theta(i-1))
17603             sing=dsin(tauangle(2,i))
17604             cost=dcos(omicron(1,i))
17605             cost1=dcos(theta(i-1))
17606             cosg=dcos(tauangle(2,i))
17607       !        do j=1,3
17608       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17609       !        enddo
17610             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17611             fac0=1.0d0/(sint1*sint)
17612             fac1=cost*fac0
17613             fac2=cost1*fac0
17614             fac3=cosg*cost1/(sint1*sint1)
17615             fac4=cosg*cost/(sint*sint)
17616       !    Obtaining the gamma derivatives from sine derivative
17617              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17618                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17619                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17620              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17621              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17622              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17623             do j=1,3
17624                 ctgt=cost/sint
17625                 ctgt1=cost1/sint1
17626                 cosg_inv=1.0d0/cosg
17627                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17628                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17629       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17630       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17631                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17632                 dsintau(j,2,2,i)= &
17633                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17634                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17635       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17636       !     & sing*ctgt*domicron(j,1,2,i),
17637       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17638                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17639       ! Bug fixed 3/24/05 (AL)
17640                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17641                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17642       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17643                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17644              enddo
17645       !   Obtaining the gamma derivatives from cosine derivative
17646             else
17647                do j=1,3
17648                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17649                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17650                dc_norm(j,i-3))/vbld(i-2)
17651                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17652                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17653                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17654                dcosomicron(j,1,1,i)
17655                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17656                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17657                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17658                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17659                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17660       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17661              enddo
17662             endif
17663             enddo
17664
17665       !CC third case SC...Ca...Ca...SC
17666 #ifdef PARINTDER
17667
17668             do i=itau_start,itau_end
17669 #else
17670             do i=3,nres
17671 #endif
17672       ! the conventional case
17673             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17674             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17675             sint=dsin(omicron(1,i))
17676             sint1=dsin(omicron(2,i-1))
17677             sing=dsin(tauangle(3,i))
17678             cost=dcos(omicron(1,i))
17679             cost1=dcos(omicron(2,i-1))
17680             cosg=dcos(tauangle(3,i))
17681             do j=1,3
17682             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17683       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17684             enddo
17685             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17686             fac0=1.0d0/(sint1*sint)
17687             fac1=cost*fac0
17688             fac2=cost1*fac0
17689             fac3=cosg*cost1/(sint1*sint1)
17690             fac4=cosg*cost/(sint*sint)
17691       !    Obtaining the gamma derivatives from sine derivative
17692              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17693                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17694                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17695              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17696              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17697              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17698             do j=1,3
17699                 ctgt=cost/sint
17700                 ctgt1=cost1/sint1
17701                 cosg_inv=1.0d0/cosg
17702                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17703                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17704                   *vbld_inv(i-2+nres)
17705                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17706                 dsintau(j,3,2,i)= &
17707                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17708                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17709                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17710       ! Bug fixed 3/24/05 (AL)
17711                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17712                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17713                   *vbld_inv(i-1+nres)
17714       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17715                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17716              enddo
17717       !   Obtaining the gamma derivatives from cosine derivative
17718             else
17719                do j=1,3
17720                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17721                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17722                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17723                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17724                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17725                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17726                dcosomicron(j,1,1,i)
17727                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17728                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17729                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17730                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17731                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17732       !          write(iout,*) "else",i
17733              enddo
17734             endif
17735             enddo
17736
17737 #ifdef CRYST_SC
17738       !   Derivatives of side-chain angles alpha and omega
17739 #if defined(MPI) && defined(PARINTDER)
17740             do i=ibond_start,ibond_end
17741 #else
17742             do i=2,nres-1
17743 #endif
17744               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17745                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17746                  fac6=fac5/vbld(i)
17747                  fac7=fac5*fac5
17748                  fac8=fac5/vbld(i+1)
17749                  fac9=fac5/vbld(i+nres)
17750                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17751                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17752                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17753                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17754                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17755                  sina=sqrt(1-cosa*cosa)
17756                  sino=dsin(omeg(i))
17757       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17758                  do j=1,3
17759                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17760                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17761                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17762                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17763                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17764                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17765                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17766                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17767                   vbld(i+nres))
17768                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17769                 enddo
17770       ! obtaining the derivatives of omega from sines
17771                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17772                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17773                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17774                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17775                    dsin(theta(i+1)))
17776                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17777                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17778                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17779                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17780                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17781                    coso_inv=1.0d0/dcos(omeg(i))
17782                    do j=1,3
17783                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17784                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17785                    (sino*dc_norm(j,i-1))/vbld(i)
17786                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17787                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17788                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17789                    -sino*dc_norm(j,i)/vbld(i+1)
17790                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17791                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17792                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17793                    vbld(i+nres)
17794                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17795                   enddo
17796                else
17797       !   obtaining the derivatives of omega from cosines
17798                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17799                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17800                  fac12=fac10*sina
17801                  fac13=fac12*fac12
17802                  fac14=sina*sina
17803                  do j=1,3
17804                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17805                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17806                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17807                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17808                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17809                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17810                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17811                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17812                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17813                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17814                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17815                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17816                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17817                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17818                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17819                 enddo
17820               endif
17821              else
17822                do j=1,3
17823                  do k=1,3
17824                    dalpha(k,j,i)=0.0d0
17825                    domega(k,j,i)=0.0d0
17826                  enddo
17827                enddo
17828              endif
17829              enddo
17830 #endif
17831 #if defined(MPI) && defined(PARINTDER)
17832             if (nfgtasks.gt.1) then
17833 #ifdef DEBUG
17834       !d      write (iout,*) "Gather dtheta"
17835       !d      call flush(iout)
17836             write (iout,*) "dtheta before gather"
17837             do i=1,nres
17838             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17839             enddo
17840 #endif
17841             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17842             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17843             king,FG_COMM,IERROR)
17844 !#define DEBUG
17845 #ifdef DEBUG
17846       !d      write (iout,*) "Gather dphi"
17847       !d      call flush(iout)
17848             write (iout,*) "dphi before gather"
17849             do i=1,nres
17850             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17851             enddo
17852 #endif
17853 !#undef DEBUG
17854             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17855             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17856             king,FG_COMM,IERROR)
17857       !d      write (iout,*) "Gather dalpha"
17858       !d      call flush(iout)
17859 #ifdef CRYST_SC
17860             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17861             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17862             king,FG_COMM,IERROR)
17863       !d      write (iout,*) "Gather domega"
17864       !d      call flush(iout)
17865             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17866             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17867             king,FG_COMM,IERROR)
17868 #endif
17869             endif
17870 #endif
17871 !#define DEBUG
17872 #ifdef DEBUG
17873             write (iout,*) "dtheta after gather"
17874             do i=1,nres
17875             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17876             enddo
17877             write (iout,*) "dphi after gather"
17878             do i=1,nres
17879             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17880             enddo
17881             write (iout,*) "dalpha after gather"
17882             do i=1,nres
17883             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17884             enddo
17885             write (iout,*) "domega after gather"
17886             do i=1,nres
17887             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17888             enddo
17889 #endif
17890 !#undef DEBUG
17891             return
17892             end subroutine intcartderiv
17893       !-----------------------------------------------------------------------------
17894             subroutine checkintcartgrad
17895       !      implicit real*8 (a-h,o-z)
17896       !      include 'DIMENSIONS'
17897 #ifdef MPI
17898             include 'mpif.h'
17899 #endif
17900       !      include 'COMMON.CHAIN'
17901       !      include 'COMMON.VAR'
17902       !      include 'COMMON.GEO'
17903       !      include 'COMMON.INTERACT'
17904       !      include 'COMMON.DERIV'
17905       !      include 'COMMON.IOUNITS'
17906       !      include 'COMMON.SETUP'
17907             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17908             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17909             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17910             real(kind=8),dimension(3) :: dc_norm_s
17911             real(kind=8) :: aincr=1.0d-5
17912             integer :: i,j
17913             real(kind=8) :: dcji
17914             do i=1,nres
17915             phi_s(i)=phi(i)
17916             theta_s(i)=theta(i)
17917             alph_s(i)=alph(i)
17918             omeg_s(i)=omeg(i)
17919             enddo
17920       ! Check theta gradient
17921             write (iout,*) &
17922              "Analytical (upper) and numerical (lower) gradient of theta"
17923             write (iout,*)
17924             do i=3,nres
17925             do j=1,3
17926               dcji=dc(j,i-2)
17927               dc(j,i-2)=dcji+aincr
17928               call chainbuild_cart
17929               call int_from_cart1(.false.)
17930           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17931           dc(j,i-2)=dcji
17932           dcji=dc(j,i-1)
17933           dc(j,i-1)=dc(j,i-1)+aincr
17934           call chainbuild_cart
17935           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17936           dc(j,i-1)=dcji
17937         enddo
17938 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17939 !el          (dtheta(j,2,i),j=1,3)
17940 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17941 !el          (dthetanum(j,2,i),j=1,3)
17942 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17943 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17944 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17945 !el        write (iout,*)
17946       enddo
17947 ! Check gamma gradient
17948       write (iout,*) &
17949        "Analytical (upper) and numerical (lower) gradient of gamma"
17950       do i=4,nres
17951         do j=1,3
17952           dcji=dc(j,i-3)
17953           dc(j,i-3)=dcji+aincr
17954           call chainbuild_cart
17955           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17956               dc(j,i-3)=dcji
17957           dcji=dc(j,i-2)
17958           dc(j,i-2)=dcji+aincr
17959           call chainbuild_cart
17960           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17961           dc(j,i-2)=dcji
17962           dcji=dc(j,i-1)
17963           dc(j,i-1)=dc(j,i-1)+aincr
17964           call chainbuild_cart
17965           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17966           dc(j,i-1)=dcji
17967         enddo
17968 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17969 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17970 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17971 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17972 !el        write (iout,'(5x,3(3f10.5,5x))') &
17973 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17974 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17975 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17976 !el        write (iout,*)
17977       enddo
17978 ! Check alpha gradient
17979       write (iout,*) &
17980        "Analytical (upper) and numerical (lower) gradient of alpha"
17981       do i=2,nres-1
17982        if(itype(i,1).ne.10) then
17983                  do j=1,3
17984                   dcji=dc(j,i-1)
17985                    dc(j,i-1)=dcji+aincr
17986               call chainbuild_cart
17987               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17988                  /aincr
17989                   dc(j,i-1)=dcji
17990               dcji=dc(j,i)
17991               dc(j,i)=dcji+aincr
17992               call chainbuild_cart
17993               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17994                  /aincr
17995               dc(j,i)=dcji
17996               dcji=dc(j,i+nres)
17997               dc(j,i+nres)=dc(j,i+nres)+aincr
17998               call chainbuild_cart
17999               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18000                  /aincr
18001              dc(j,i+nres)=dcji
18002             enddo
18003           endif
18004 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18005 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18006 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18007 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18008 !el        write (iout,'(5x,3(3f10.5,5x))') &
18009 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18010 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18011 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18012 !el        write (iout,*)
18013       enddo
18014 !     Check omega gradient
18015       write (iout,*) &
18016        "Analytical (upper) and numerical (lower) gradient of omega"
18017       do i=2,nres-1
18018        if(itype(i,1).ne.10) then
18019                  do j=1,3
18020                   dcji=dc(j,i-1)
18021                    dc(j,i-1)=dcji+aincr
18022               call chainbuild_cart
18023               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18024                  /aincr
18025                   dc(j,i-1)=dcji
18026               dcji=dc(j,i)
18027               dc(j,i)=dcji+aincr
18028               call chainbuild_cart
18029               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18030                  /aincr
18031               dc(j,i)=dcji
18032               dcji=dc(j,i+nres)
18033               dc(j,i+nres)=dc(j,i+nres)+aincr
18034               call chainbuild_cart
18035               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18036                  /aincr
18037              dc(j,i+nres)=dcji
18038             enddo
18039           endif
18040 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18041 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18042 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18043 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18044 !el        write (iout,'(5x,3(3f10.5,5x))') &
18045 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18046 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18047 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18048 !el        write (iout,*)
18049       enddo
18050       return
18051       end subroutine checkintcartgrad
18052 !-----------------------------------------------------------------------------
18053 ! q_measure.F
18054 !-----------------------------------------------------------------------------
18055       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18056 !      implicit real*8 (a-h,o-z)
18057 !      include 'DIMENSIONS'
18058 !      include 'COMMON.IOUNITS'
18059 !      include 'COMMON.CHAIN'
18060 !      include 'COMMON.INTERACT'
18061 !      include 'COMMON.VAR'
18062       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18063       integer :: kkk,nsep=3
18064       real(kind=8) :: qm      !dist,
18065       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18066       logical :: lprn=.false.
18067       logical :: flag
18068 !      real(kind=8) :: sigm,x
18069
18070 !el      sigm(x)=0.25d0*x     ! local function
18071       qqmax=1.0d10
18072       do kkk=1,nperm
18073       qq = 0.0d0
18074       nl=0
18075        if(flag) then
18076         do il=seg1+nsep,seg2
18077           do jl=seg1,il-nsep
18078             nl=nl+1
18079             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18080                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18081                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18082             dij=dist(il,jl)
18083             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18084             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18085               nl=nl+1
18086               d0ijCM=dsqrt( &
18087                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18088                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18089                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18090               dijCM=dist(il+nres,jl+nres)
18091               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18092             endif
18093             qq = qq+qqij+qqijCM
18094           enddo
18095         enddo
18096         qq = qq/nl
18097       else
18098       do il=seg1,seg2
18099         if((seg3-il).lt.3) then
18100              secseg=il+3
18101         else
18102              secseg=seg3
18103         endif
18104           do jl=secseg,seg4
18105             nl=nl+1
18106             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18107                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18108                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18109             dij=dist(il,jl)
18110             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18111             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18112               nl=nl+1
18113               d0ijCM=dsqrt( &
18114                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18115                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18116                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18117               dijCM=dist(il+nres,jl+nres)
18118               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18119             endif
18120             qq = qq+qqij+qqijCM
18121           enddo
18122         enddo
18123       qq = qq/nl
18124       endif
18125       if (qqmax.le.qq) qqmax=qq
18126       enddo
18127       qwolynes=1.0d0-qqmax
18128       return
18129       end function qwolynes
18130 !-----------------------------------------------------------------------------
18131       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18132 !      implicit real*8 (a-h,o-z)
18133 !      include 'DIMENSIONS'
18134 !      include 'COMMON.IOUNITS'
18135 !      include 'COMMON.CHAIN'
18136 !      include 'COMMON.INTERACT'
18137 !      include 'COMMON.VAR'
18138 !      include 'COMMON.MD'
18139       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18140       integer :: nsep=3, kkk
18141 !el      real(kind=8) :: dist
18142       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18143       logical :: lprn=.false.
18144       logical :: flag
18145       real(kind=8) :: sim,dd0,fac,ddqij
18146 !el      sigm(x)=0.25d0*x           ! local function
18147       do kkk=1,nperm
18148       do i=0,nres
18149         do j=1,3
18150           dqwol(j,i)=0.0d0
18151           dxqwol(j,i)=0.0d0
18152         enddo
18153       enddo
18154       nl=0
18155        if(flag) then
18156         do il=seg1+nsep,seg2
18157           do jl=seg1,il-nsep
18158             nl=nl+1
18159             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18160                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18161                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18162             dij=dist(il,jl)
18163             sim = 1.0d0/sigm(d0ij)
18164             sim = sim*sim
18165             dd0 = dij-d0ij
18166             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18167           do k=1,3
18168               ddqij = (c(k,il)-c(k,jl))*fac
18169               dqwol(k,il)=dqwol(k,il)+ddqij
18170               dqwol(k,jl)=dqwol(k,jl)-ddqij
18171             enddo
18172
18173             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18174               nl=nl+1
18175               d0ijCM=dsqrt( &
18176                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18177                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18178                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18179               dijCM=dist(il+nres,jl+nres)
18180               sim = 1.0d0/sigm(d0ijCM)
18181               sim = sim*sim
18182               dd0=dijCM-d0ijCM
18183               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18184               do k=1,3
18185                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18186                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18187                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18188               enddo
18189             endif
18190           enddo
18191         enddo
18192        else
18193         do il=seg1,seg2
18194         if((seg3-il).lt.3) then
18195              secseg=il+3
18196         else
18197              secseg=seg3
18198         endif
18199           do jl=secseg,seg4
18200             nl=nl+1
18201             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18202                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18203                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18204             dij=dist(il,jl)
18205             sim = 1.0d0/sigm(d0ij)
18206             sim = sim*sim
18207             dd0 = dij-d0ij
18208             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18209             do k=1,3
18210               ddqij = (c(k,il)-c(k,jl))*fac
18211               dqwol(k,il)=dqwol(k,il)+ddqij
18212               dqwol(k,jl)=dqwol(k,jl)-ddqij
18213             enddo
18214             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18215               nl=nl+1
18216               d0ijCM=dsqrt( &
18217                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18218                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18219                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18220               dijCM=dist(il+nres,jl+nres)
18221               sim = 1.0d0/sigm(d0ijCM)
18222               sim=sim*sim
18223               dd0 = dijCM-d0ijCM
18224               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18225               do k=1,3
18226                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18227                dxqwol(k,il)=dxqwol(k,il)+ddqij
18228                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18229               enddo
18230             endif
18231           enddo
18232         enddo
18233       endif
18234       enddo
18235        do i=0,nres
18236          do j=1,3
18237            dqwol(j,i)=dqwol(j,i)/nl
18238            dxqwol(j,i)=dxqwol(j,i)/nl
18239          enddo
18240        enddo
18241       return
18242       end subroutine qwolynes_prim
18243 !-----------------------------------------------------------------------------
18244       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18245 !      implicit real*8 (a-h,o-z)
18246 !      include 'DIMENSIONS'
18247 !      include 'COMMON.IOUNITS'
18248 !      include 'COMMON.CHAIN'
18249 !      include 'COMMON.INTERACT'
18250 !      include 'COMMON.VAR'
18251       integer :: seg1,seg2,seg3,seg4
18252       logical :: flag
18253       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18254       real(kind=8),dimension(3,0:2*nres) :: cdummy
18255       real(kind=8) :: q1,q2
18256       real(kind=8) :: delta=1.0d-10
18257       integer :: i,j
18258
18259       do i=0,nres
18260         do j=1,3
18261           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18262           cdummy(j,i)=c(j,i)
18263           c(j,i)=c(j,i)+delta
18264           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18265           qwolan(j,i)=(q2-q1)/delta
18266           c(j,i)=cdummy(j,i)
18267         enddo
18268       enddo
18269       do i=0,nres
18270         do j=1,3
18271           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18272           cdummy(j,i+nres)=c(j,i+nres)
18273           c(j,i+nres)=c(j,i+nres)+delta
18274           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18275           qwolxan(j,i)=(q2-q1)/delta
18276           c(j,i+nres)=cdummy(j,i+nres)
18277         enddo
18278       enddo
18279 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18280 !      do i=0,nct
18281 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18282 !      enddo
18283 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18284 !      do i=0,nct
18285 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18286 !      enddo
18287       return
18288       end subroutine qwol_num
18289 !-----------------------------------------------------------------------------
18290       subroutine EconstrQ
18291 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18292 !      implicit real*8 (a-h,o-z)
18293 !      include 'DIMENSIONS'
18294 !      include 'COMMON.CONTROL'
18295 !      include 'COMMON.VAR'
18296 !      include 'COMMON.MD'
18297       use MD_data
18298 !#ifndef LANG0
18299 !      include 'COMMON.LANGEVIN'
18300 !#else
18301 !      include 'COMMON.LANGEVIN.lang0'
18302 !#endif
18303 !      include 'COMMON.CHAIN'
18304 !      include 'COMMON.DERIV'
18305 !      include 'COMMON.GEO'
18306 !      include 'COMMON.LOCAL'
18307 !      include 'COMMON.INTERACT'
18308 !      include 'COMMON.IOUNITS'
18309 !      include 'COMMON.NAMES'
18310 !      include 'COMMON.TIME1'
18311       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18312       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18313                    duconst,duxconst
18314       integer :: kstart,kend,lstart,lend,idummy
18315       real(kind=8) :: delta=1.0d-7
18316       integer :: i,j,k,ii
18317       do i=0,nres
18318          do j=1,3
18319             duconst(j,i)=0.0d0
18320             dudconst(j,i)=0.0d0
18321             duxconst(j,i)=0.0d0
18322             dudxconst(j,i)=0.0d0
18323          enddo
18324       enddo
18325       Uconst=0.0d0
18326       do i=1,nfrag
18327          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18328            idummy,idummy)
18329          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18330 ! Calculating the derivatives of Constraint energy with respect to Q
18331          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18332            qinfrag(i,iset))
18333 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18334 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18335 !         hmnum=(hm2-hm1)/delta
18336 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18337 !     &   qinfrag(i,iset))
18338 !         write(iout,*) "harmonicnum frag", hmnum
18339 ! Calculating the derivatives of Q with respect to cartesian coordinates
18340          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18341           idummy,idummy)
18342 !         write(iout,*) "dqwol "
18343 !         do ii=1,nres
18344 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18345 !         enddo
18346 !         write(iout,*) "dxqwol "
18347 !         do ii=1,nres
18348 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18349 !         enddo
18350 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18351 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18352 !     &  ,idummy,idummy)
18353 !  The gradients of Uconst in Cs
18354          do ii=0,nres
18355             do j=1,3
18356                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18357                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18358             enddo
18359          enddo
18360       enddo
18361       do i=1,npair
18362          kstart=ifrag(1,ipair(1,i,iset),iset)
18363          kend=ifrag(2,ipair(1,i,iset),iset)
18364          lstart=ifrag(1,ipair(2,i,iset),iset)
18365          lend=ifrag(2,ipair(2,i,iset),iset)
18366          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18367          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18368 !  Calculating dU/dQ
18369          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18370 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18371 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18372 !         hmnum=(hm2-hm1)/delta
18373 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18374 !     &   qinpair(i,iset))
18375 !         write(iout,*) "harmonicnum pair ", hmnum
18376 ! Calculating dQ/dXi
18377          call qwolynes_prim(kstart,kend,.false.,&
18378           lstart,lend)
18379 !         write(iout,*) "dqwol "
18380 !         do ii=1,nres
18381 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18382 !         enddo
18383 !         write(iout,*) "dxqwol "
18384 !         do ii=1,nres
18385 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18386 !        enddo
18387 ! Calculating numerical gradients
18388 !        call qwol_num(kstart,kend,.false.
18389 !     &  ,lstart,lend)
18390 ! The gradients of Uconst in Cs
18391          do ii=0,nres
18392             do j=1,3
18393                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18394                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18395             enddo
18396          enddo
18397       enddo
18398 !      write(iout,*) "Uconst inside subroutine ", Uconst
18399 ! Transforming the gradients from Cs to dCs for the backbone
18400       do i=0,nres
18401          do j=i+1,nres
18402            do k=1,3
18403              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18404            enddo
18405          enddo
18406       enddo
18407 !  Transforming the gradients from Cs to dCs for the side chains
18408       do i=1,nres
18409          do j=1,3
18410            dudxconst(j,i)=duxconst(j,i)
18411          enddo
18412       enddo
18413 !      write(iout,*) "dU/ddc backbone "
18414 !       do ii=0,nres
18415 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18416 !      enddo
18417 !      write(iout,*) "dU/ddX side chain "
18418 !      do ii=1,nres
18419 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18420 !      enddo
18421 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18422 !      call dEconstrQ_num
18423       return
18424       end subroutine EconstrQ
18425 !-----------------------------------------------------------------------------
18426       subroutine dEconstrQ_num
18427 ! Calculating numerical dUconst/ddc and dUconst/ddx
18428 !      implicit real*8 (a-h,o-z)
18429 !      include 'DIMENSIONS'
18430 !      include 'COMMON.CONTROL'
18431 !      include 'COMMON.VAR'
18432 !      include 'COMMON.MD'
18433       use MD_data
18434 !#ifndef LANG0
18435 !      include 'COMMON.LANGEVIN'
18436 !#else
18437 !      include 'COMMON.LANGEVIN.lang0'
18438 !#endif
18439 !      include 'COMMON.CHAIN'
18440 !      include 'COMMON.DERIV'
18441 !      include 'COMMON.GEO'
18442 !      include 'COMMON.LOCAL'
18443 !      include 'COMMON.INTERACT'
18444 !      include 'COMMON.IOUNITS'
18445 !      include 'COMMON.NAMES'
18446 !      include 'COMMON.TIME1'
18447       real(kind=8) :: uzap1,uzap2
18448       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18449       integer :: kstart,kend,lstart,lend,idummy
18450       real(kind=8) :: delta=1.0d-7
18451 !el local variables
18452       integer :: i,ii,j
18453 !     real(kind=8) ::
18454 !     For the backbone
18455       do i=0,nres-1
18456          do j=1,3
18457             dUcartan(j,i)=0.0d0
18458             cdummy(j,i)=dc(j,i)
18459             dc(j,i)=dc(j,i)+delta
18460             call chainbuild_cart
18461           uzap2=0.0d0
18462             do ii=1,nfrag
18463              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18464                 idummy,idummy)
18465                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18466                 qinfrag(ii,iset))
18467             enddo
18468             do ii=1,npair
18469                kstart=ifrag(1,ipair(1,ii,iset),iset)
18470                kend=ifrag(2,ipair(1,ii,iset),iset)
18471                lstart=ifrag(1,ipair(2,ii,iset),iset)
18472                lend=ifrag(2,ipair(2,ii,iset),iset)
18473                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18474                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18475                  qinpair(ii,iset))
18476             enddo
18477             dc(j,i)=cdummy(j,i)
18478             call chainbuild_cart
18479             uzap1=0.0d0
18480              do ii=1,nfrag
18481              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18482                 idummy,idummy)
18483                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18484                 qinfrag(ii,iset))
18485             enddo
18486             do ii=1,npair
18487                kstart=ifrag(1,ipair(1,ii,iset),iset)
18488                kend=ifrag(2,ipair(1,ii,iset),iset)
18489                lstart=ifrag(1,ipair(2,ii,iset),iset)
18490                lend=ifrag(2,ipair(2,ii,iset),iset)
18491                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18492                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18493                 qinpair(ii,iset))
18494             enddo
18495             ducartan(j,i)=(uzap2-uzap1)/(delta)
18496          enddo
18497       enddo
18498 ! Calculating numerical gradients for dU/ddx
18499       do i=0,nres-1
18500          duxcartan(j,i)=0.0d0
18501          do j=1,3
18502             cdummy(j,i)=dc(j,i+nres)
18503             dc(j,i+nres)=dc(j,i+nres)+delta
18504             call chainbuild_cart
18505           uzap2=0.0d0
18506             do ii=1,nfrag
18507              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18508                 idummy,idummy)
18509                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18510                 qinfrag(ii,iset))
18511             enddo
18512             do ii=1,npair
18513                kstart=ifrag(1,ipair(1,ii,iset),iset)
18514                kend=ifrag(2,ipair(1,ii,iset),iset)
18515                lstart=ifrag(1,ipair(2,ii,iset),iset)
18516                lend=ifrag(2,ipair(2,ii,iset),iset)
18517                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18518                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18519                 qinpair(ii,iset))
18520             enddo
18521             dc(j,i+nres)=cdummy(j,i)
18522             call chainbuild_cart
18523             uzap1=0.0d0
18524              do ii=1,nfrag
18525                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18526                 ifrag(2,ii,iset),.true.,idummy,idummy)
18527                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18528                 qinfrag(ii,iset))
18529             enddo
18530             do ii=1,npair
18531                kstart=ifrag(1,ipair(1,ii,iset),iset)
18532                kend=ifrag(2,ipair(1,ii,iset),iset)
18533                lstart=ifrag(1,ipair(2,ii,iset),iset)
18534                lend=ifrag(2,ipair(2,ii,iset),iset)
18535                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18536                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18537                 qinpair(ii,iset))
18538             enddo
18539             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18540          enddo
18541       enddo
18542       write(iout,*) "Numerical dUconst/ddc backbone "
18543       do ii=0,nres
18544         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18545       enddo
18546 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18547 !      do ii=1,nres
18548 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18549 !      enddo
18550       return
18551       end subroutine dEconstrQ_num
18552 !-----------------------------------------------------------------------------
18553 ! ssMD.F
18554 !-----------------------------------------------------------------------------
18555       subroutine check_energies
18556
18557 !      use random, only: ran_number
18558
18559 !      implicit none
18560 !     Includes
18561 !      include 'DIMENSIONS'
18562 !      include 'COMMON.CHAIN'
18563 !      include 'COMMON.VAR'
18564 !      include 'COMMON.IOUNITS'
18565 !      include 'COMMON.SBRIDGE'
18566 !      include 'COMMON.LOCAL'
18567 !      include 'COMMON.GEO'
18568
18569 !     External functions
18570 !EL      double precision ran_number
18571 !EL      external ran_number
18572
18573 !     Local variables
18574       integer :: i,j,k,l,lmax,p,pmax
18575       real(kind=8) :: rmin,rmax
18576       real(kind=8) :: eij
18577
18578       real(kind=8) :: d
18579       real(kind=8) :: wi,rij,tj,pj
18580 !      return
18581
18582       i=5
18583       j=14
18584
18585       d=dsc(1)
18586       rmin=2.0D0
18587       rmax=12.0D0
18588
18589       lmax=10000
18590       pmax=1
18591
18592       do k=1,3
18593         c(k,i)=0.0D0
18594         c(k,j)=0.0D0
18595         c(k,nres+i)=0.0D0
18596         c(k,nres+j)=0.0D0
18597       enddo
18598
18599       do l=1,lmax
18600
18601 !t        wi=ran_number(0.0D0,pi)
18602 !        wi=ran_number(0.0D0,pi/6.0D0)
18603 !        wi=0.0D0
18604 !t        tj=ran_number(0.0D0,pi)
18605 !t        pj=ran_number(0.0D0,pi)
18606 !        pj=ran_number(0.0D0,pi/6.0D0)
18607 !        pj=0.0D0
18608
18609         do p=1,pmax
18610 !t           rij=ran_number(rmin,rmax)
18611
18612            c(1,j)=d*sin(pj)*cos(tj)
18613            c(2,j)=d*sin(pj)*sin(tj)
18614            c(3,j)=d*cos(pj)
18615
18616            c(3,nres+i)=-rij
18617
18618            c(1,i)=d*sin(wi)
18619            c(3,i)=-rij-d*cos(wi)
18620
18621            do k=1,3
18622               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18623               dc_norm(k,nres+i)=dc(k,nres+i)/d
18624               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18625               dc_norm(k,nres+j)=dc(k,nres+j)/d
18626            enddo
18627
18628            call dyn_ssbond_ene(i,j,eij)
18629         enddo
18630       enddo
18631       call exit(1)
18632       return
18633       end subroutine check_energies
18634 !-----------------------------------------------------------------------------
18635       subroutine dyn_ssbond_ene(resi,resj,eij)
18636 !      implicit none
18637 !      Includes
18638       use calc_data
18639       use comm_sschecks
18640 !      include 'DIMENSIONS'
18641 !      include 'COMMON.SBRIDGE'
18642 !      include 'COMMON.CHAIN'
18643 !      include 'COMMON.DERIV'
18644 !      include 'COMMON.LOCAL'
18645 !      include 'COMMON.INTERACT'
18646 !      include 'COMMON.VAR'
18647 !      include 'COMMON.IOUNITS'
18648 !      include 'COMMON.CALC'
18649 #ifndef CLUST
18650 #ifndef WHAM
18651        use MD_data
18652 !      include 'COMMON.MD'
18653 !      use MD, only: totT,t_bath
18654 #endif
18655 #endif
18656 !     External functions
18657 !EL      double precision h_base
18658 !EL      external h_base
18659
18660 !     Input arguments
18661       integer :: resi,resj
18662
18663 !     Output arguments
18664       real(kind=8) :: eij
18665
18666 !     Local variables
18667       logical :: havebond
18668       integer itypi,itypj
18669       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18670       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18671       real(kind=8),dimension(3) :: dcosom1,dcosom2
18672       real(kind=8) :: ed
18673       real(kind=8) :: pom1,pom2
18674       real(kind=8) :: ljA,ljB,ljXs
18675       real(kind=8),dimension(1:3) :: d_ljB
18676       real(kind=8) :: ssA,ssB,ssC,ssXs
18677       real(kind=8) :: ssxm,ljxm,ssm,ljm
18678       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18679       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18680       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18681 !-------FIRST METHOD
18682       real(kind=8) :: xm
18683       real(kind=8),dimension(1:3) :: d_xm
18684 !-------END FIRST METHOD
18685 !-------SECOND METHOD
18686 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18687 !-------END SECOND METHOD
18688
18689 !-------TESTING CODE
18690 !el      logical :: checkstop,transgrad
18691 !el      common /sschecks/ checkstop,transgrad
18692
18693       integer :: icheck,nicheck,jcheck,njcheck
18694       real(kind=8),dimension(-1:1) :: echeck
18695       real(kind=8) :: deps,ssx0,ljx0
18696 !-------END TESTING CODE
18697
18698       eij=0.0d0
18699       i=resi
18700       j=resj
18701
18702 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18703 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18704
18705       itypi=itype(i,1)
18706       dxi=dc_norm(1,nres+i)
18707       dyi=dc_norm(2,nres+i)
18708       dzi=dc_norm(3,nres+i)
18709       dsci_inv=vbld_inv(i+nres)
18710
18711       itypj=itype(j,1)
18712       xj=c(1,nres+j)-c(1,nres+i)
18713       yj=c(2,nres+j)-c(2,nres+i)
18714       zj=c(3,nres+j)-c(3,nres+i)
18715       dxj=dc_norm(1,nres+j)
18716       dyj=dc_norm(2,nres+j)
18717       dzj=dc_norm(3,nres+j)
18718       dscj_inv=vbld_inv(j+nres)
18719
18720       chi1=chi(itypi,itypj)
18721       chi2=chi(itypj,itypi)
18722       chi12=chi1*chi2
18723       chip1=chip(itypi)
18724       chip2=chip(itypj)
18725       chip12=chip1*chip2
18726       alf1=alp(itypi)
18727       alf2=alp(itypj)
18728       alf12=0.5D0*(alf1+alf2)
18729
18730       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18731       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18732 !     The following are set in sc_angular
18733 !      erij(1)=xj*rij
18734 !      erij(2)=yj*rij
18735 !      erij(3)=zj*rij
18736 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18737 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18738 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18739       call sc_angular
18740       rij=1.0D0/rij  ! Reset this so it makes sense
18741
18742       sig0ij=sigma(itypi,itypj)
18743       sig=sig0ij*dsqrt(1.0D0/sigsq)
18744
18745       ljXs=sig-sig0ij
18746       ljA=eps1*eps2rt**2*eps3rt**2
18747       ljB=ljA*bb_aq(itypi,itypj)
18748       ljA=ljA*aa_aq(itypi,itypj)
18749       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18750
18751       ssXs=d0cm
18752       deltat1=1.0d0-om1
18753       deltat2=1.0d0+om2
18754       deltat12=om2-om1+2.0d0
18755       cosphi=om12-om1*om2
18756       ssA=akcm
18757       ssB=akct*deltat12
18758       ssC=ss_depth &
18759            +akth*(deltat1*deltat1+deltat2*deltat2) &
18760            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18761       ssxm=ssXs-0.5D0*ssB/ssA
18762
18763 !-------TESTING CODE
18764 !$$$c     Some extra output
18765 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18766 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18767 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18768 !$$$      if (ssx0.gt.0.0d0) then
18769 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18770 !$$$      else
18771 !$$$        ssx0=ssxm
18772 !$$$      endif
18773 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18774 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18775 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18776 !$$$      return
18777 !-------END TESTING CODE
18778
18779 !-------TESTING CODE
18780 !     Stop and plot energy and derivative as a function of distance
18781       if (checkstop) then
18782         ssm=ssC-0.25D0*ssB*ssB/ssA
18783         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18784         if (ssm.lt.ljm .and. &
18785              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18786           nicheck=1000
18787           njcheck=1
18788           deps=0.5d-7
18789         else
18790           checkstop=.false.
18791         endif
18792       endif
18793       if (.not.checkstop) then
18794         nicheck=0
18795         njcheck=-1
18796       endif
18797
18798       do icheck=0,nicheck
18799       do jcheck=-1,njcheck
18800       if (checkstop) rij=(ssxm-1.0d0)+ &
18801              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18802 !-------END TESTING CODE
18803
18804       if (rij.gt.ljxm) then
18805         havebond=.false.
18806         ljd=rij-ljXs
18807         fac=(1.0D0/ljd)**expon
18808         e1=fac*fac*aa_aq(itypi,itypj)
18809         e2=fac*bb_aq(itypi,itypj)
18810         eij=eps1*eps2rt*eps3rt*(e1+e2)
18811         eps2der=eij*eps3rt
18812         eps3der=eij*eps2rt
18813         eij=eij*eps2rt*eps3rt
18814
18815         sigder=-sig/sigsq
18816         e1=e1*eps1*eps2rt**2*eps3rt**2
18817         ed=-expon*(e1+eij)/ljd
18818         sigder=ed*sigder
18819         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18820         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18821         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18822              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18823       else if (rij.lt.ssxm) then
18824         havebond=.true.
18825         ssd=rij-ssXs
18826         eij=ssA*ssd*ssd+ssB*ssd+ssC
18827
18828         ed=2*akcm*ssd+akct*deltat12
18829         pom1=akct*ssd
18830         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18831         eom1=-2*akth*deltat1-pom1-om2*pom2
18832         eom2= 2*akth*deltat2+pom1-om1*pom2
18833         eom12=pom2
18834       else
18835         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18836
18837         d_ssxm(1)=0.5D0*akct/ssA
18838         d_ssxm(2)=-d_ssxm(1)
18839         d_ssxm(3)=0.0D0
18840
18841         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18842         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18843         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18844         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18845
18846 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18847         xm=0.5d0*(ssxm+ljxm)
18848         do k=1,3
18849           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18850         enddo
18851         if (rij.lt.xm) then
18852           havebond=.true.
18853           ssm=ssC-0.25D0*ssB*ssB/ssA
18854           d_ssm(1)=0.5D0*akct*ssB/ssA
18855           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18856           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18857           d_ssm(3)=omega
18858           f1=(rij-xm)/(ssxm-xm)
18859           f2=(rij-ssxm)/(xm-ssxm)
18860           h1=h_base(f1,hd1)
18861           h2=h_base(f2,hd2)
18862           eij=ssm*h1+Ht*h2
18863           delta_inv=1.0d0/(xm-ssxm)
18864           deltasq_inv=delta_inv*delta_inv
18865           fac=ssm*hd1-Ht*hd2
18866           fac1=deltasq_inv*fac*(xm-rij)
18867           fac2=deltasq_inv*fac*(rij-ssxm)
18868           ed=delta_inv*(Ht*hd2-ssm*hd1)
18869           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18870           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18871           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18872         else
18873           havebond=.false.
18874           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18875           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18876           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18877           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18878                alf12/eps3rt)
18879           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18880           f1=(rij-ljxm)/(xm-ljxm)
18881           f2=(rij-xm)/(ljxm-xm)
18882           h1=h_base(f1,hd1)
18883           h2=h_base(f2,hd2)
18884           eij=Ht*h1+ljm*h2
18885           delta_inv=1.0d0/(ljxm-xm)
18886           deltasq_inv=delta_inv*delta_inv
18887           fac=Ht*hd1-ljm*hd2
18888           fac1=deltasq_inv*fac*(ljxm-rij)
18889           fac2=deltasq_inv*fac*(rij-xm)
18890           ed=delta_inv*(ljm*hd2-Ht*hd1)
18891           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18892           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18893           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18894         endif
18895 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18896
18897 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18898 !$$$        ssd=rij-ssXs
18899 !$$$        ljd=rij-ljXs
18900 !$$$        fac1=rij-ljxm
18901 !$$$        fac2=rij-ssxm
18902 !$$$
18903 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18904 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18905 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18906 !$$$
18907 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18908 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18909 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18910 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18911 !$$$        d_ssm(3)=omega
18912 !$$$
18913 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18914 !$$$        do k=1,3
18915 !$$$          d_ljm(k)=ljm*d_ljB(k)
18916 !$$$        enddo
18917 !$$$        ljm=ljm*ljB
18918 !$$$
18919 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18920 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18921 !$$$        d_ss(2)=akct*ssd
18922 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18923 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18924 !$$$        d_ss(3)=omega
18925 !$$$
18926 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18927 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18928 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18929 !$$$        do k=1,3
18930 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18931 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18932 !$$$        enddo
18933 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18934 !$$$
18935 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18936 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18937 !$$$        h1=h_base(f1,hd1)
18938 !$$$        h2=h_base(f2,hd2)
18939 !$$$        eij=ss*h1+ljf*h2
18940 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18941 !$$$        deltasq_inv=delta_inv*delta_inv
18942 !$$$        fac=ljf*hd2-ss*hd1
18943 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18944 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18945 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18946 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18947 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18948 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18949 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18950 !$$$
18951 !$$$        havebond=.false.
18952 !$$$        if (ed.gt.0.0d0) havebond=.true.
18953 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18954
18955       endif
18956
18957       if (havebond) then
18958 !#ifndef CLUST
18959 !#ifndef WHAM
18960 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18961 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18962 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18963 !        endif
18964 !#endif
18965 !#endif
18966         dyn_ssbond_ij(i,j)=eij
18967       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18968         dyn_ssbond_ij(i,j)=1.0d300
18969 !#ifndef CLUST
18970 !#ifndef WHAM
18971 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18972 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18973 !#endif
18974 !#endif
18975       endif
18976
18977 !-------TESTING CODE
18978 !el      if (checkstop) then
18979         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18980              "CHECKSTOP",rij,eij,ed
18981         echeck(jcheck)=eij
18982 !el      endif
18983       enddo
18984       if (checkstop) then
18985         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18986       endif
18987       enddo
18988       if (checkstop) then
18989         transgrad=.true.
18990         checkstop=.false.
18991       endif
18992 !-------END TESTING CODE
18993
18994       do k=1,3
18995         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18996         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18997       enddo
18998       do k=1,3
18999         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19000       enddo
19001       do k=1,3
19002         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19003              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19004              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19005         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19006              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19007              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19008       enddo
19009 !grad      do k=i,j-1
19010 !grad        do l=1,3
19011 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19012 !grad        enddo
19013 !grad      enddo
19014
19015       do l=1,3
19016         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19017         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19018       enddo
19019
19020       return
19021       end subroutine dyn_ssbond_ene
19022 !--------------------------------------------------------------------------
19023          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19024 !      implicit none
19025 !      Includes
19026       use calc_data
19027       use comm_sschecks
19028 !      include 'DIMENSIONS'
19029 !      include 'COMMON.SBRIDGE'
19030 !      include 'COMMON.CHAIN'
19031 !      include 'COMMON.DERIV'
19032 !      include 'COMMON.LOCAL'
19033 !      include 'COMMON.INTERACT'
19034 !      include 'COMMON.VAR'
19035 !      include 'COMMON.IOUNITS'
19036 !      include 'COMMON.CALC'
19037 #ifndef CLUST
19038 #ifndef WHAM
19039        use MD_data
19040 !      include 'COMMON.MD'
19041 !      use MD, only: totT,t_bath
19042 #endif
19043 #endif
19044       double precision h_base
19045       external h_base
19046
19047 !c     Input arguments
19048       integer resi,resj,resk,m,itypi,itypj,itypk
19049
19050 !c     Output arguments
19051       double precision eij,eij1,eij2,eij3
19052
19053 !c     Local variables
19054       logical havebond
19055 !c      integer itypi,itypj,k,l
19056       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19057       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19058       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19059       double precision sig0ij,ljd,sig,fac,e1,e2
19060       double precision dcosom1(3),dcosom2(3),ed
19061       double precision pom1,pom2
19062       double precision ljA,ljB,ljXs
19063       double precision d_ljB(1:3)
19064       double precision ssA,ssB,ssC,ssXs
19065       double precision ssxm,ljxm,ssm,ljm
19066       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19067       eij=0.0
19068       if (dtriss.eq.0) return
19069       i=resi
19070       j=resj
19071       k=resk
19072 !C      write(iout,*) resi,resj,resk
19073       itypi=itype(i,1)
19074       dxi=dc_norm(1,nres+i)
19075       dyi=dc_norm(2,nres+i)
19076       dzi=dc_norm(3,nres+i)
19077       dsci_inv=vbld_inv(i+nres)
19078       xi=c(1,nres+i)
19079       yi=c(2,nres+i)
19080       zi=c(3,nres+i)
19081       itypj=itype(j,1)
19082       xj=c(1,nres+j)
19083       yj=c(2,nres+j)
19084       zj=c(3,nres+j)
19085
19086       dxj=dc_norm(1,nres+j)
19087       dyj=dc_norm(2,nres+j)
19088       dzj=dc_norm(3,nres+j)
19089       dscj_inv=vbld_inv(j+nres)
19090       itypk=itype(k,1)
19091       xk=c(1,nres+k)
19092       yk=c(2,nres+k)
19093       zk=c(3,nres+k)
19094
19095       dxk=dc_norm(1,nres+k)
19096       dyk=dc_norm(2,nres+k)
19097       dzk=dc_norm(3,nres+k)
19098       dscj_inv=vbld_inv(k+nres)
19099       xij=xj-xi
19100       xik=xk-xi
19101       xjk=xk-xj
19102       yij=yj-yi
19103       yik=yk-yi
19104       yjk=yk-yj
19105       zij=zj-zi
19106       zik=zk-zi
19107       zjk=zk-zj
19108       rrij=(xij*xij+yij*yij+zij*zij)
19109       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19110       rrik=(xik*xik+yik*yik+zik*zik)
19111       rik=dsqrt(rrik)
19112       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19113       rjk=dsqrt(rrjk)
19114 !C there are three combination of distances for each trisulfide bonds
19115 !C The first case the ith atom is the center
19116 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19117 !C distance y is second distance the a,b,c,d are parameters derived for
19118 !C this problem d parameter was set as a penalty currenlty set to 1.
19119       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19120       eij1=0.0d0
19121       else
19122       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19123       endif
19124 !C second case jth atom is center
19125       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19126       eij2=0.0d0
19127       else
19128       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19129       endif
19130 !C the third case kth atom is the center
19131       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19132       eij3=0.0d0
19133       else
19134       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19135       endif
19136 !C      eij2=0.0
19137 !C      eij3=0.0
19138 !C      eij1=0.0
19139       eij=eij1+eij2+eij3
19140 !C      write(iout,*)i,j,k,eij
19141 !C The energy penalty calculated now time for the gradient part
19142 !C derivative over rij
19143       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19144       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19145             gg(1)=xij*fac/rij
19146             gg(2)=yij*fac/rij
19147             gg(3)=zij*fac/rij
19148       do m=1,3
19149         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19150         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19151       enddo
19152
19153       do l=1,3
19154         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19155         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19156       enddo
19157 !C now derivative over rik
19158       fac=-eij1**2/dtriss* &
19159       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19160       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19161             gg(1)=xik*fac/rik
19162             gg(2)=yik*fac/rik
19163             gg(3)=zik*fac/rik
19164       do m=1,3
19165         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19166         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19167       enddo
19168       do l=1,3
19169         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19170         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19171       enddo
19172 !C now derivative over rjk
19173       fac=-eij2**2/dtriss* &
19174       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19175       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19176             gg(1)=xjk*fac/rjk
19177             gg(2)=yjk*fac/rjk
19178             gg(3)=zjk*fac/rjk
19179       do m=1,3
19180         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19181         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19182       enddo
19183       do l=1,3
19184         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19185         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19186       enddo
19187       return
19188       end subroutine triple_ssbond_ene
19189
19190
19191
19192 !-----------------------------------------------------------------------------
19193       real(kind=8) function h_base(x,deriv)
19194 !     A smooth function going 0->1 in range [0,1]
19195 !     It should NOT be called outside range [0,1], it will not work there.
19196       implicit none
19197
19198 !     Input arguments
19199       real(kind=8) :: x
19200
19201 !     Output arguments
19202       real(kind=8) :: deriv
19203
19204 !     Local variables
19205       real(kind=8) :: xsq
19206
19207
19208 !     Two parabolas put together.  First derivative zero at extrema
19209 !$$$      if (x.lt.0.5D0) then
19210 !$$$        h_base=2.0D0*x*x
19211 !$$$        deriv=4.0D0*x
19212 !$$$      else
19213 !$$$        deriv=1.0D0-x
19214 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19215 !$$$        deriv=4.0D0*deriv
19216 !$$$      endif
19217
19218 !     Third degree polynomial.  First derivative zero at extrema
19219       h_base=x*x*(3.0d0-2.0d0*x)
19220       deriv=6.0d0*x*(1.0d0-x)
19221
19222 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19223 !$$$      xsq=x*x
19224 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19225 !$$$      deriv=x-1.0d0
19226 !$$$      deriv=deriv*deriv
19227 !$$$      deriv=30.0d0*xsq*deriv
19228
19229       return
19230       end function h_base
19231 !-----------------------------------------------------------------------------
19232       subroutine dyn_set_nss
19233 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19234 !      implicit none
19235       use MD_data, only: totT,t_bath
19236 !     Includes
19237 !      include 'DIMENSIONS'
19238 #ifdef MPI
19239       include "mpif.h"
19240 #endif
19241 !      include 'COMMON.SBRIDGE'
19242 !      include 'COMMON.CHAIN'
19243 !      include 'COMMON.IOUNITS'
19244 !      include 'COMMON.SETUP'
19245 !      include 'COMMON.MD'
19246 !     Local variables
19247       real(kind=8) :: emin
19248       integer :: i,j,imin,ierr
19249       integer :: diff,allnss,newnss
19250       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19251                 newihpb,newjhpb
19252       logical :: found
19253       integer,dimension(0:nfgtasks) :: i_newnss
19254       integer,dimension(0:nfgtasks) :: displ
19255       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19256       integer :: g_newnss
19257
19258       allnss=0
19259       do i=1,nres-1
19260         do j=i+1,nres
19261           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19262             allnss=allnss+1
19263             allflag(allnss)=0
19264             allihpb(allnss)=i
19265             alljhpb(allnss)=j
19266           endif
19267         enddo
19268       enddo
19269
19270 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19271
19272  1    emin=1.0d300
19273       do i=1,allnss
19274         if (allflag(i).eq.0 .and. &
19275              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19276           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19277           imin=i
19278         endif
19279       enddo
19280       if (emin.lt.1.0d300) then
19281         allflag(imin)=1
19282         do i=1,allnss
19283           if (allflag(i).eq.0 .and. &
19284                (allihpb(i).eq.allihpb(imin) .or. &
19285                alljhpb(i).eq.allihpb(imin) .or. &
19286                allihpb(i).eq.alljhpb(imin) .or. &
19287                alljhpb(i).eq.alljhpb(imin))) then
19288             allflag(i)=-1
19289           endif
19290         enddo
19291         goto 1
19292       endif
19293
19294 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19295
19296       newnss=0
19297       do i=1,allnss
19298         if (allflag(i).eq.1) then
19299           newnss=newnss+1
19300           newihpb(newnss)=allihpb(i)
19301           newjhpb(newnss)=alljhpb(i)
19302         endif
19303       enddo
19304
19305 #ifdef MPI
19306       if (nfgtasks.gt.1)then
19307
19308         call MPI_Reduce(newnss,g_newnss,1,&
19309           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19310         call MPI_Gather(newnss,1,MPI_INTEGER,&
19311                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19312         displ(0)=0
19313         do i=1,nfgtasks-1,1
19314           displ(i)=i_newnss(i-1)+displ(i-1)
19315         enddo
19316         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19317                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19318                          king,FG_COMM,IERR)
19319         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19320                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19321                          king,FG_COMM,IERR)
19322         if(fg_rank.eq.0) then
19323 !         print *,'g_newnss',g_newnss
19324 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19325 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19326          newnss=g_newnss
19327          do i=1,newnss
19328           newihpb(i)=g_newihpb(i)
19329           newjhpb(i)=g_newjhpb(i)
19330          enddo
19331         endif
19332       endif
19333 #endif
19334
19335       diff=newnss-nss
19336
19337 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19338 !       print *,newnss,nss,maxdim
19339       do i=1,nss
19340         found=.false.
19341 !        print *,newnss
19342         do j=1,newnss
19343 !!          print *,j
19344           if (idssb(i).eq.newihpb(j) .and. &
19345                jdssb(i).eq.newjhpb(j)) found=.true.
19346         enddo
19347 #ifndef CLUST
19348 #ifndef WHAM
19349 !        write(iout,*) "found",found,i,j
19350         if (.not.found.and.fg_rank.eq.0) &
19351             write(iout,'(a15,f12.2,f8.1,2i5)') &
19352              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19353 #endif
19354 #endif
19355       enddo
19356
19357       do i=1,newnss
19358         found=.false.
19359         do j=1,nss
19360 !          print *,i,j
19361           if (newihpb(i).eq.idssb(j) .and. &
19362                newjhpb(i).eq.jdssb(j)) found=.true.
19363         enddo
19364 #ifndef CLUST
19365 #ifndef WHAM
19366 !        write(iout,*) "found",found,i,j
19367         if (.not.found.and.fg_rank.eq.0) &
19368             write(iout,'(a15,f12.2,f8.1,2i5)') &
19369              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19370 #endif
19371 #endif
19372       enddo
19373
19374       nss=newnss
19375       do i=1,nss
19376         idssb(i)=newihpb(i)
19377         jdssb(i)=newjhpb(i)
19378       enddo
19379
19380       return
19381       end subroutine dyn_set_nss
19382 ! Lipid transfer energy function
19383       subroutine Eliptransfer(eliptran)
19384 !C this is done by Adasko
19385 !C      print *,"wchodze"
19386 !C structure of box:
19387 !C      water
19388 !C--bordliptop-- buffore starts
19389 !C--bufliptop--- here true lipid starts
19390 !C      lipid
19391 !C--buflipbot--- lipid ends buffore starts
19392 !C--bordlipbot--buffore ends
19393       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19394       integer :: i
19395       eliptran=0.0
19396 !      print *, "I am in eliptran"
19397       do i=ilip_start,ilip_end
19398 !C       do i=1,1
19399         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19400          cycle
19401
19402         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19403         if (positi.le.0.0) positi=positi+boxzsize
19404 !C        print *,i
19405 !C first for peptide groups
19406 !c for each residue check if it is in lipid or lipid water border area
19407        if ((positi.gt.bordlipbot)  &
19408       .and.(positi.lt.bordliptop)) then
19409 !C the energy transfer exist
19410         if (positi.lt.buflipbot) then
19411 !C what fraction I am in
19412          fracinbuf=1.0d0-      &
19413              ((positi-bordlipbot)/lipbufthick)
19414 !C lipbufthick is thickenes of lipid buffore
19415          sslip=sscalelip(fracinbuf)
19416          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19417          eliptran=eliptran+sslip*pepliptran
19418          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19419          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19420 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19421
19422 !C        print *,"doing sccale for lower part"
19423 !C         print *,i,sslip,fracinbuf,ssgradlip
19424         elseif (positi.gt.bufliptop) then
19425          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19426          sslip=sscalelip(fracinbuf)
19427          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19428          eliptran=eliptran+sslip*pepliptran
19429          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19430          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19431 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19432 !C          print *, "doing sscalefor top part"
19433 !C         print *,i,sslip,fracinbuf,ssgradlip
19434         else
19435          eliptran=eliptran+pepliptran
19436 !C         print *,"I am in true lipid"
19437         endif
19438 !C       else
19439 !C       eliptran=elpitran+0.0 ! I am in water
19440        endif
19441        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19442        enddo
19443 ! here starts the side chain transfer
19444        do i=ilip_start,ilip_end
19445         if (itype(i,1).eq.ntyp1) cycle
19446         positi=(mod(c(3,i+nres),boxzsize))
19447         if (positi.le.0) positi=positi+boxzsize
19448 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19449 !c for each residue check if it is in lipid or lipid water border area
19450 !C       respos=mod(c(3,i+nres),boxzsize)
19451 !C       print *,positi,bordlipbot,buflipbot
19452        if ((positi.gt.bordlipbot) &
19453        .and.(positi.lt.bordliptop)) then
19454 !C the energy transfer exist
19455         if (positi.lt.buflipbot) then
19456          fracinbuf=1.0d0-   &
19457            ((positi-bordlipbot)/lipbufthick)
19458 !C lipbufthick is thickenes of lipid buffore
19459          sslip=sscalelip(fracinbuf)
19460          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19461          eliptran=eliptran+sslip*liptranene(itype(i,1))
19462          gliptranx(3,i)=gliptranx(3,i) &
19463       +ssgradlip*liptranene(itype(i,1))
19464          gliptranc(3,i-1)= gliptranc(3,i-1) &
19465       +ssgradlip*liptranene(itype(i,1))
19466 !C         print *,"doing sccale for lower part"
19467         elseif (positi.gt.bufliptop) then
19468          fracinbuf=1.0d0-  &
19469       ((bordliptop-positi)/lipbufthick)
19470          sslip=sscalelip(fracinbuf)
19471          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19472          eliptran=eliptran+sslip*liptranene(itype(i,1))
19473          gliptranx(3,i)=gliptranx(3,i)  &
19474        +ssgradlip*liptranene(itype(i,1))
19475          gliptranc(3,i-1)= gliptranc(3,i-1) &
19476       +ssgradlip*liptranene(itype(i,1))
19477 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19478         else
19479          eliptran=eliptran+liptranene(itype(i,1))
19480 !C         print *,"I am in true lipid"
19481         endif
19482         endif ! if in lipid or buffor
19483 !C       else
19484 !C       eliptran=elpitran+0.0 ! I am in water
19485         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19486        enddo
19487        return
19488        end  subroutine Eliptransfer
19489 !----------------------------------NANO FUNCTIONS
19490 !C-----------------------------------------------------------------------
19491 !C-----------------------------------------------------------
19492 !C This subroutine is to mimic the histone like structure but as well can be
19493 !C utilizet to nanostructures (infinit) small modification has to be used to
19494 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19495 !C gradient has to be modified at the ends
19496 !C The energy function is Kihara potential
19497 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19498 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19499 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19500 !C simple Kihara potential
19501       subroutine calctube(Etube)
19502       real(kind=8),dimension(3) :: vectube
19503       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19504        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19505        sc_aa_tube,sc_bb_tube
19506       integer :: i,j,iti
19507       Etube=0.0d0
19508       do i=itube_start,itube_end
19509         enetube(i)=0.0d0
19510         enetube(i+nres)=0.0d0
19511       enddo
19512 !C first we calculate the distance from tube center
19513 !C for UNRES
19514        do i=itube_start,itube_end
19515 !C lets ommit dummy atoms for now
19516        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19517 !C now calculate distance from center of tube and direction vectors
19518       xmin=boxxsize
19519       ymin=boxysize
19520 ! Find minimum distance in periodic box
19521         do j=-1,1
19522          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19523          vectube(1)=vectube(1)+boxxsize*j
19524          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19525          vectube(2)=vectube(2)+boxysize*j
19526          xminact=abs(vectube(1)-tubecenter(1))
19527          yminact=abs(vectube(2)-tubecenter(2))
19528            if (xmin.gt.xminact) then
19529             xmin=xminact
19530             xtemp=vectube(1)
19531            endif
19532            if (ymin.gt.yminact) then
19533              ymin=yminact
19534              ytemp=vectube(2)
19535             endif
19536          enddo
19537       vectube(1)=xtemp
19538       vectube(2)=ytemp
19539       vectube(1)=vectube(1)-tubecenter(1)
19540       vectube(2)=vectube(2)-tubecenter(2)
19541
19542 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19543 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19544
19545 !C as the tube is infinity we do not calculate the Z-vector use of Z
19546 !C as chosen axis
19547       vectube(3)=0.0d0
19548 !C now calculte the distance
19549        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19550 !C now normalize vector
19551       vectube(1)=vectube(1)/tub_r
19552       vectube(2)=vectube(2)/tub_r
19553 !C calculte rdiffrence between r and r0
19554       rdiff=tub_r-tubeR0
19555 !C and its 6 power
19556       rdiff6=rdiff**6.0d0
19557 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19558        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19559 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19560 !C       print *,rdiff,rdiff6,pep_aa_tube
19561 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19562 !C now we calculate gradient
19563        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19564             6.0d0*pep_bb_tube)/rdiff6/rdiff
19565 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19566 !C     &rdiff,fac
19567 !C now direction of gg_tube vector
19568         do j=1,3
19569         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19570         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19571         enddo
19572         enddo
19573 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19574 !C        print *,gg_tube(1,0),"TU"
19575
19576
19577        do i=itube_start,itube_end
19578 !C Lets not jump over memory as we use many times iti
19579          iti=itype(i,1)
19580 !C lets ommit dummy atoms for now
19581          if ((iti.eq.ntyp1)  &
19582 !C in UNRES uncomment the line below as GLY has no side-chain...
19583 !C      .or.(iti.eq.10)
19584         ) cycle
19585       xmin=boxxsize
19586       ymin=boxysize
19587         do j=-1,1
19588          vectube(1)=mod((c(1,i+nres)),boxxsize)
19589          vectube(1)=vectube(1)+boxxsize*j
19590          vectube(2)=mod((c(2,i+nres)),boxysize)
19591          vectube(2)=vectube(2)+boxysize*j
19592
19593          xminact=abs(vectube(1)-tubecenter(1))
19594          yminact=abs(vectube(2)-tubecenter(2))
19595            if (xmin.gt.xminact) then
19596             xmin=xminact
19597             xtemp=vectube(1)
19598            endif
19599            if (ymin.gt.yminact) then
19600              ymin=yminact
19601              ytemp=vectube(2)
19602             endif
19603          enddo
19604       vectube(1)=xtemp
19605       vectube(2)=ytemp
19606 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19607 !C     &     tubecenter(2)
19608       vectube(1)=vectube(1)-tubecenter(1)
19609       vectube(2)=vectube(2)-tubecenter(2)
19610
19611 !C as the tube is infinity we do not calculate the Z-vector use of Z
19612 !C as chosen axis
19613       vectube(3)=0.0d0
19614 !C now calculte the distance
19615        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19616 !C now normalize vector
19617       vectube(1)=vectube(1)/tub_r
19618       vectube(2)=vectube(2)/tub_r
19619
19620 !C calculte rdiffrence between r and r0
19621       rdiff=tub_r-tubeR0
19622 !C and its 6 power
19623       rdiff6=rdiff**6.0d0
19624 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19625        sc_aa_tube=sc_aa_tube_par(iti)
19626        sc_bb_tube=sc_bb_tube_par(iti)
19627        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19628        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19629              6.0d0*sc_bb_tube/rdiff6/rdiff
19630 !C now direction of gg_tube vector
19631          do j=1,3
19632           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19633           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19634          enddo
19635         enddo
19636         do i=itube_start,itube_end
19637           Etube=Etube+enetube(i)+enetube(i+nres)
19638         enddo
19639 !C        print *,"ETUBE", etube
19640         return
19641         end subroutine calctube
19642 !C TO DO 1) add to total energy
19643 !C       2) add to gradient summation
19644 !C       3) add reading parameters (AND of course oppening of PARAM file)
19645 !C       4) add reading the center of tube
19646 !C       5) add COMMONs
19647 !C       6) add to zerograd
19648 !C       7) allocate matrices
19649
19650
19651 !C-----------------------------------------------------------------------
19652 !C-----------------------------------------------------------
19653 !C This subroutine is to mimic the histone like structure but as well can be
19654 !C utilizet to nanostructures (infinit) small modification has to be used to
19655 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19656 !C gradient has to be modified at the ends
19657 !C The energy function is Kihara potential
19658 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19659 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19660 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19661 !C simple Kihara potential
19662       subroutine calctube2(Etube)
19663             real(kind=8),dimension(3) :: vectube
19664       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19665        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19666        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19667       integer:: i,j,iti
19668       Etube=0.0d0
19669       do i=itube_start,itube_end
19670         enetube(i)=0.0d0
19671         enetube(i+nres)=0.0d0
19672       enddo
19673 !C first we calculate the distance from tube center
19674 !C first sugare-phosphate group for NARES this would be peptide group
19675 !C for UNRES
19676        do i=itube_start,itube_end
19677 !C lets ommit dummy atoms for now
19678
19679        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19680 !C now calculate distance from center of tube and direction vectors
19681 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19682 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19683 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19684 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19685       xmin=boxxsize
19686       ymin=boxysize
19687         do j=-1,1
19688          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19689          vectube(1)=vectube(1)+boxxsize*j
19690          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19691          vectube(2)=vectube(2)+boxysize*j
19692
19693          xminact=abs(vectube(1)-tubecenter(1))
19694          yminact=abs(vectube(2)-tubecenter(2))
19695            if (xmin.gt.xminact) then
19696             xmin=xminact
19697             xtemp=vectube(1)
19698            endif
19699            if (ymin.gt.yminact) then
19700              ymin=yminact
19701              ytemp=vectube(2)
19702             endif
19703          enddo
19704       vectube(1)=xtemp
19705       vectube(2)=ytemp
19706       vectube(1)=vectube(1)-tubecenter(1)
19707       vectube(2)=vectube(2)-tubecenter(2)
19708
19709 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19710 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19711
19712 !C as the tube is infinity we do not calculate the Z-vector use of Z
19713 !C as chosen axis
19714       vectube(3)=0.0d0
19715 !C now calculte the distance
19716        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19717 !C now normalize vector
19718       vectube(1)=vectube(1)/tub_r
19719       vectube(2)=vectube(2)/tub_r
19720 !C calculte rdiffrence between r and r0
19721       rdiff=tub_r-tubeR0
19722 !C and its 6 power
19723       rdiff6=rdiff**6.0d0
19724 !C THIS FRAGMENT MAKES TUBE FINITE
19725         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19726         if (positi.le.0) positi=positi+boxzsize
19727 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19728 !c for each residue check if it is in lipid or lipid water border area
19729 !C       respos=mod(c(3,i+nres),boxzsize)
19730 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19731        if ((positi.gt.bordtubebot)  &
19732         .and.(positi.lt.bordtubetop)) then
19733 !C the energy transfer exist
19734         if (positi.lt.buftubebot) then
19735          fracinbuf=1.0d0-  &
19736            ((positi-bordtubebot)/tubebufthick)
19737 !C lipbufthick is thickenes of lipid buffore
19738          sstube=sscalelip(fracinbuf)
19739          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19740 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19741          enetube(i)=enetube(i)+sstube*tubetranenepep
19742 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19743 !C     &+ssgradtube*tubetranene(itype(i,1))
19744 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19745 !C     &+ssgradtube*tubetranene(itype(i,1))
19746 !C         print *,"doing sccale for lower part"
19747         elseif (positi.gt.buftubetop) then
19748          fracinbuf=1.0d0-  &
19749         ((bordtubetop-positi)/tubebufthick)
19750          sstube=sscalelip(fracinbuf)
19751          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19752          enetube(i)=enetube(i)+sstube*tubetranenepep
19753 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19754 !C     &+ssgradtube*tubetranene(itype(i,1))
19755 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19756 !C     &+ssgradtube*tubetranene(itype(i,1))
19757 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19758         else
19759          sstube=1.0d0
19760          ssgradtube=0.0d0
19761          enetube(i)=enetube(i)+sstube*tubetranenepep
19762 !C         print *,"I am in true lipid"
19763         endif
19764         else
19765 !C          sstube=0.0d0
19766 !C          ssgradtube=0.0d0
19767         cycle
19768         endif ! if in lipid or buffor
19769
19770 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19771        enetube(i)=enetube(i)+sstube* &
19772         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19773 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19774 !C       print *,rdiff,rdiff6,pep_aa_tube
19775 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19776 !C now we calculate gradient
19777        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19778              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19779 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19780 !C     &rdiff,fac
19781
19782 !C now direction of gg_tube vector
19783        do j=1,3
19784         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19785         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19786         enddo
19787          gg_tube(3,i)=gg_tube(3,i)  &
19788        +ssgradtube*enetube(i)/sstube/2.0d0
19789          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19790        +ssgradtube*enetube(i)/sstube/2.0d0
19791
19792         enddo
19793 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19794 !C        print *,gg_tube(1,0),"TU"
19795         do i=itube_start,itube_end
19796 !C Lets not jump over memory as we use many times iti
19797          iti=itype(i,1)
19798 !C lets ommit dummy atoms for now
19799          if ((iti.eq.ntyp1) &
19800 !!C in UNRES uncomment the line below as GLY has no side-chain...
19801            .or.(iti.eq.10) &
19802           ) cycle
19803           vectube(1)=c(1,i+nres)
19804           vectube(1)=mod(vectube(1),boxxsize)
19805           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19806           vectube(2)=c(2,i+nres)
19807           vectube(2)=mod(vectube(2),boxysize)
19808           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19809
19810       vectube(1)=vectube(1)-tubecenter(1)
19811       vectube(2)=vectube(2)-tubecenter(2)
19812 !C THIS FRAGMENT MAKES TUBE FINITE
19813         positi=(mod(c(3,i+nres),boxzsize))
19814         if (positi.le.0) positi=positi+boxzsize
19815 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19816 !c for each residue check if it is in lipid or lipid water border area
19817 !C       respos=mod(c(3,i+nres),boxzsize)
19818 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19819
19820        if ((positi.gt.bordtubebot)  &
19821         .and.(positi.lt.bordtubetop)) then
19822 !C the energy transfer exist
19823         if (positi.lt.buftubebot) then
19824          fracinbuf=1.0d0- &
19825             ((positi-bordtubebot)/tubebufthick)
19826 !C lipbufthick is thickenes of lipid buffore
19827          sstube=sscalelip(fracinbuf)
19828          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19829 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19830          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19831 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19832 !C     &+ssgradtube*tubetranene(itype(i,1))
19833 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19834 !C     &+ssgradtube*tubetranene(itype(i,1))
19835 !C         print *,"doing sccale for lower part"
19836         elseif (positi.gt.buftubetop) then
19837          fracinbuf=1.0d0- &
19838         ((bordtubetop-positi)/tubebufthick)
19839
19840          sstube=sscalelip(fracinbuf)
19841          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19842          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19843 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19844 !C     &+ssgradtube*tubetranene(itype(i,1))
19845 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19846 !C     &+ssgradtube*tubetranene(itype(i,1))
19847 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19848         else
19849          sstube=1.0d0
19850          ssgradtube=0.0d0
19851          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19852 !C         print *,"I am in true lipid"
19853         endif
19854         else
19855 !C          sstube=0.0d0
19856 !C          ssgradtube=0.0d0
19857         cycle
19858         endif ! if in lipid or buffor
19859 !CEND OF FINITE FRAGMENT
19860 !C as the tube is infinity we do not calculate the Z-vector use of Z
19861 !C as chosen axis
19862       vectube(3)=0.0d0
19863 !C now calculte the distance
19864        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19865 !C now normalize vector
19866       vectube(1)=vectube(1)/tub_r
19867       vectube(2)=vectube(2)/tub_r
19868 !C calculte rdiffrence between r and r0
19869       rdiff=tub_r-tubeR0
19870 !C and its 6 power
19871       rdiff6=rdiff**6.0d0
19872 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19873        sc_aa_tube=sc_aa_tube_par(iti)
19874        sc_bb_tube=sc_bb_tube_par(iti)
19875        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19876                        *sstube+enetube(i+nres)
19877 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19878 !C now we calculate gradient
19879        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19880             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19881 !C now direction of gg_tube vector
19882          do j=1,3
19883           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19884           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19885          enddo
19886          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19887        +ssgradtube*enetube(i+nres)/sstube
19888          gg_tube(3,i-1)= gg_tube(3,i-1) &
19889        +ssgradtube*enetube(i+nres)/sstube
19890
19891         enddo
19892         do i=itube_start,itube_end
19893           Etube=Etube+enetube(i)+enetube(i+nres)
19894         enddo
19895 !C        print *,"ETUBE", etube
19896         return
19897         end subroutine calctube2
19898 !=====================================================================================================================================
19899       subroutine calcnano(Etube)
19900       real(kind=8),dimension(3) :: vectube
19901
19902       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19903        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19904        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19905        integer:: i,j,iti,r
19906
19907       Etube=0.0d0
19908 !      print *,itube_start,itube_end,"poczatek"
19909       do i=itube_start,itube_end
19910         enetube(i)=0.0d0
19911         enetube(i+nres)=0.0d0
19912       enddo
19913 !C first we calculate the distance from tube center
19914 !C first sugare-phosphate group for NARES this would be peptide group
19915 !C for UNRES
19916        do i=itube_start,itube_end
19917 !C lets ommit dummy atoms for now
19918        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19919 !C now calculate distance from center of tube and direction vectors
19920       xmin=boxxsize
19921       ymin=boxysize
19922       zmin=boxzsize
19923
19924         do j=-1,1
19925          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19926          vectube(1)=vectube(1)+boxxsize*j
19927          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19928          vectube(2)=vectube(2)+boxysize*j
19929          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19930          vectube(3)=vectube(3)+boxzsize*j
19931
19932
19933          xminact=dabs(vectube(1)-tubecenter(1))
19934          yminact=dabs(vectube(2)-tubecenter(2))
19935          zminact=dabs(vectube(3)-tubecenter(3))
19936
19937            if (xmin.gt.xminact) then
19938             xmin=xminact
19939             xtemp=vectube(1)
19940            endif
19941            if (ymin.gt.yminact) then
19942              ymin=yminact
19943              ytemp=vectube(2)
19944             endif
19945            if (zmin.gt.zminact) then
19946              zmin=zminact
19947              ztemp=vectube(3)
19948             endif
19949          enddo
19950       vectube(1)=xtemp
19951       vectube(2)=ytemp
19952       vectube(3)=ztemp
19953
19954       vectube(1)=vectube(1)-tubecenter(1)
19955       vectube(2)=vectube(2)-tubecenter(2)
19956       vectube(3)=vectube(3)-tubecenter(3)
19957
19958 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19959 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19960 !C as the tube is infinity we do not calculate the Z-vector use of Z
19961 !C as chosen axis
19962 !C      vectube(3)=0.0d0
19963 !C now calculte the distance
19964        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19965 !C now normalize vector
19966       vectube(1)=vectube(1)/tub_r
19967       vectube(2)=vectube(2)/tub_r
19968       vectube(3)=vectube(3)/tub_r
19969 !C calculte rdiffrence between r and r0
19970       rdiff=tub_r-tubeR0
19971 !C and its 6 power
19972       rdiff6=rdiff**6.0d0
19973 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19974        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19975 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19976 !C       print *,rdiff,rdiff6,pep_aa_tube
19977 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19978 !C now we calculate gradient
19979        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19980             6.0d0*pep_bb_tube)/rdiff6/rdiff
19981 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19982 !C     &rdiff,fac
19983          if (acavtubpep.eq.0.0d0) then
19984 !C go to 667
19985          enecavtube(i)=0.0
19986          faccav=0.0
19987          else
19988          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19989          enecavtube(i)=  &
19990         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19991         /denominator
19992          enecavtube(i)=0.0
19993          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19994         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19995         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19996         /denominator**2.0d0
19997 !C         faccav=0.0
19998 !C         fac=fac+faccav
19999 !C 667     continue
20000          endif
20001           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20002         do j=1,3
20003         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20004         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20005         enddo
20006         enddo
20007
20008        do i=itube_start,itube_end
20009         enecavtube(i)=0.0d0
20010 !C Lets not jump over memory as we use many times iti
20011          iti=itype(i,1)
20012 !C lets ommit dummy atoms for now
20013          if ((iti.eq.ntyp1) &
20014 !C in UNRES uncomment the line below as GLY has no side-chain...
20015 !C      .or.(iti.eq.10)
20016          ) cycle
20017       xmin=boxxsize
20018       ymin=boxysize
20019       zmin=boxzsize
20020         do j=-1,1
20021          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20022          vectube(1)=vectube(1)+boxxsize*j
20023          vectube(2)=dmod((c(2,i+nres)),boxysize)
20024          vectube(2)=vectube(2)+boxysize*j
20025          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20026          vectube(3)=vectube(3)+boxzsize*j
20027
20028
20029          xminact=dabs(vectube(1)-tubecenter(1))
20030          yminact=dabs(vectube(2)-tubecenter(2))
20031          zminact=dabs(vectube(3)-tubecenter(3))
20032
20033            if (xmin.gt.xminact) then
20034             xmin=xminact
20035             xtemp=vectube(1)
20036            endif
20037            if (ymin.gt.yminact) then
20038              ymin=yminact
20039              ytemp=vectube(2)
20040             endif
20041            if (zmin.gt.zminact) then
20042              zmin=zminact
20043              ztemp=vectube(3)
20044             endif
20045          enddo
20046       vectube(1)=xtemp
20047       vectube(2)=ytemp
20048       vectube(3)=ztemp
20049
20050 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20051 !C     &     tubecenter(2)
20052       vectube(1)=vectube(1)-tubecenter(1)
20053       vectube(2)=vectube(2)-tubecenter(2)
20054       vectube(3)=vectube(3)-tubecenter(3)
20055 !C now calculte the distance
20056        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20057 !C now normalize vector
20058       vectube(1)=vectube(1)/tub_r
20059       vectube(2)=vectube(2)/tub_r
20060       vectube(3)=vectube(3)/tub_r
20061
20062 !C calculte rdiffrence between r and r0
20063       rdiff=tub_r-tubeR0
20064 !C and its 6 power
20065       rdiff6=rdiff**6.0d0
20066        sc_aa_tube=sc_aa_tube_par(iti)
20067        sc_bb_tube=sc_bb_tube_par(iti)
20068        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20069 !C       enetube(i+nres)=0.0d0
20070 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20071 !C now we calculate gradient
20072        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20073             6.0d0*sc_bb_tube/rdiff6/rdiff
20074 !C       fac=0.0
20075 !C now direction of gg_tube vector
20076 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20077          if (acavtub(iti).eq.0.0d0) then
20078 !C go to 667
20079          enecavtube(i+nres)=0.0d0
20080          faccav=0.0d0
20081          else
20082          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20083          enecavtube(i+nres)=   &
20084         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20085         /denominator
20086 !C         enecavtube(i)=0.0
20087          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20088         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20089         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20090         /denominator**2.0d0
20091 !C         faccav=0.0
20092          fac=fac+faccav
20093 !C 667     continue
20094          endif
20095 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20096 !C     &   enecavtube(i),faccav
20097 !C         print *,"licz=",
20098 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20099 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20100          do j=1,3
20101           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20102           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20103          enddo
20104           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20105         enddo
20106
20107
20108
20109         do i=itube_start,itube_end
20110           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20111          +enecavtube(i+nres)
20112         enddo
20113 !        do i=1,20
20114 !         print *,"begin", i,"a"
20115 !         do r=1,10000
20116 !          rdiff=r/100.0d0
20117 !          rdiff6=rdiff**6.0d0
20118 !          sc_aa_tube=sc_aa_tube_par(i)
20119 !          sc_bb_tube=sc_bb_tube_par(i)
20120 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20121 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20122 !          enecavtube(i)=   &
20123 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20124 !         /denominator
20125
20126 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20127 !         enddo
20128 !         print *,"end",i,"a"
20129 !        enddo
20130 !C        print *,"ETUBE", etube
20131         return
20132         end subroutine calcnano
20133
20134 !===============================================
20135 !--------------------------------------------------------------------------------
20136 !C first for shielding is setting of function of side-chains
20137
20138        subroutine set_shield_fac2
20139        real(kind=8) :: div77_81=0.974996043d0, &
20140         div4_81=0.2222222222d0
20141        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20142          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20143          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20144          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20145 !C the vector between center of side_chain and peptide group
20146        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20147          pept_group,costhet_grad,cosphi_grad_long, &
20148          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20149          sh_frac_dist_grad,pep_side
20150         integer i,j,k
20151 !C      write(2,*) "ivec",ivec_start,ivec_end
20152       do i=1,nres
20153         fac_shield(i)=0.0d0
20154         ishield_list(i)=0
20155         do j=1,3
20156         grad_shield(j,i)=0.0d0
20157         enddo
20158       enddo
20159       do i=ivec_start,ivec_end
20160 !C      do i=1,nres-1
20161 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20162 !      ishield_list(i)=0
20163       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20164 !Cif there two consequtive dummy atoms there is no peptide group between them
20165 !C the line below has to be changed for FGPROC>1
20166       VolumeTotal=0.0
20167       do k=1,nres
20168        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20169        dist_pep_side=0.0
20170        dist_side_calf=0.0
20171        do j=1,3
20172 !C first lets set vector conecting the ithe side-chain with kth side-chain
20173       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20174 !C      pep_side(j)=2.0d0
20175 !C and vector conecting the side-chain with its proper calfa
20176       side_calf(j)=c(j,k+nres)-c(j,k)
20177 !C      side_calf(j)=2.0d0
20178       pept_group(j)=c(j,i)-c(j,i+1)
20179 !C lets have their lenght
20180       dist_pep_side=pep_side(j)**2+dist_pep_side
20181       dist_side_calf=dist_side_calf+side_calf(j)**2
20182       dist_pept_group=dist_pept_group+pept_group(j)**2
20183       enddo
20184        dist_pep_side=sqrt(dist_pep_side)
20185        dist_pept_group=sqrt(dist_pept_group)
20186        dist_side_calf=sqrt(dist_side_calf)
20187       do j=1,3
20188         pep_side_norm(j)=pep_side(j)/dist_pep_side
20189         side_calf_norm(j)=dist_side_calf
20190       enddo
20191 !C now sscale fraction
20192        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20193 !       print *,buff_shield,"buff",sh_frac_dist
20194 !C now sscale
20195         if (sh_frac_dist.le.0.0) cycle
20196 !C        print *,ishield_list(i),i
20197 !C If we reach here it means that this side chain reaches the shielding sphere
20198 !C Lets add him to the list for gradient
20199         ishield_list(i)=ishield_list(i)+1
20200 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20201 !C this list is essential otherwise problem would be O3
20202         shield_list(ishield_list(i),i)=k
20203 !C Lets have the sscale value
20204         if (sh_frac_dist.gt.1.0) then
20205          scale_fac_dist=1.0d0
20206          do j=1,3
20207          sh_frac_dist_grad(j)=0.0d0
20208          enddo
20209         else
20210          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20211                         *(2.0d0*sh_frac_dist-3.0d0)
20212          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20213                        /dist_pep_side/buff_shield*0.5d0
20214          do j=1,3
20215          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20216 !C         sh_frac_dist_grad(j)=0.0d0
20217 !C         scale_fac_dist=1.0d0
20218 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20219 !C     &                    sh_frac_dist_grad(j)
20220          enddo
20221         endif
20222 !C this is what is now we have the distance scaling now volume...
20223       short=short_r_sidechain(itype(k,1))
20224       long=long_r_sidechain(itype(k,1))
20225       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20226       sinthet=short/dist_pep_side*costhet
20227 !      print *,"SORT",short,long,sinthet,costhet
20228 !C now costhet_grad
20229 !C       costhet=0.6d0
20230 !C       sinthet=0.8
20231        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20232 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20233 !C     &             -short/dist_pep_side**2/costhet)
20234 !C       costhet_fac=0.0d0
20235        do j=1,3
20236          costhet_grad(j)=costhet_fac*pep_side(j)
20237        enddo
20238 !C remember for the final gradient multiply costhet_grad(j)
20239 !C for side_chain by factor -2 !
20240 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20241 !C pep_side0pept_group is vector multiplication
20242       pep_side0pept_group=0.0d0
20243       do j=1,3
20244       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20245       enddo
20246       cosalfa=(pep_side0pept_group/ &
20247       (dist_pep_side*dist_side_calf))
20248       fac_alfa_sin=1.0d0-cosalfa**2
20249       fac_alfa_sin=dsqrt(fac_alfa_sin)
20250       rkprim=fac_alfa_sin*(long-short)+short
20251 !C      rkprim=short
20252
20253 !C now costhet_grad
20254        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20255 !C       cosphi=0.6
20256        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20257        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20258            dist_pep_side**2)
20259 !C       sinphi=0.8
20260        do j=1,3
20261          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20262       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20263       *(long-short)/fac_alfa_sin*cosalfa/ &
20264       ((dist_pep_side*dist_side_calf))* &
20265       ((side_calf(j))-cosalfa* &
20266       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20267 !C       cosphi_grad_long(j)=0.0d0
20268         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20269       *(long-short)/fac_alfa_sin*cosalfa &
20270       /((dist_pep_side*dist_side_calf))* &
20271       (pep_side(j)- &
20272       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20273 !C       cosphi_grad_loc(j)=0.0d0
20274        enddo
20275 !C      print *,sinphi,sinthet
20276       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20277                          /VSolvSphere_div
20278 !C     &                    *wshield
20279 !C now the gradient...
20280       do j=1,3
20281       grad_shield(j,i)=grad_shield(j,i) &
20282 !C gradient po skalowaniu
20283                      +(sh_frac_dist_grad(j)*VofOverlap &
20284 !C  gradient po costhet
20285             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20286         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20287             sinphi/sinthet*costhet*costhet_grad(j) &
20288            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20289         )*wshield
20290 !C grad_shield_side is Cbeta sidechain gradient
20291       grad_shield_side(j,ishield_list(i),i)=&
20292              (sh_frac_dist_grad(j)*-2.0d0&
20293              *VofOverlap&
20294             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20295        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20296             sinphi/sinthet*costhet*costhet_grad(j)&
20297            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20298             )*wshield
20299 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20300 !            sinphi/sinthet,&
20301 !           +sinthet/sinphi,"HERE"
20302        grad_shield_loc(j,ishield_list(i),i)=   &
20303             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20304       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20305             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20306              ))&
20307              *wshield
20308 !         print *,grad_shield_loc(j,ishield_list(i),i)
20309       enddo
20310       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20311       enddo
20312       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20313
20314 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20315       enddo
20316       return
20317       end subroutine set_shield_fac2
20318 !----------------------------------------------------------------------------
20319 ! SOUBROUTINE FOR AFM
20320        subroutine AFMvel(Eafmforce)
20321        use MD_data, only:totTafm
20322       real(kind=8),dimension(3) :: diffafm
20323       real(kind=8) :: afmdist,Eafmforce
20324        integer :: i
20325 !C Only for check grad COMMENT if not used for checkgrad
20326 !C      totT=3.0d0
20327 !C--------------------------------------------------------
20328 !C      print *,"wchodze"
20329       afmdist=0.0d0
20330       Eafmforce=0.0d0
20331       do i=1,3
20332       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20333       afmdist=afmdist+diffafm(i)**2
20334       enddo
20335       afmdist=dsqrt(afmdist)
20336 !      totTafm=3.0
20337       Eafmforce=0.5d0*forceAFMconst &
20338       *(distafminit+totTafm*velAFMconst-afmdist)**2
20339 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20340       do i=1,3
20341       gradafm(i,afmend-1)=-forceAFMconst* &
20342        (distafminit+totTafm*velAFMconst-afmdist) &
20343        *diffafm(i)/afmdist
20344       gradafm(i,afmbeg-1)=forceAFMconst* &
20345       (distafminit+totTafm*velAFMconst-afmdist) &
20346       *diffafm(i)/afmdist
20347       enddo
20348 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20349       return
20350       end subroutine AFMvel
20351 !---------------------------------------------------------
20352        subroutine AFMforce(Eafmforce)
20353
20354       real(kind=8),dimension(3) :: diffafm
20355 !      real(kind=8) ::afmdist
20356       real(kind=8) :: afmdist,Eafmforce
20357       integer :: i
20358       afmdist=0.0d0
20359       Eafmforce=0.0d0
20360       do i=1,3
20361       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20362       afmdist=afmdist+diffafm(i)**2
20363       enddo
20364       afmdist=dsqrt(afmdist)
20365 !      print *,afmdist,distafminit
20366       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20367       do i=1,3
20368       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20369       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20370       enddo
20371 !C      print *,'AFM',Eafmforce
20372       return
20373       end subroutine AFMforce
20374
20375 !-----------------------------------------------------------------------------
20376 #ifdef WHAM
20377       subroutine read_ssHist
20378 !      implicit none
20379 !      Includes
20380 !      include 'DIMENSIONS'
20381 !      include "DIMENSIONS.FREE"
20382 !      include 'COMMON.FREE'
20383 !     Local variables
20384       integer :: i,j
20385       character(len=80) :: controlcard
20386
20387       do i=1,dyn_nssHist
20388         call card_concat(controlcard,.true.)
20389         read(controlcard,*) &
20390              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20391       enddo
20392
20393       return
20394       end subroutine read_ssHist
20395 #endif
20396 !-----------------------------------------------------------------------------
20397       integer function indmat(i,j)
20398 !el
20399 ! get the position of the jth ijth fragment of the chain coordinate system
20400 ! in the fromto array.
20401         integer :: i,j
20402
20403         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20404       return
20405       end function indmat
20406 !-----------------------------------------------------------------------------
20407       real(kind=8) function sigm(x)
20408 !el
20409        real(kind=8) :: x
20410         sigm=0.25d0*x
20411       return
20412       end function sigm
20413 !-----------------------------------------------------------------------------
20414 !-----------------------------------------------------------------------------
20415       subroutine alloc_ener_arrays
20416 !EL Allocation of arrays used by module energy
20417       use MD_data, only: mset
20418 !el local variables
20419       integer :: i,j
20420
20421       if(nres.lt.100) then
20422         maxconts=10*nres
20423       elseif(nres.lt.200) then
20424         maxconts=10*nres      ! Max. number of contacts per residue
20425       else
20426         maxconts=10*nres ! (maxconts=maxres/4)
20427       endif
20428       maxcont=12*nres      ! Max. number of SC contacts
20429       maxvar=6*nres      ! Max. number of variables
20430 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20431       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20432 !----------------------
20433 ! arrays in subroutine init_int_table
20434 !el#ifdef MPI
20435 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20436 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20437 !el#endif
20438       allocate(nint_gr(nres))
20439       allocate(nscp_gr(nres))
20440       allocate(ielstart(nres))
20441       allocate(ielend(nres))
20442 !(maxres)
20443       allocate(istart(nres,maxint_gr))
20444       allocate(iend(nres,maxint_gr))
20445 !(maxres,maxint_gr)
20446       allocate(iscpstart(nres,maxint_gr))
20447       allocate(iscpend(nres,maxint_gr))
20448 !(maxres,maxint_gr)
20449       allocate(ielstart_vdw(nres))
20450       allocate(ielend_vdw(nres))
20451 !(maxres)
20452       allocate(nint_gr_nucl(nres))
20453       allocate(nscp_gr_nucl(nres))
20454       allocate(ielstart_nucl(nres))
20455       allocate(ielend_nucl(nres))
20456 !(maxres)
20457       allocate(istart_nucl(nres,maxint_gr))
20458       allocate(iend_nucl(nres,maxint_gr))
20459 !(maxres,maxint_gr)
20460       allocate(iscpstart_nucl(nres,maxint_gr))
20461       allocate(iscpend_nucl(nres,maxint_gr))
20462 !(maxres,maxint_gr)
20463       allocate(ielstart_vdw_nucl(nres))
20464       allocate(ielend_vdw_nucl(nres))
20465
20466       allocate(lentyp(0:nfgtasks-1))
20467 !(0:maxprocs-1)
20468 !----------------------
20469 ! commom.contacts
20470 !      common /contacts/
20471       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20472       allocate(icont(2,maxcont))
20473 !(2,maxcont)
20474 !      common /contacts1/
20475       allocate(num_cont(0:nres+4))
20476 !(maxres)
20477       allocate(jcont(maxconts,nres))
20478 !(maxconts,maxres)
20479       allocate(facont(maxconts,nres))
20480 !(maxconts,maxres)
20481       allocate(gacont(3,maxconts,nres))
20482 !(3,maxconts,maxres)
20483 !      common /contacts_hb/
20484       allocate(gacontp_hb1(3,maxconts,nres))
20485       allocate(gacontp_hb2(3,maxconts,nres))
20486       allocate(gacontp_hb3(3,maxconts,nres))
20487       allocate(gacontm_hb1(3,maxconts,nres))
20488       allocate(gacontm_hb2(3,maxconts,nres))
20489       allocate(gacontm_hb3(3,maxconts,nres))
20490       allocate(gacont_hbr(3,maxconts,nres))
20491       allocate(grij_hb_cont(3,maxconts,nres))
20492 !(3,maxconts,maxres)
20493       allocate(facont_hb(maxconts,nres))
20494
20495       allocate(ees0p(maxconts,nres))
20496       allocate(ees0m(maxconts,nres))
20497       allocate(d_cont(maxconts,nres))
20498       allocate(ees0plist(maxconts,nres))
20499
20500 !(maxconts,maxres)
20501       allocate(num_cont_hb(nres))
20502 !(maxres)
20503       allocate(jcont_hb(maxconts,nres))
20504 !(maxconts,maxres)
20505 !      common /rotat/
20506       allocate(Ug(2,2,nres))
20507       allocate(Ugder(2,2,nres))
20508       allocate(Ug2(2,2,nres))
20509       allocate(Ug2der(2,2,nres))
20510 !(2,2,maxres)
20511       allocate(obrot(2,nres))
20512       allocate(obrot2(2,nres))
20513       allocate(obrot_der(2,nres))
20514       allocate(obrot2_der(2,nres))
20515 !(2,maxres)
20516 !      common /precomp1/
20517       allocate(mu(2,nres))
20518       allocate(muder(2,nres))
20519       allocate(Ub2(2,nres))
20520       Ub2(1,:)=0.0d0
20521       Ub2(2,:)=0.0d0
20522       allocate(Ub2der(2,nres))
20523       allocate(Ctobr(2,nres))
20524       allocate(Ctobrder(2,nres))
20525       allocate(Dtobr2(2,nres))
20526       allocate(Dtobr2der(2,nres))
20527 !(2,maxres)
20528       allocate(EUg(2,2,nres))
20529       allocate(EUgder(2,2,nres))
20530       allocate(CUg(2,2,nres))
20531       allocate(CUgder(2,2,nres))
20532       allocate(DUg(2,2,nres))
20533       allocate(Dugder(2,2,nres))
20534       allocate(DtUg2(2,2,nres))
20535       allocate(DtUg2der(2,2,nres))
20536 !(2,2,maxres)
20537 !      common /precomp2/
20538       allocate(Ug2Db1t(2,nres))
20539       allocate(Ug2Db1tder(2,nres))
20540       allocate(CUgb2(2,nres))
20541       allocate(CUgb2der(2,nres))
20542 !(2,maxres)
20543       allocate(EUgC(2,2,nres))
20544       allocate(EUgCder(2,2,nres))
20545       allocate(EUgD(2,2,nres))
20546       allocate(EUgDder(2,2,nres))
20547       allocate(DtUg2EUg(2,2,nres))
20548       allocate(Ug2DtEUg(2,2,nres))
20549 !(2,2,maxres)
20550       allocate(Ug2DtEUgder(2,2,2,nres))
20551       allocate(DtUg2EUgder(2,2,2,nres))
20552 !(2,2,2,maxres)
20553       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20554       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20555       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20556       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20557
20558       allocate(ctilde(2,2,nres))
20559       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20560       allocate(gtb1(2,nres))
20561       allocate(gtb2(2,nres))
20562       allocate(cc(2,2,nres))
20563       allocate(dd(2,2,nres))
20564       allocate(ee(2,2,nres))
20565       allocate(gtcc(2,2,nres))
20566       allocate(gtdd(2,2,nres))
20567       allocate(gtee(2,2,nres))
20568       allocate(gUb2(2,nres))
20569       allocate(gteUg(2,2,nres))
20570
20571 !      common /rotat_old/
20572       allocate(costab(nres))
20573       allocate(sintab(nres))
20574       allocate(costab2(nres))
20575       allocate(sintab2(nres))
20576 !(maxres)
20577 !      common /dipmat/
20578       allocate(a_chuj(2,2,maxconts,nres))
20579 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20580       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20581 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20582 !      common /contdistrib/
20583       allocate(ncont_sent(nres))
20584       allocate(ncont_recv(nres))
20585
20586       allocate(iat_sent(nres))
20587 !(maxres)
20588       allocate(iint_sent(4,nres,nres))
20589       allocate(iint_sent_local(4,nres,nres))
20590 !(4,maxres,maxres)
20591       allocate(iturn3_sent(4,0:nres+4))
20592       allocate(iturn4_sent(4,0:nres+4))
20593       allocate(iturn3_sent_local(4,nres))
20594       allocate(iturn4_sent_local(4,nres))
20595 !(4,maxres)
20596       allocate(itask_cont_from(0:nfgtasks-1))
20597       allocate(itask_cont_to(0:nfgtasks-1))
20598 !(0:max_fg_procs-1)
20599
20600
20601
20602 !----------------------
20603 ! commom.deriv;
20604 !      common /derivat/
20605       allocate(dcdv(6,maxdim))
20606       allocate(dxdv(6,maxdim))
20607 !(6,maxdim)
20608       allocate(dxds(6,nres))
20609 !(6,maxres)
20610       allocate(gradx(3,-1:nres,0:2))
20611       allocate(gradc(3,-1:nres,0:2))
20612 !(3,maxres,2)
20613       allocate(gvdwx(3,-1:nres))
20614       allocate(gvdwc(3,-1:nres))
20615       allocate(gelc(3,-1:nres))
20616       allocate(gelc_long(3,-1:nres))
20617       allocate(gvdwpp(3,-1:nres))
20618       allocate(gvdwc_scpp(3,-1:nres))
20619       allocate(gradx_scp(3,-1:nres))
20620       allocate(gvdwc_scp(3,-1:nres))
20621       allocate(ghpbx(3,-1:nres))
20622       allocate(ghpbc(3,-1:nres))
20623       allocate(gradcorr(3,-1:nres))
20624       allocate(gradcorr_long(3,-1:nres))
20625       allocate(gradcorr5_long(3,-1:nres))
20626       allocate(gradcorr6_long(3,-1:nres))
20627       allocate(gcorr6_turn_long(3,-1:nres))
20628       allocate(gradxorr(3,-1:nres))
20629       allocate(gradcorr5(3,-1:nres))
20630       allocate(gradcorr6(3,-1:nres))
20631       allocate(gliptran(3,-1:nres))
20632       allocate(gliptranc(3,-1:nres))
20633       allocate(gliptranx(3,-1:nres))
20634       allocate(gshieldx(3,-1:nres))
20635       allocate(gshieldc(3,-1:nres))
20636       allocate(gshieldc_loc(3,-1:nres))
20637       allocate(gshieldx_ec(3,-1:nres))
20638       allocate(gshieldc_ec(3,-1:nres))
20639       allocate(gshieldc_loc_ec(3,-1:nres))
20640       allocate(gshieldx_t3(3,-1:nres))
20641       allocate(gshieldc_t3(3,-1:nres))
20642       allocate(gshieldc_loc_t3(3,-1:nres))
20643       allocate(gshieldx_t4(3,-1:nres))
20644       allocate(gshieldc_t4(3,-1:nres))
20645       allocate(gshieldc_loc_t4(3,-1:nres))
20646       allocate(gshieldx_ll(3,-1:nres))
20647       allocate(gshieldc_ll(3,-1:nres))
20648       allocate(gshieldc_loc_ll(3,-1:nres))
20649       allocate(grad_shield(3,-1:nres))
20650       allocate(gg_tube_sc(3,-1:nres))
20651       allocate(gg_tube(3,-1:nres))
20652       allocate(gradafm(3,-1:nres))
20653       allocate(gradb_nucl(3,-1:nres))
20654       allocate(gradbx_nucl(3,-1:nres))
20655       allocate(gvdwpsb1(3,-1:nres))
20656       allocate(gelpp(3,-1:nres))
20657       allocate(gvdwpsb(3,-1:nres))
20658       allocate(gelsbc(3,-1:nres))
20659       allocate(gelsbx(3,-1:nres))
20660       allocate(gvdwsbx(3,-1:nres))
20661       allocate(gvdwsbc(3,-1:nres))
20662       allocate(gsbloc(3,-1:nres))
20663       allocate(gsblocx(3,-1:nres))
20664       allocate(gradcorr_nucl(3,-1:nres))
20665       allocate(gradxorr_nucl(3,-1:nres))
20666       allocate(gradcorr3_nucl(3,-1:nres))
20667       allocate(gradxorr3_nucl(3,-1:nres))
20668       allocate(gvdwpp_nucl(3,-1:nres))
20669       allocate(gradpepcat(3,-1:nres))
20670       allocate(gradpepcatx(3,-1:nres))
20671       allocate(gradcatcat(3,-1:nres))
20672 !(3,maxres)
20673       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20674       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20675 ! grad for shielding surroing
20676       allocate(gloc(0:maxvar,0:2))
20677       allocate(gloc_x(0:maxvar,2))
20678 !(maxvar,2)
20679       allocate(gel_loc(3,-1:nres))
20680       allocate(gel_loc_long(3,-1:nres))
20681       allocate(gcorr3_turn(3,-1:nres))
20682       allocate(gcorr4_turn(3,-1:nres))
20683       allocate(gcorr6_turn(3,-1:nres))
20684       allocate(gradb(3,-1:nres))
20685       allocate(gradbx(3,-1:nres))
20686 !(3,maxres)
20687       allocate(gel_loc_loc(maxvar))
20688       allocate(gel_loc_turn3(maxvar))
20689       allocate(gel_loc_turn4(maxvar))
20690       allocate(gel_loc_turn6(maxvar))
20691       allocate(gcorr_loc(maxvar))
20692       allocate(g_corr5_loc(maxvar))
20693       allocate(g_corr6_loc(maxvar))
20694 !(maxvar)
20695       allocate(gsccorc(3,-1:nres))
20696       allocate(gsccorx(3,-1:nres))
20697 !(3,maxres)
20698       allocate(gsccor_loc(-1:nres))
20699 !(maxres)
20700       allocate(gvdwx_scbase(3,-1:nres))
20701       allocate(gvdwc_scbase(3,-1:nres))
20702       allocate(gvdwx_pepbase(3,-1:nres))
20703       allocate(gvdwc_pepbase(3,-1:nres))
20704       allocate(gvdwx_scpho(3,-1:nres))
20705       allocate(gvdwc_scpho(3,-1:nres))
20706       allocate(gvdwc_peppho(3,-1:nres))
20707
20708       allocate(dtheta(3,2,-1:nres))
20709 !(3,2,maxres)
20710       allocate(gscloc(3,-1:nres))
20711       allocate(gsclocx(3,-1:nres))
20712 !(3,maxres)
20713       allocate(dphi(3,3,-1:nres))
20714       allocate(dalpha(3,3,-1:nres))
20715       allocate(domega(3,3,-1:nres))
20716 !(3,3,maxres)
20717 !      common /deriv_scloc/
20718       allocate(dXX_C1tab(3,nres))
20719       allocate(dYY_C1tab(3,nres))
20720       allocate(dZZ_C1tab(3,nres))
20721       allocate(dXX_Ctab(3,nres))
20722       allocate(dYY_Ctab(3,nres))
20723       allocate(dZZ_Ctab(3,nres))
20724       allocate(dXX_XYZtab(3,nres))
20725       allocate(dYY_XYZtab(3,nres))
20726       allocate(dZZ_XYZtab(3,nres))
20727 !(3,maxres)
20728 !      common /mpgrad/
20729       allocate(jgrad_start(nres))
20730       allocate(jgrad_end(nres))
20731 !(maxres)
20732 !----------------------
20733
20734 !      common /indices/
20735       allocate(ibond_displ(0:nfgtasks-1))
20736       allocate(ibond_count(0:nfgtasks-1))
20737       allocate(ithet_displ(0:nfgtasks-1))
20738       allocate(ithet_count(0:nfgtasks-1))
20739       allocate(iphi_displ(0:nfgtasks-1))
20740       allocate(iphi_count(0:nfgtasks-1))
20741       allocate(iphi1_displ(0:nfgtasks-1))
20742       allocate(iphi1_count(0:nfgtasks-1))
20743       allocate(ivec_displ(0:nfgtasks-1))
20744       allocate(ivec_count(0:nfgtasks-1))
20745       allocate(iset_displ(0:nfgtasks-1))
20746       allocate(iset_count(0:nfgtasks-1))
20747       allocate(iint_count(0:nfgtasks-1))
20748       allocate(iint_displ(0:nfgtasks-1))
20749 !(0:max_fg_procs-1)
20750 !----------------------
20751 ! common.MD
20752 !      common /mdgrad/
20753       allocate(gcart(3,-1:nres))
20754       allocate(gxcart(3,-1:nres))
20755 !(3,0:MAXRES)
20756       allocate(gradcag(3,-1:nres))
20757       allocate(gradxag(3,-1:nres))
20758 !(3,MAXRES)
20759 !      common /back_constr/
20760 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20761       allocate(dutheta(nres))
20762       allocate(dugamma(nres))
20763 !(maxres)
20764       allocate(duscdiff(3,nres))
20765       allocate(duscdiffx(3,nres))
20766 !(3,maxres)
20767 !el i io:read_fragments
20768 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20769 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20770 !      common /qmeas/
20771 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20772 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20773       allocate(mset(0:nprocs))  !(maxprocs/20)
20774       mset(:)=0
20775 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20776 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20777       allocate(dUdconst(3,0:nres))
20778       allocate(dUdxconst(3,0:nres))
20779       allocate(dqwol(3,0:nres))
20780       allocate(dxqwol(3,0:nres))
20781 !(3,0:MAXRES)
20782 !----------------------
20783 ! common.sbridge
20784 !      common /sbridge/ in io_common: read_bridge
20785 !el    allocate((:),allocatable :: iss      !(maxss)
20786 !      common /links/  in io_common: read_bridge
20787 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20788 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20789 !      common /dyn_ssbond/
20790 ! and side-chain vectors in theta or phi.
20791       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20792 !(maxres,maxres)
20793 !      do i=1,nres
20794 !        do j=i+1,nres
20795       dyn_ssbond_ij(:,:)=1.0d300
20796 !        enddo
20797 !      enddo
20798
20799 !      if (nss.gt.0) then
20800         allocate(idssb(maxdim),jdssb(maxdim))
20801 !        allocate(newihpb(nss),newjhpb(nss))
20802 !(maxdim)
20803 !      endif
20804       allocate(ishield_list(-1:nres))
20805       allocate(shield_list(maxcontsshi,-1:nres))
20806       allocate(dyn_ss_mask(nres))
20807       allocate(fac_shield(-1:nres))
20808       allocate(enetube(nres*2))
20809       allocate(enecavtube(nres*2))
20810
20811 !(maxres)
20812       dyn_ss_mask(:)=.false.
20813 !----------------------
20814 ! common.sccor
20815 ! Parameters of the SCCOR term
20816 !      common/sccor/
20817 !el in io_conf: parmread
20818 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20819 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20820 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20821 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20822 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20823 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20824 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20825 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20826 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20827 !----------------
20828       allocate(gloc_sc(3,0:2*nres,0:10))
20829 !(3,0:maxres2,10)maxres2=2*maxres
20830       allocate(dcostau(3,3,3,2*nres))
20831       allocate(dsintau(3,3,3,2*nres))
20832       allocate(dtauangle(3,3,3,2*nres))
20833       allocate(dcosomicron(3,3,3,2*nres))
20834       allocate(domicron(3,3,3,2*nres))
20835 !(3,3,3,maxres2)maxres2=2*maxres
20836 !----------------------
20837 ! common.var
20838 !      common /restr/
20839       allocate(varall(maxvar))
20840 !(maxvar)(maxvar=6*maxres)
20841       allocate(mask_theta(nres))
20842       allocate(mask_phi(nres))
20843       allocate(mask_side(nres))
20844 !(maxres)
20845 !----------------------
20846 ! common.vectors
20847 !      common /vectors/
20848       allocate(uy(3,nres))
20849       allocate(uz(3,nres))
20850 !(3,maxres)
20851       allocate(uygrad(3,3,2,nres))
20852       allocate(uzgrad(3,3,2,nres))
20853 !(3,3,2,maxres)
20854
20855       return
20856       end subroutine alloc_ener_arrays
20857 !-----------------------------------------------------------------
20858       subroutine ebond_nucl(estr_nucl)
20859 !c
20860 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20861 !c
20862
20863       real(kind=8),dimension(3) :: u,ud
20864       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20865       real(kind=8) :: estr_nucl,diff
20866       integer :: iti,i,j,k,nbi
20867       estr_nucl=0.0d0
20868 !C      print *,"I enter ebond"
20869       if (energy_dec) &
20870       write (iout,*) "ibondp_start,ibondp_end",&
20871        ibondp_nucl_start,ibondp_nucl_end
20872       do i=ibondp_nucl_start,ibondp_nucl_end
20873         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20874          itype(i,2).eq.ntyp1_molec(2)) cycle
20875 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20876 !          do j=1,3
20877 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20878 !     &      *dc(j,i-1)/vbld(i)
20879 !          enddo
20880 !          if (energy_dec) write(iout,*)
20881 !     &       "estr1",i,vbld(i),distchainmax,
20882 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20883
20884           diff = vbld(i)-vbldp0_nucl
20885           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20886           vbldp0_nucl,diff,AKP_nucl*diff*diff
20887           estr_nucl=estr_nucl+diff*diff
20888 !          print *,estr_nucl
20889           do j=1,3
20890             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20891           enddo
20892 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20893       enddo
20894       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20895 !      print *,"partial sum", estr_nucl,AKP_nucl
20896
20897       if (energy_dec) &
20898       write (iout,*) "ibondp_start,ibondp_end",&
20899        ibond_nucl_start,ibond_nucl_end
20900
20901       do i=ibond_nucl_start,ibond_nucl_end
20902 !C        print *, "I am stuck",i
20903         iti=itype(i,2)
20904         if (iti.eq.ntyp1_molec(2)) cycle
20905           nbi=nbondterm_nucl(iti)
20906 !C        print *,iti,nbi
20907           if (nbi.eq.1) then
20908             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20909
20910             if (energy_dec) &
20911            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20912            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20913             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20914 !            print *,estr_nucl
20915             do j=1,3
20916               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20917             enddo
20918           else
20919             do j=1,nbi
20920               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20921               ud(j)=aksc_nucl(j,iti)*diff
20922               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20923             enddo
20924             uprod=u(1)
20925             do j=2,nbi
20926               uprod=uprod*u(j)
20927             enddo
20928             usum=0.0d0
20929             usumsqder=0.0d0
20930             do j=1,nbi
20931               uprod1=1.0d0
20932               uprod2=1.0d0
20933               do k=1,nbi
20934                 if (k.ne.j) then
20935                   uprod1=uprod1*u(k)
20936                   uprod2=uprod2*u(k)*u(k)
20937                 endif
20938               enddo
20939               usum=usum+uprod1
20940               usumsqder=usumsqder+ud(j)*uprod2
20941             enddo
20942             estr_nucl=estr_nucl+uprod/usum
20943             do j=1,3
20944              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20945             enddo
20946         endif
20947       enddo
20948 !C      print *,"I am about to leave ebond"
20949       return
20950       end subroutine ebond_nucl
20951
20952 !-----------------------------------------------------------------------------
20953       subroutine ebend_nucl(etheta_nucl)
20954       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20955       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20956       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20957       logical :: lprn=.false., lprn1=.false.
20958 !el local variables
20959       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20960       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20961       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20962 ! local variables for constrains
20963       real(kind=8) :: difi,thetiii
20964        integer itheta
20965       etheta_nucl=0.0D0
20966 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20967       do i=ithet_nucl_start,ithet_nucl_end
20968         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20969         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20970         (itype(i,2).eq.ntyp1_molec(2))) cycle
20971         dethetai=0.0d0
20972         dephii=0.0d0
20973         dephii1=0.0d0
20974         theti2=0.5d0*theta(i)
20975         ityp2=ithetyp_nucl(itype(i-1,2))
20976         do k=1,nntheterm_nucl
20977           coskt(k)=dcos(k*theti2)
20978           sinkt(k)=dsin(k*theti2)
20979         enddo
20980         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20981 #ifdef OSF
20982           phii=phi(i)
20983           if (phii.ne.phii) phii=150.0
20984 #else
20985           phii=phi(i)
20986 #endif
20987           ityp1=ithetyp_nucl(itype(i-2,2))
20988           do k=1,nsingle_nucl
20989             cosph1(k)=dcos(k*phii)
20990             sinph1(k)=dsin(k*phii)
20991           enddo
20992         else
20993           phii=0.0d0
20994           ityp1=nthetyp_nucl+1
20995           do k=1,nsingle_nucl
20996             cosph1(k)=0.0d0
20997             sinph1(k)=0.0d0
20998           enddo
20999         endif
21000
21001         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21002 #ifdef OSF
21003           phii1=phi(i+1)
21004           if (phii1.ne.phii1) phii1=150.0
21005           phii1=pinorm(phii1)
21006 #else
21007           phii1=phi(i+1)
21008 #endif
21009           ityp3=ithetyp_nucl(itype(i,2))
21010           do k=1,nsingle_nucl
21011             cosph2(k)=dcos(k*phii1)
21012             sinph2(k)=dsin(k*phii1)
21013           enddo
21014         else
21015           phii1=0.0d0
21016           ityp3=nthetyp_nucl+1
21017           do k=1,nsingle_nucl
21018             cosph2(k)=0.0d0
21019             sinph2(k)=0.0d0
21020           enddo
21021         endif
21022         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21023         do k=1,ndouble_nucl
21024           do l=1,k-1
21025             ccl=cosph1(l)*cosph2(k-l)
21026             ssl=sinph1(l)*sinph2(k-l)
21027             scl=sinph1(l)*cosph2(k-l)
21028             csl=cosph1(l)*sinph2(k-l)
21029             cosph1ph2(l,k)=ccl-ssl
21030             cosph1ph2(k,l)=ccl+ssl
21031             sinph1ph2(l,k)=scl+csl
21032             sinph1ph2(k,l)=scl-csl
21033           enddo
21034         enddo
21035         if (lprn) then
21036         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21037          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21038         write (iout,*) "coskt and sinkt",nntheterm_nucl
21039         do k=1,nntheterm_nucl
21040           write (iout,*) k,coskt(k),sinkt(k)
21041         enddo
21042         endif
21043         do k=1,ntheterm_nucl
21044           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21045           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21046            *coskt(k)
21047           if (lprn)&
21048          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21049           " ethetai",ethetai
21050         enddo
21051         if (lprn) then
21052         write (iout,*) "cosph and sinph"
21053         do k=1,nsingle_nucl
21054           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21055         enddo
21056         write (iout,*) "cosph1ph2 and sinph2ph2"
21057         do k=2,ndouble_nucl
21058           do l=1,k-1
21059             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21060               sinph1ph2(l,k),sinph1ph2(k,l)
21061           enddo
21062         enddo
21063         write(iout,*) "ethetai",ethetai
21064         endif
21065         do m=1,ntheterm2_nucl
21066           do k=1,nsingle_nucl
21067             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21068               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21069               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21070               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21071             ethetai=ethetai+sinkt(m)*aux
21072             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21073             dephii=dephii+k*sinkt(m)*(&
21074                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21075                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21076             dephii1=dephii1+k*sinkt(m)*(&
21077                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21078                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21079             if (lprn) &
21080            write (iout,*) "m",m," k",k," bbthet",&
21081               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21082               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21083               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21084               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21085           enddo
21086         enddo
21087         if (lprn) &
21088         write(iout,*) "ethetai",ethetai
21089         do m=1,ntheterm3_nucl
21090           do k=2,ndouble_nucl
21091             do l=1,k-1
21092               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21093                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21094                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21095                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21096               ethetai=ethetai+sinkt(m)*aux
21097               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21098               dephii=dephii+l*sinkt(m)*(&
21099                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21100                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21101                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21102                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21103               dephii1=dephii1+(k-l)*sinkt(m)*( &
21104                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21105                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21106                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21107                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21108               if (lprn) then
21109               write (iout,*) "m",m," k",k," l",l," ffthet", &
21110                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21111                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21112                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21113                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21114               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21115                  cosph1ph2(k,l)*sinkt(m),&
21116                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21117               endif
21118             enddo
21119           enddo
21120         enddo
21121 10      continue
21122         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21123         i,theta(i)*rad2deg,phii*rad2deg, &
21124         phii1*rad2deg,ethetai
21125         etheta_nucl=etheta_nucl+ethetai
21126 !        print *,i,"partial sum",etheta_nucl
21127         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21128         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21129         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21130       enddo
21131       return
21132       end subroutine ebend_nucl
21133 !----------------------------------------------------
21134       subroutine etor_nucl(etors_nucl)
21135 !      implicit real*8 (a-h,o-z)
21136 !      include 'DIMENSIONS'
21137 !      include 'COMMON.VAR'
21138 !      include 'COMMON.GEO'
21139 !      include 'COMMON.LOCAL'
21140 !      include 'COMMON.TORSION'
21141 !      include 'COMMON.INTERACT'
21142 !      include 'COMMON.DERIV'
21143 !      include 'COMMON.CHAIN'
21144 !      include 'COMMON.NAMES'
21145 !      include 'COMMON.IOUNITS'
21146 !      include 'COMMON.FFIELD'
21147 !      include 'COMMON.TORCNSTR'
21148 !      include 'COMMON.CONTROL'
21149       real(kind=8) :: etors_nucl,edihcnstr
21150       logical :: lprn
21151 !el local variables
21152       integer :: i,j,iblock,itori,itori1
21153       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21154                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21155 ! Set lprn=.true. for debugging
21156       lprn=.false.
21157 !     lprn=.true.
21158       etors_nucl=0.0D0
21159 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21160       do i=iphi_nucl_start,iphi_nucl_end
21161         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21162              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21163              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21164         etors_ii=0.0D0
21165         itori=itortyp_nucl(itype(i-2,2))
21166         itori1=itortyp_nucl(itype(i-1,2))
21167         phii=phi(i)
21168 !         print *,i,itori,itori1
21169         gloci=0.0D0
21170 !C Regular cosine and sine terms
21171         do j=1,nterm_nucl(itori,itori1)
21172           v1ij=v1_nucl(j,itori,itori1)
21173           v2ij=v2_nucl(j,itori,itori1)
21174           cosphi=dcos(j*phii)
21175           sinphi=dsin(j*phii)
21176           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21177           if (energy_dec) etors_ii=etors_ii+&
21178                      v1ij*cosphi+v2ij*sinphi
21179           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21180         enddo
21181 !C Lorentz terms
21182 !C                         v1
21183 !C  E = SUM ----------------------------------- - v1
21184 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21185 !C
21186         cosphi=dcos(0.5d0*phii)
21187         sinphi=dsin(0.5d0*phii)
21188         do j=1,nlor_nucl(itori,itori1)
21189           vl1ij=vlor1_nucl(j,itori,itori1)
21190           vl2ij=vlor2_nucl(j,itori,itori1)
21191           vl3ij=vlor3_nucl(j,itori,itori1)
21192           pom=vl2ij*cosphi+vl3ij*sinphi
21193           pom1=1.0d0/(pom*pom+1.0d0)
21194           etors_nucl=etors_nucl+vl1ij*pom1
21195           if (energy_dec) etors_ii=etors_ii+ &
21196                      vl1ij*pom1
21197           pom=-pom*pom1*pom1
21198           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21199         enddo
21200 !C Subtract the constant term
21201         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21202           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21203               'etor',i,etors_ii-v0_nucl(itori,itori1)
21204         if (lprn) &
21205        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21206        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21207        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21208         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21209 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21210       enddo
21211       return
21212       end subroutine etor_nucl
21213 !------------------------------------------------------------
21214       subroutine epp_nucl_sub(evdw1,ees)
21215 !C
21216 !C This subroutine calculates the average interaction energy and its gradient
21217 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21218 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21219 !C The potential depends both on the distance of peptide-group centers and on
21220 !C the orientation of the CA-CA virtual bonds.
21221 !C
21222       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21223       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21224       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21225                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21226                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21227       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21228                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21229       integer xshift,yshift,zshift
21230       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21231       real(kind=8) :: ees,eesij
21232 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21233       real(kind=8) scal_el /0.5d0/
21234       t_eelecij=0.0d0
21235       ees=0.0D0
21236       evdw1=0.0D0
21237       ind=0
21238 !c
21239 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21240 !c
21241 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21242       do i=iatel_s_nucl,iatel_e_nucl
21243         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21244         dxi=dc(1,i)
21245         dyi=dc(2,i)
21246         dzi=dc(3,i)
21247         dx_normi=dc_norm(1,i)
21248         dy_normi=dc_norm(2,i)
21249         dz_normi=dc_norm(3,i)
21250         xmedi=c(1,i)+0.5d0*dxi
21251         ymedi=c(2,i)+0.5d0*dyi
21252         zmedi=c(3,i)+0.5d0*dzi
21253           xmedi=dmod(xmedi,boxxsize)
21254           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21255           ymedi=dmod(ymedi,boxysize)
21256           if (ymedi.lt.0) ymedi=ymedi+boxysize
21257           zmedi=dmod(zmedi,boxzsize)
21258           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21259
21260         do j=ielstart_nucl(i),ielend_nucl(i)
21261           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21262           ind=ind+1
21263           dxj=dc(1,j)
21264           dyj=dc(2,j)
21265           dzj=dc(3,j)
21266 !          xj=c(1,j)+0.5D0*dxj-xmedi
21267 !          yj=c(2,j)+0.5D0*dyj-ymedi
21268 !          zj=c(3,j)+0.5D0*dzj-zmedi
21269           xj=c(1,j)+0.5D0*dxj
21270           yj=c(2,j)+0.5D0*dyj
21271           zj=c(3,j)+0.5D0*dzj
21272           xj=mod(xj,boxxsize)
21273           if (xj.lt.0) xj=xj+boxxsize
21274           yj=mod(yj,boxysize)
21275           if (yj.lt.0) yj=yj+boxysize
21276           zj=mod(zj,boxzsize)
21277           if (zj.lt.0) zj=zj+boxzsize
21278       isubchap=0
21279       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21280       xj_safe=xj
21281       yj_safe=yj
21282       zj_safe=zj
21283       do xshift=-1,1
21284       do yshift=-1,1
21285       do zshift=-1,1
21286           xj=xj_safe+xshift*boxxsize
21287           yj=yj_safe+yshift*boxysize
21288           zj=zj_safe+zshift*boxzsize
21289           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21290           if(dist_temp.lt.dist_init) then
21291             dist_init=dist_temp
21292             xj_temp=xj
21293             yj_temp=yj
21294             zj_temp=zj
21295             isubchap=1
21296           endif
21297        enddo
21298        enddo
21299        enddo
21300        if (isubchap.eq.1) then
21301 !C          print *,i,j
21302           xj=xj_temp-xmedi
21303           yj=yj_temp-ymedi
21304           zj=zj_temp-zmedi
21305        else
21306           xj=xj_safe-xmedi
21307           yj=yj_safe-ymedi
21308           zj=zj_safe-zmedi
21309        endif
21310
21311           rij=xj*xj+yj*yj+zj*zj
21312 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21313           fac=(r0pp**2/rij)**3
21314           ev1=epspp*fac*fac
21315           ev2=epspp*fac
21316           evdw1ij=ev1-2*ev2
21317           fac=(-ev1-evdw1ij)/rij
21318 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21319           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21320           evdw1=evdw1+evdw1ij
21321 !C
21322 !C Calculate contributions to the Cartesian gradient.
21323 !C
21324           ggg(1)=fac*xj
21325           ggg(2)=fac*yj
21326           ggg(3)=fac*zj
21327           do k=1,3
21328             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21329             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21330           enddo
21331 !c phoshate-phosphate electrostatic interactions
21332           rij=dsqrt(rij)
21333           fac=1.0d0/rij
21334           eesij=dexp(-BEES*rij)*fac
21335 !          write (2,*)"fac",fac," eesijpp",eesij
21336           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21337           ees=ees+eesij
21338 !c          fac=-eesij*fac
21339           fac=-(fac+BEES)*eesij*fac
21340           ggg(1)=fac*xj
21341           ggg(2)=fac*yj
21342           ggg(3)=fac*zj
21343 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21344 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21345 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21346           do k=1,3
21347             gelpp(k,i)=gelpp(k,i)-ggg(k)
21348             gelpp(k,j)=gelpp(k,j)+ggg(k)
21349           enddo
21350         enddo ! j
21351       enddo   ! i
21352 !c      ees=332.0d0*ees
21353       ees=AEES*ees
21354       do i=nnt,nct
21355 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21356         do k=1,3
21357           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21358 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21359           gelpp(k,i)=AEES*gelpp(k,i)
21360         enddo
21361 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21362       enddo
21363 !c      write (2,*) "total EES",ees
21364       return
21365       end subroutine epp_nucl_sub
21366 !---------------------------------------------------------------------
21367       subroutine epsb(evdwpsb,eelpsb)
21368 !      use comm_locel
21369 !C
21370 !C This subroutine calculates the excluded-volume interaction energy between
21371 !C peptide-group centers and side chains and its gradient in virtual-bond and
21372 !C side-chain vectors.
21373 !C
21374       real(kind=8),dimension(3):: ggg
21375       integer :: i,iint,j,k,iteli,itypj,subchap
21376       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21377                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21378       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21379                     dist_temp, dist_init
21380       integer xshift,yshift,zshift
21381
21382 !cd    print '(a)','Enter ESCP'
21383 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21384       eelpsb=0.0d0
21385       evdwpsb=0.0d0
21386 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21387       do i=iatscp_s_nucl,iatscp_e_nucl
21388         if (itype(i,2).eq.ntyp1_molec(2) &
21389          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21390         xi=0.5D0*(c(1,i)+c(1,i+1))
21391         yi=0.5D0*(c(2,i)+c(2,i+1))
21392         zi=0.5D0*(c(3,i)+c(3,i+1))
21393           xi=mod(xi,boxxsize)
21394           if (xi.lt.0) xi=xi+boxxsize
21395           yi=mod(yi,boxysize)
21396           if (yi.lt.0) yi=yi+boxysize
21397           zi=mod(zi,boxzsize)
21398           if (zi.lt.0) zi=zi+boxzsize
21399
21400         do iint=1,nscp_gr_nucl(i)
21401
21402         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21403           itypj=itype(j,2)
21404           if (itypj.eq.ntyp1_molec(2)) cycle
21405 !C Uncomment following three lines for SC-p interactions
21406 !c         xj=c(1,nres+j)-xi
21407 !c         yj=c(2,nres+j)-yi
21408 !c         zj=c(3,nres+j)-zi
21409 !C Uncomment following three lines for Ca-p interactions
21410 !          xj=c(1,j)-xi
21411 !          yj=c(2,j)-yi
21412 !          zj=c(3,j)-zi
21413           xj=c(1,j)
21414           yj=c(2,j)
21415           zj=c(3,j)
21416           xj=mod(xj,boxxsize)
21417           if (xj.lt.0) xj=xj+boxxsize
21418           yj=mod(yj,boxysize)
21419           if (yj.lt.0) yj=yj+boxysize
21420           zj=mod(zj,boxzsize)
21421           if (zj.lt.0) zj=zj+boxzsize
21422       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21423       xj_safe=xj
21424       yj_safe=yj
21425       zj_safe=zj
21426       subchap=0
21427       do xshift=-1,1
21428       do yshift=-1,1
21429       do zshift=-1,1
21430           xj=xj_safe+xshift*boxxsize
21431           yj=yj_safe+yshift*boxysize
21432           zj=zj_safe+zshift*boxzsize
21433           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21434           if(dist_temp.lt.dist_init) then
21435             dist_init=dist_temp
21436             xj_temp=xj
21437             yj_temp=yj
21438             zj_temp=zj
21439             subchap=1
21440           endif
21441        enddo
21442        enddo
21443        enddo
21444        if (subchap.eq.1) then
21445           xj=xj_temp-xi
21446           yj=yj_temp-yi
21447           zj=zj_temp-zi
21448        else
21449           xj=xj_safe-xi
21450           yj=yj_safe-yi
21451           zj=zj_safe-zi
21452        endif
21453
21454           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21455           fac=rrij**expon2
21456           e1=fac*fac*aad_nucl(itypj)
21457           e2=fac*bad_nucl(itypj)
21458           if (iabs(j-i) .le. 2) then
21459             e1=scal14*e1
21460             e2=scal14*e2
21461           endif
21462           evdwij=e1+e2
21463           evdwpsb=evdwpsb+evdwij
21464           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21465              'evdw2',i,j,evdwij,"tu4"
21466 !C
21467 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21468 !C
21469           fac=-(evdwij+e1)*rrij
21470           ggg(1)=xj*fac
21471           ggg(2)=yj*fac
21472           ggg(3)=zj*fac
21473           do k=1,3
21474             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21475             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21476           enddo
21477         enddo
21478
21479         enddo ! iint
21480       enddo ! i
21481       do i=1,nct
21482         do j=1,3
21483           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21484           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21485         enddo
21486       enddo
21487       return
21488       end subroutine epsb
21489
21490 !------------------------------------------------------
21491       subroutine esb_gb(evdwsb,eelsb)
21492       use comm_locel
21493       use calc_data_nucl
21494       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21495       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21496       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21497       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21498                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21499       integer :: ii
21500       logical lprn
21501       evdw=0.0D0
21502       eelsb=0.0d0
21503       ecorr=0.0d0
21504       evdwsb=0.0D0
21505       lprn=.false.
21506       ind=0
21507 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21508       do i=iatsc_s_nucl,iatsc_e_nucl
21509         num_conti=0
21510         num_conti2=0
21511         itypi=itype(i,2)
21512 !        PRINT *,"I=",i,itypi
21513         if (itypi.eq.ntyp1_molec(2)) cycle
21514         itypi1=itype(i+1,2)
21515         xi=c(1,nres+i)
21516         yi=c(2,nres+i)
21517         zi=c(3,nres+i)
21518           xi=dmod(xi,boxxsize)
21519           if (xi.lt.0) xi=xi+boxxsize
21520           yi=dmod(yi,boxysize)
21521           if (yi.lt.0) yi=yi+boxysize
21522           zi=dmod(zi,boxzsize)
21523           if (zi.lt.0) zi=zi+boxzsize
21524
21525         dxi=dc_norm(1,nres+i)
21526         dyi=dc_norm(2,nres+i)
21527         dzi=dc_norm(3,nres+i)
21528         dsci_inv=vbld_inv(i+nres)
21529 !C
21530 !C Calculate SC interaction energy.
21531 !C
21532         do iint=1,nint_gr_nucl(i)
21533 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21534           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21535             ind=ind+1
21536 !            print *,"JESTEM"
21537             itypj=itype(j,2)
21538             if (itypj.eq.ntyp1_molec(2)) cycle
21539             dscj_inv=vbld_inv(j+nres)
21540             sig0ij=sigma_nucl(itypi,itypj)
21541             chi1=chi_nucl(itypi,itypj)
21542             chi2=chi_nucl(itypj,itypi)
21543             chi12=chi1*chi2
21544             chip1=chip_nucl(itypi,itypj)
21545             chip2=chip_nucl(itypj,itypi)
21546             chip12=chip1*chip2
21547 !            xj=c(1,nres+j)-xi
21548 !            yj=c(2,nres+j)-yi
21549 !            zj=c(3,nres+j)-zi
21550            xj=c(1,nres+j)
21551            yj=c(2,nres+j)
21552            zj=c(3,nres+j)
21553           xj=dmod(xj,boxxsize)
21554           if (xj.lt.0) xj=xj+boxxsize
21555           yj=dmod(yj,boxysize)
21556           if (yj.lt.0) yj=yj+boxysize
21557           zj=dmod(zj,boxzsize)
21558           if (zj.lt.0) zj=zj+boxzsize
21559       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21560       xj_safe=xj
21561       yj_safe=yj
21562       zj_safe=zj
21563       subchap=0
21564       do xshift=-1,1
21565       do yshift=-1,1
21566       do zshift=-1,1
21567           xj=xj_safe+xshift*boxxsize
21568           yj=yj_safe+yshift*boxysize
21569           zj=zj_safe+zshift*boxzsize
21570           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21571           if(dist_temp.lt.dist_init) then
21572             dist_init=dist_temp
21573             xj_temp=xj
21574             yj_temp=yj
21575             zj_temp=zj
21576             subchap=1
21577           endif
21578        enddo
21579        enddo
21580        enddo
21581        if (subchap.eq.1) then
21582           xj=xj_temp-xi
21583           yj=yj_temp-yi
21584           zj=zj_temp-zi
21585        else
21586           xj=xj_safe-xi
21587           yj=yj_safe-yi
21588           zj=zj_safe-zi
21589        endif
21590
21591             dxj=dc_norm(1,nres+j)
21592             dyj=dc_norm(2,nres+j)
21593             dzj=dc_norm(3,nres+j)
21594             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21595             rij=dsqrt(rrij)
21596 !C Calculate angle-dependent terms of energy and contributions to their
21597 !C derivatives.
21598             erij(1)=xj*rij
21599             erij(2)=yj*rij
21600             erij(3)=zj*rij
21601             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21602             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21603             om12=dxi*dxj+dyi*dyj+dzi*dzj
21604             call sc_angular_nucl
21605             sigsq=1.0D0/sigsq
21606             sig=sig0ij*dsqrt(sigsq)
21607             rij_shift=1.0D0/rij-sig+sig0ij
21608 !            print *,rij_shift,"rij_shift"
21609 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21610 !c     &       " rij_shift",rij_shift
21611             if (rij_shift.le.0.0D0) then
21612               evdw=1.0D20
21613               return
21614             endif
21615             sigder=-sig*sigsq
21616 !c---------------------------------------------------------------
21617             rij_shift=1.0D0/rij_shift
21618             fac=rij_shift**expon
21619             e1=fac*fac*aa_nucl(itypi,itypj)
21620             e2=fac*bb_nucl(itypi,itypj)
21621             evdwij=eps1*eps2rt*(e1+e2)
21622 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21623 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21624             eps2der=evdwij
21625             evdwij=evdwij*eps2rt
21626             evdwsb=evdwsb+evdwij
21627             if (lprn) then
21628             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21629             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21630             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21631              restyp(itypi,2),i,restyp(itypj,2),j, &
21632              epsi,sigm,chi1,chi2,chip1,chip2, &
21633              eps1,eps2rt**2,sig,sig0ij, &
21634              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21635             evdwij
21636             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21637             endif
21638
21639             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21640                              'evdw',i,j,evdwij,"tu3"
21641
21642
21643 !C Calculate gradient components.
21644             e1=e1*eps1*eps2rt**2
21645             fac=-expon*(e1+evdwij)*rij_shift
21646             sigder=fac*sigder
21647             fac=rij*fac
21648 !c            fac=0.0d0
21649 !C Calculate the radial part of the gradient
21650             gg(1)=xj*fac
21651             gg(2)=yj*fac
21652             gg(3)=zj*fac
21653 !C Calculate angular part of the gradient.
21654             call sc_grad_nucl
21655             call eelsbij(eelij,num_conti2)
21656             if (energy_dec .and. &
21657            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21658           write (istat,'(e14.5)') evdwij
21659             eelsb=eelsb+eelij
21660           enddo      ! j
21661         enddo        ! iint
21662         num_cont_hb(i)=num_conti2
21663       enddo          ! i
21664 !c      write (iout,*) "Number of loop steps in EGB:",ind
21665 !cccc      energy_dec=.false.
21666       return
21667       end subroutine esb_gb
21668 !-------------------------------------------------------------------------------
21669       subroutine eelsbij(eesij,num_conti2)
21670       use comm_locel
21671       use calc_data_nucl
21672       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21673       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21674       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21675                     dist_temp, dist_init,rlocshield,fracinbuf
21676       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21677
21678 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21679       real(kind=8) scal_el /0.5d0/
21680       integer :: iteli,itelj,kkk,kkll,m,isubchap
21681       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21682       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21683       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21684                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21685                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21686                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21687                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21688                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21689                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21690                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21691       ind=ind+1
21692       itypi=itype(i,2)
21693       itypj=itype(j,2)
21694 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21695       ael6i=ael6_nucl(itypi,itypj)
21696       ael3i=ael3_nucl(itypi,itypj)
21697       ael63i=ael63_nucl(itypi,itypj)
21698       ael32i=ael32_nucl(itypi,itypj)
21699 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21700 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21701       dxj=dc(1,j+nres)
21702       dyj=dc(2,j+nres)
21703       dzj=dc(3,j+nres)
21704       dx_normi=dc_norm(1,i+nres)
21705       dy_normi=dc_norm(2,i+nres)
21706       dz_normi=dc_norm(3,i+nres)
21707       dx_normj=dc_norm(1,j+nres)
21708       dy_normj=dc_norm(2,j+nres)
21709       dz_normj=dc_norm(3,j+nres)
21710 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21711 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21712 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21713       if (ipot_nucl.ne.2) then
21714         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21715         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21716         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21717       else
21718         cosa=om12
21719         cosb=om1
21720         cosg=om2
21721       endif
21722       r3ij=rij*rrij
21723       r6ij=r3ij*r3ij
21724       fac=cosa-3.0D0*cosb*cosg
21725       facfac=fac*fac
21726       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21727       fac3=ael6i*r6ij
21728       fac4=ael3i*r3ij
21729       fac5=ael63i*r6ij
21730       fac6=ael32i*r6ij
21731 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21732 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21733       el1=fac3*(4.0D0+facfac-fac1)
21734       el2=fac4*fac
21735       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21736       el4=fac6*facfac
21737       eesij=el1+el2+el3+el4
21738 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21739       ees0ij=4.0D0+facfac-fac1
21740
21741       if (energy_dec) then
21742           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21743           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21744            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21745            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21746            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21747           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21748       endif
21749
21750 !C
21751 !C Calculate contributions to the Cartesian gradient.
21752 !C
21753       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21754       fac1=fac
21755 !c      erij(1)=xj*rmij
21756 !c      erij(2)=yj*rmij
21757 !c      erij(3)=zj*rmij
21758 !*
21759 !* Radial derivatives. First process both termini of the fragment (i,j)
21760 !*
21761       ggg(1)=facel*xj
21762       ggg(2)=facel*yj
21763       ggg(3)=facel*zj
21764       do k=1,3
21765         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21766         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21767         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21768         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21769       enddo
21770 !*
21771 !* Angular part
21772 !*
21773       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21774       fac4=-3.0D0*fac4
21775       fac3=-6.0D0*fac3
21776       fac5= 6.0d0*fac5
21777       fac6=-6.0d0*fac6
21778       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21779        fac6*fac1*cosg
21780       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21781        fac6*fac1*cosb
21782       do k=1,3
21783         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21784         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21785       enddo
21786       do k=1,3
21787         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21788       enddo
21789       do k=1,3
21790         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21791              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21792              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21793         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21794              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21795              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21796         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21797         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21798       enddo
21799 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21800        IF ( j.gt.i+1 .and.&
21801           num_conti.le.maxcont) THEN
21802 !C
21803 !C Calculate the contact function. The ith column of the array JCONT will
21804 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21805 !C greater than I). The arrays FACONT and GACONT will contain the values of
21806 !C the contact function and its derivative.
21807         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21808 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21809         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21810 !c        write (2,*) "fcont",fcont
21811         if (fcont.gt.0.0D0) then
21812           num_conti=num_conti+1
21813           num_conti2=num_conti2+1
21814
21815           if (num_conti.gt.maxconts) then
21816             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21817                           ' will skip next contacts for this conf.',maxconts
21818           else
21819             jcont_hb(num_conti,i)=j
21820 !c            write (iout,*) "num_conti",num_conti,
21821 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21822 !C Calculate contact energies
21823             cosa4=4.0D0*cosa
21824             wij=cosa-3.0D0*cosb*cosg
21825             cosbg1=cosb+cosg
21826             cosbg2=cosb-cosg
21827             fac3=dsqrt(-ael6i)*r3ij
21828 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21829             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21830             if (ees0tmp.gt.0) then
21831               ees0pij=dsqrt(ees0tmp)
21832             else
21833               ees0pij=0
21834             endif
21835             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21836             if (ees0tmp.gt.0) then
21837               ees0mij=dsqrt(ees0tmp)
21838             else
21839               ees0mij=0
21840             endif
21841             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21842             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21843 !c            write (iout,*) "i",i," j",j,
21844 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21845             ees0pij1=fac3/ees0pij
21846             ees0mij1=fac3/ees0mij
21847             fac3p=-3.0D0*fac3*rrij
21848             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21849             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21850             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21851             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21852             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21853             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21854             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21855             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21856             ecosap=ecosa1+ecosa2
21857             ecosbp=ecosb1+ecosb2
21858             ecosgp=ecosg1+ecosg2
21859             ecosam=ecosa1-ecosa2
21860             ecosbm=ecosb1-ecosb2
21861             ecosgm=ecosg1-ecosg2
21862 !C End diagnostics
21863             facont_hb(num_conti,i)=fcont
21864             fprimcont=fprimcont/rij
21865             do k=1,3
21866               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21867               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21868             enddo
21869             gggp(1)=gggp(1)+ees0pijp*xj
21870             gggp(2)=gggp(2)+ees0pijp*yj
21871             gggp(3)=gggp(3)+ees0pijp*zj
21872             gggm(1)=gggm(1)+ees0mijp*xj
21873             gggm(2)=gggm(2)+ees0mijp*yj
21874             gggm(3)=gggm(3)+ees0mijp*zj
21875 !C Derivatives due to the contact function
21876             gacont_hbr(1,num_conti,i)=fprimcont*xj
21877             gacont_hbr(2,num_conti,i)=fprimcont*yj
21878             gacont_hbr(3,num_conti,i)=fprimcont*zj
21879             do k=1,3
21880 !c
21881 !c Gradient of the correlation terms
21882 !c
21883               gacontp_hb1(k,num_conti,i)= &
21884              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21885             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21886               gacontp_hb2(k,num_conti,i)= &
21887              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21888             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21889               gacontp_hb3(k,num_conti,i)=gggp(k)
21890               gacontm_hb1(k,num_conti,i)= &
21891              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21892             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21893               gacontm_hb2(k,num_conti,i)= &
21894              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21895             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21896               gacontm_hb3(k,num_conti,i)=gggm(k)
21897             enddo
21898           endif
21899         endif
21900       ENDIF
21901       return
21902       end subroutine eelsbij
21903 !------------------------------------------------------------------
21904       subroutine sc_grad_nucl
21905       use comm_locel
21906       use calc_data_nucl
21907       real(kind=8),dimension(3) :: dcosom1,dcosom2
21908       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21909       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21910       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21911       do k=1,3
21912         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21913         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21914       enddo
21915       do k=1,3
21916         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21917       enddo
21918       do k=1,3
21919         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21920                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21921                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21922         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21923                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21924                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21925       enddo
21926 !C
21927 !C Calculate the components of the gradient in DC and X
21928 !C
21929       do l=1,3
21930         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21931         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21932       enddo
21933       return
21934       end subroutine sc_grad_nucl
21935 !-----------------------------------------------------------------------
21936       subroutine esb(esbloc)
21937 !C Calculate the local energy of a side chain and its derivatives in the
21938 !C corresponding virtual-bond valence angles THETA and the spherical angles
21939 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21940 !C added by Urszula Kozlowska. 07/11/2007
21941 !C
21942       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21943       real(kind=8),dimension(9):: x
21944      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21945       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21946       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21947       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21948        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21949        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21950        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21951        integer::it,nlobit,i,j,k
21952 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21953       delta=0.02d0*pi
21954       esbloc=0.0D0
21955       do i=loc_start_nucl,loc_end_nucl
21956         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21957         costtab(i+1) =dcos(theta(i+1))
21958         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21959         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21960         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21961         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21962         cosfac=dsqrt(cosfac2)
21963         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21964         sinfac=dsqrt(sinfac2)
21965         it=itype(i,2)
21966         if (it.eq.10) goto 1
21967
21968 !c
21969 !C  Compute the axes of tghe local cartesian coordinates system; store in
21970 !c   x_prime, y_prime and z_prime
21971 !c
21972         do j=1,3
21973           x_prime(j) = 0.00
21974           y_prime(j) = 0.00
21975           z_prime(j) = 0.00
21976         enddo
21977 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21978 !C     &   dc_norm(3,i+nres)
21979         do j = 1,3
21980           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21981           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21982         enddo
21983         do j = 1,3
21984           z_prime(j) = -uz(j,i-1)
21985 !           z_prime(j)=0.0
21986         enddo
21987
21988         xx=0.0d0
21989         yy=0.0d0
21990         zz=0.0d0
21991         do j = 1,3
21992           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21993           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21994           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21995         enddo
21996
21997         xxtab(i)=xx
21998         yytab(i)=yy
21999         zztab(i)=zz
22000          it=itype(i,2)
22001         do j = 1,9
22002           x(j) = sc_parmin_nucl(j,it)
22003         enddo
22004 #ifdef CHECK_COORD
22005 !Cc diagnostics - remove later
22006         xx1 = dcos(alph(2))
22007         yy1 = dsin(alph(2))*dcos(omeg(2))
22008         zz1 = -dsin(alph(2))*dsin(omeg(2))
22009         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22010          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22011          xx1,yy1,zz1
22012 !C,"  --- ", xx_w,yy_w,zz_w
22013 !c end diagnostics
22014 #endif
22015         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22016         esbloc = esbloc + sumene
22017         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22018 !        print *,"enecomp",sumene,sumene2
22019 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22020 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22021 #ifdef DEBUG
22022         write (2,*) "x",(x(k),k=1,9)
22023 !C
22024 !C This section to check the numerical derivatives of the energy of ith side
22025 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22026 !C #define DEBUG in the code to turn it on.
22027 !C
22028         write (2,*) "sumene               =",sumene
22029         aincr=1.0d-7
22030         xxsave=xx
22031         xx=xx+aincr
22032         write (2,*) xx,yy,zz
22033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22034         de_dxx_num=(sumenep-sumene)/aincr
22035         xx=xxsave
22036         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22037         yysave=yy
22038         yy=yy+aincr
22039         write (2,*) xx,yy,zz
22040         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22041         de_dyy_num=(sumenep-sumene)/aincr
22042         yy=yysave
22043         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22044         zzsave=zz
22045         zz=zz+aincr
22046         write (2,*) xx,yy,zz
22047         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22048         de_dzz_num=(sumenep-sumene)/aincr
22049         zz=zzsave
22050         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22051         costsave=cost2tab(i+1)
22052         sintsave=sint2tab(i+1)
22053         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22054         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22055         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22056         de_dt_num=(sumenep-sumene)/aincr
22057         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22058         cost2tab(i+1)=costsave
22059         sint2tab(i+1)=sintsave
22060 !C End of diagnostics section.
22061 #endif
22062 !C
22063 !C Compute the gradient of esc
22064 !C
22065         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22066         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22067         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22068         de_dtt=0.0d0
22069 #ifdef DEBUG
22070         write (2,*) "x",(x(k),k=1,9)
22071         write (2,*) "xx",xx," yy",yy," zz",zz
22072         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22073           " de_zz   ",de_zz," de_tt   ",de_tt
22074         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22075           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22076 #endif
22077 !C
22078        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22079        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22080        cosfac2xx=cosfac2*xx
22081        sinfac2yy=sinfac2*yy
22082        do k = 1,3
22083          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22084            vbld_inv(i+1)
22085          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22086            vbld_inv(i)
22087          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22088          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22089 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22090 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22091 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22092 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22093          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22094          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22095          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22096          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22097          dZZ_Ci1(k)=0.0d0
22098          dZZ_Ci(k)=0.0d0
22099          do j=1,3
22100            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22101            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22102          enddo
22103
22104          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22105          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22106          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22107 !c
22108          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22109          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22110        enddo
22111
22112        do k=1,3
22113          dXX_Ctab(k,i)=dXX_Ci(k)
22114          dXX_C1tab(k,i)=dXX_Ci1(k)
22115          dYY_Ctab(k,i)=dYY_Ci(k)
22116          dYY_C1tab(k,i)=dYY_Ci1(k)
22117          dZZ_Ctab(k,i)=dZZ_Ci(k)
22118          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22119          dXX_XYZtab(k,i)=dXX_XYZ(k)
22120          dYY_XYZtab(k,i)=dYY_XYZ(k)
22121          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22122        enddo
22123        do k = 1,3
22124 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22125 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22126 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22127 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22128 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22129 !c     &    dt_dci(k)
22130 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22131 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22132          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22133          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22134          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22135          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22136          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22137          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22138 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22139        enddo
22140 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22141 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22142
22143 !C to check gradient call subroutine check_grad
22144
22145     1 continue
22146       enddo
22147       return
22148       end subroutine esb
22149 !=-------------------------------------------------------
22150       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22151 !      implicit none
22152       real(kind=8),dimension(9):: x(9)
22153        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22154       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22155       integer i
22156 !c      write (2,*) "enesc"
22157 !c      write (2,*) "x",(x(i),i=1,9)
22158 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22159       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22160         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22161         + x(9)*yy*zz
22162       enesc_nucl=sumene
22163       return
22164       end function enesc_nucl
22165 !-----------------------------------------------------------------------------
22166       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22167 #ifdef MPI
22168       include 'mpif.h'
22169       integer,parameter :: max_cont=2000
22170       integer,parameter:: max_dim=2*(8*3+6)
22171       integer, parameter :: msglen1=max_cont*max_dim
22172       integer,parameter :: msglen2=2*msglen1
22173       integer source,CorrelType,CorrelID,Error
22174       real(kind=8) :: buffer(max_cont,max_dim)
22175       integer status(MPI_STATUS_SIZE)
22176       integer :: ierror,nbytes
22177 #endif
22178       real(kind=8),dimension(3):: gx(3),gx1(3)
22179       real(kind=8) :: time00
22180       logical lprn,ldone
22181       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22182       real(kind=8) ecorr,ecorr3
22183       integer :: n_corr,n_corr1,mm,msglen
22184 !C Set lprn=.true. for debugging
22185       lprn=.false.
22186       n_corr=0
22187       n_corr1=0
22188 #ifdef MPI
22189       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22190
22191       if (nfgtasks.le.1) goto 30
22192       if (lprn) then
22193         write (iout,'(a)') 'Contact function values:'
22194         do i=nnt,nct-1
22195           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22196          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22197          j=1,num_cont_hb(i))
22198         enddo
22199       endif
22200 !C Caution! Following code assumes that electrostatic interactions concerning
22201 !C a given atom are split among at most two processors!
22202       CorrelType=477
22203       CorrelID=fg_rank+1
22204       ldone=.false.
22205       do i=1,max_cont
22206         do j=1,max_dim
22207           buffer(i,j)=0.0D0
22208         enddo
22209       enddo
22210       mm=mod(fg_rank,2)
22211 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22212       if (mm) 20,20,10
22213    10 continue
22214 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22215       if (fg_rank.gt.0) then
22216 !C Send correlation contributions to the preceding processor
22217         msglen=msglen1
22218         nn=num_cont_hb(iatel_s_nucl)
22219         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22220 !c        write (*,*) 'The BUFFER array:'
22221 !c        do i=1,nn
22222 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22223 !c        enddo
22224         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22225           msglen=msglen2
22226           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22227 !C Clear the contacts of the atom passed to the neighboring processor
22228         nn=num_cont_hb(iatel_s_nucl+1)
22229 !c        do i=1,nn
22230 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22231 !c        enddo
22232             num_cont_hb(iatel_s_nucl)=0
22233         endif
22234 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22235 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22236 !cd   & ' msglen=',msglen
22237 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22238 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22239 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22240         time00=MPI_Wtime()
22241         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22242          CorrelType,FG_COMM,IERROR)
22243         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22244 !cd      write (iout,*) 'Processor ',fg_rank,
22245 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22246 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22247 !c        write (*,*) 'Processor ',fg_rank,
22248 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22249 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22250 !c        msglen=msglen1
22251       endif ! (fg_rank.gt.0)
22252       if (ldone) goto 30
22253       ldone=.true.
22254    20 continue
22255 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22256       if (fg_rank.lt.nfgtasks-1) then
22257 !C Receive correlation contributions from the next processor
22258         msglen=msglen1
22259         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22260 !cd      write (iout,*) 'Processor',fg_rank,
22261 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22262 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22263 !c        write (*,*) 'Processor',fg_rank,
22264 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22265 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22266         time00=MPI_Wtime()
22267         nbytes=-1
22268         do while (nbytes.le.0)
22269           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22270           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22271         enddo
22272 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22273         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22274          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22275         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22276 !c        write (*,*) 'Processor',fg_rank,
22277 !c     &' has received correlation contribution from processor',fg_rank+1,
22278 !c     & ' msglen=',msglen,' nbytes=',nbytes
22279 !c        write (*,*) 'The received BUFFER array:'
22280 !c        do i=1,max_cont
22281 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22282 !c        enddo
22283         if (msglen.eq.msglen1) then
22284           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22285         else if (msglen.eq.msglen2)  then
22286           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22287           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22288         else
22289           write (iout,*) &
22290       'ERROR!!!! message length changed while processing correlations.'
22291           write (*,*) &
22292       'ERROR!!!! message length changed while processing correlations.'
22293           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22294         endif ! msglen.eq.msglen1
22295       endif ! fg_rank.lt.nfgtasks-1
22296       if (ldone) goto 30
22297       ldone=.true.
22298       goto 10
22299    30 continue
22300 #endif
22301       if (lprn) then
22302         write (iout,'(a)') 'Contact function values:'
22303         do i=nnt_molec(2),nct_molec(2)-1
22304           write (iout,'(2i3,50(1x,i2,f5.2))') &
22305          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22306          j=1,num_cont_hb(i))
22307         enddo
22308       endif
22309       ecorr=0.0D0
22310       ecorr3=0.0d0
22311 !C Remove the loop below after debugging !!!
22312 !      do i=nnt_molec(2),nct_molec(2)
22313 !        do j=1,3
22314 !          gradcorr_nucl(j,i)=0.0D0
22315 !          gradxorr_nucl(j,i)=0.0D0
22316 !          gradcorr3_nucl(j,i)=0.0D0
22317 !          gradxorr3_nucl(j,i)=0.0D0
22318 !        enddo
22319 !      enddo
22320 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22321 !C Calculate the local-electrostatic correlation terms
22322       do i=iatsc_s_nucl,iatsc_e_nucl
22323         i1=i+1
22324         num_conti=num_cont_hb(i)
22325         num_conti1=num_cont_hb(i+1)
22326 !        print *,i,num_conti,num_conti1
22327         do jj=1,num_conti
22328           j=jcont_hb(jj,i)
22329           do kk=1,num_conti1
22330             j1=jcont_hb(kk,i1)
22331 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22332 !c     &         ' jj=',jj,' kk=',kk
22333             if (j1.eq.j+1 .or. j1.eq.j-1) then
22334 !C
22335 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22336 !C The system gains extra energy.
22337 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22338 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22339 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22340 !C
22341               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22342               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22343                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22344               n_corr=n_corr+1
22345             else if (j1.eq.j) then
22346 !C
22347 !C Contacts I-J and I-(J+1) occur simultaneously.
22348 !C The system loses extra energy.
22349 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22350 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22351 !C Need to implement full formulas 32 from Liwo et al., 1998.
22352 !C
22353 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22354 !c     &         ' jj=',jj,' kk=',kk
22355               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22356             endif
22357           enddo ! kk
22358           do kk=1,num_conti
22359             j1=jcont_hb(kk,i)
22360 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22361 !c     &         ' jj=',jj,' kk=',kk
22362             if (j1.eq.j+1) then
22363 !C Contacts I-J and (I+1)-J occur simultaneously.
22364 !C The system loses extra energy.
22365               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22366             endif ! j1==j+1
22367           enddo ! kk
22368         enddo ! jj
22369       enddo ! i
22370       return
22371       end subroutine multibody_hb_nucl
22372 !-----------------------------------------------------------
22373       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22374 !      implicit real*8 (a-h,o-z)
22375 !      include 'DIMENSIONS'
22376 !      include 'COMMON.IOUNITS'
22377 !      include 'COMMON.DERIV'
22378 !      include 'COMMON.INTERACT'
22379 !      include 'COMMON.CONTACTS'
22380       real(kind=8),dimension(3) :: gx,gx1
22381       logical :: lprn
22382 !el local variables
22383       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22384       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22385                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22386                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22387                    rlocshield
22388
22389       lprn=.false.
22390       eij=facont_hb(jj,i)
22391       ekl=facont_hb(kk,k)
22392       ees0pij=ees0p(jj,i)
22393       ees0pkl=ees0p(kk,k)
22394       ees0mij=ees0m(jj,i)
22395       ees0mkl=ees0m(kk,k)
22396       ekont=eij*ekl
22397       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22398 !      print *,"ehbcorr_nucl",ekont,ees
22399 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22400 !C Following 4 lines for diagnostics.
22401 !cd    ees0pkl=0.0D0
22402 !cd    ees0pij=1.0D0
22403 !cd    ees0mkl=0.0D0
22404 !cd    ees0mij=1.0D0
22405 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22406 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22407 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22408 !C Calculate the multi-body contribution to energy.
22409 !      ecorr_nucl=ecorr_nucl+ekont*ees
22410 !C Calculate multi-body contributions to the gradient.
22411       coeffpees0pij=coeffp*ees0pij
22412       coeffmees0mij=coeffm*ees0mij
22413       coeffpees0pkl=coeffp*ees0pkl
22414       coeffmees0mkl=coeffm*ees0mkl
22415       do ll=1,3
22416         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22417        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22418        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22419         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22420         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22421         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22422         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22423         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22424         coeffmees0mij*gacontm_hb1(ll,kk,k))
22425         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22426         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22427         coeffmees0mij*gacontm_hb2(ll,kk,k))
22428         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22429           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22430           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22431         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22432         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22433         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22434           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22435           coeffmees0mij*gacontm_hb3(ll,kk,k))
22436         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22437         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22438         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22439         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22440         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22441         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22442       enddo
22443       ehbcorr_nucl=ekont*ees
22444       return
22445       end function ehbcorr_nucl
22446 !-------------------------------------------------------------------------
22447
22448      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22449 !      implicit real*8 (a-h,o-z)
22450 !      include 'DIMENSIONS'
22451 !      include 'COMMON.IOUNITS'
22452 !      include 'COMMON.DERIV'
22453 !      include 'COMMON.INTERACT'
22454 !      include 'COMMON.CONTACTS'
22455       real(kind=8),dimension(3) :: gx,gx1
22456       logical :: lprn
22457 !el local variables
22458       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22459       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22460                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22461                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22462                    rlocshield
22463
22464       lprn=.false.
22465       eij=facont_hb(jj,i)
22466       ekl=facont_hb(kk,k)
22467       ees0pij=ees0p(jj,i)
22468       ees0pkl=ees0p(kk,k)
22469       ees0mij=ees0m(jj,i)
22470       ees0mkl=ees0m(kk,k)
22471       ekont=eij*ekl
22472       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22473 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22474 !C Following 4 lines for diagnostics.
22475 !cd    ees0pkl=0.0D0
22476 !cd    ees0pij=1.0D0
22477 !cd    ees0mkl=0.0D0
22478 !cd    ees0mij=1.0D0
22479 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22480 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22481 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22482 !C Calculate the multi-body contribution to energy.
22483 !      ecorr=ecorr+ekont*ees
22484 !C Calculate multi-body contributions to the gradient.
22485       coeffpees0pij=coeffp*ees0pij
22486       coeffmees0mij=coeffm*ees0mij
22487       coeffpees0pkl=coeffp*ees0pkl
22488       coeffmees0mkl=coeffm*ees0mkl
22489       do ll=1,3
22490         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22491        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22492        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22493         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22494         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22495         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22496         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22497         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22498         coeffmees0mij*gacontm_hb1(ll,kk,k))
22499         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22500         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22501         coeffmees0mij*gacontm_hb2(ll,kk,k))
22502         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22503           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22504           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22505         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22506         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22507         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22508           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22509           coeffmees0mij*gacontm_hb3(ll,kk,k))
22510         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22511         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22512         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22513         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22514         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22515         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22516       enddo
22517       ehbcorr3_nucl=ekont*ees
22518       return
22519       end function ehbcorr3_nucl
22520 #ifdef MPI
22521       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22522       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22523       real(kind=8):: buffer(dimen1,dimen2)
22524       num_kont=num_cont_hb(atom)
22525       do i=1,num_kont
22526         do k=1,8
22527           do j=1,3
22528             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22529           enddo ! j
22530         enddo ! k
22531         buffer(i,indx+25)=facont_hb(i,atom)
22532         buffer(i,indx+26)=ees0p(i,atom)
22533         buffer(i,indx+27)=ees0m(i,atom)
22534         buffer(i,indx+28)=d_cont(i,atom)
22535         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22536       enddo ! i
22537       buffer(1,indx+30)=dfloat(num_kont)
22538       return
22539       end subroutine pack_buffer
22540 !c------------------------------------------------------------------------------
22541       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22542       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22543       real(kind=8):: buffer(dimen1,dimen2)
22544 !      double precision zapas
22545 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22546 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22547 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22548 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22549       num_kont=buffer(1,indx+30)
22550       num_kont_old=num_cont_hb(atom)
22551       num_cont_hb(atom)=num_kont+num_kont_old
22552       do i=1,num_kont
22553         ii=i+num_kont_old
22554         do k=1,8
22555           do j=1,3
22556             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22557           enddo ! j
22558         enddo ! k
22559         facont_hb(ii,atom)=buffer(i,indx+25)
22560         ees0p(ii,atom)=buffer(i,indx+26)
22561         ees0m(ii,atom)=buffer(i,indx+27)
22562         d_cont(i,atom)=buffer(i,indx+28)
22563         jcont_hb(ii,atom)=buffer(i,indx+29)
22564       enddo ! i
22565       return
22566       end subroutine unpack_buffer
22567 !c------------------------------------------------------------------------------
22568 #endif
22569       subroutine ecatcat(ecationcation)
22570         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22571         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22572         r7,r4,ecationcation,k0,rcal
22573         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22574         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22575         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22576         gg,r
22577
22578         ecationcation=0.0d0
22579         if (nres_molec(5).eq.0) return
22580         rcat0=3.472
22581         epscalc=0.05
22582         r06 = rcat0**6
22583         r012 = r06**2
22584         k0 = 332.0*(2.0*2.0)/80.0
22585         itmp=0
22586
22587         do i=1,4
22588         itmp=itmp+nres_molec(i)
22589         enddo
22590 !        write(iout,*) "itmp",itmp
22591         do i=itmp+1,itmp+nres_molec(5)-1
22592
22593         xi=c(1,i)
22594         yi=c(2,i)
22595         zi=c(3,i)
22596
22597           xi=mod(xi,boxxsize)
22598           if (xi.lt.0) xi=xi+boxxsize
22599           yi=mod(yi,boxysize)
22600           if (yi.lt.0) yi=yi+boxysize
22601           zi=mod(zi,boxzsize)
22602           if (zi.lt.0) zi=zi+boxzsize
22603
22604           do j=i+1,itmp+nres_molec(5)
22605 !           print *,i,j,'catcat'
22606            xj=c(1,j)
22607            yj=c(2,j)
22608            zj=c(3,j)
22609           xj=dmod(xj,boxxsize)
22610           if (xj.lt.0) xj=xj+boxxsize
22611           yj=dmod(yj,boxysize)
22612           if (yj.lt.0) yj=yj+boxysize
22613           zj=dmod(zj,boxzsize)
22614           if (zj.lt.0) zj=zj+boxzsize
22615 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22616       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22617       xj_safe=xj
22618       yj_safe=yj
22619       zj_safe=zj
22620       subchap=0
22621       do xshift=-1,1
22622       do yshift=-1,1
22623       do zshift=-1,1
22624           xj=xj_safe+xshift*boxxsize
22625           yj=yj_safe+yshift*boxysize
22626           zj=zj_safe+zshift*boxzsize
22627           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22628           if(dist_temp.lt.dist_init) then
22629             dist_init=dist_temp
22630             xj_temp=xj
22631             yj_temp=yj
22632             zj_temp=zj
22633             subchap=1
22634           endif
22635        enddo
22636        enddo
22637        enddo
22638        if (subchap.eq.1) then
22639           xj=xj_temp-xi
22640           yj=yj_temp-yi
22641           zj=zj_temp-zi
22642        else
22643           xj=xj_safe-xi
22644           yj=yj_safe-yi
22645           zj=zj_safe-zi
22646        endif
22647        rcal =xj**2+yj**2+zj**2
22648         ract=sqrt(rcal)
22649 !        rcat0=3.472
22650 !        epscalc=0.05
22651 !        r06 = rcat0**6
22652 !        r012 = r06**2
22653 !        k0 = 332*(2*2)/80
22654         Evan1cat=epscalc*(r012/rcal**6)
22655         Evan2cat=epscalc*2*(r06/rcal**3)
22656         Eeleccat=k0/ract
22657         r7 = rcal**7
22658         r4 = rcal**4
22659         r(1)=xj
22660         r(2)=yj
22661         r(3)=zj
22662         do k=1,3
22663           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22664           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22665           dEeleccat(k)=-k0*r(k)/ract**3
22666         enddo
22667         do k=1,3
22668           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22669           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22670           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22671         enddo
22672
22673 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22674         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22675        enddo
22676        enddo
22677        return
22678        end subroutine ecatcat
22679 !---------------------------------------------------------------------------
22680        subroutine ecat_prot(ecation_prot)
22681        integer i,j,k,subchap,itmp,inum
22682         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22683         r7,r4,ecationcation
22684         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22685         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22686         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22687         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22688         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22689         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22690         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22691         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22692         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22693         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22694         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22695         ndiv,ndivi
22696         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22697         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22698         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22699         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22700         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22701         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22702         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22703         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22704         dEvan1Cat
22705         real(kind=8),dimension(6) :: vcatprm
22706         ecation_prot=0.0d0
22707 ! first lets calculate interaction with peptide groups
22708         if (nres_molec(5).eq.0) return
22709         itmp=0
22710         do i=1,4
22711         itmp=itmp+nres_molec(i)
22712         enddo
22713 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22714         do i=ibond_start,ibond_end
22715 !         cycle
22716          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22717         xi=0.5d0*(c(1,i)+c(1,i+1))
22718         yi=0.5d0*(c(2,i)+c(2,i+1))
22719         zi=0.5d0*(c(3,i)+c(3,i+1))
22720           xi=mod(xi,boxxsize)
22721           if (xi.lt.0) xi=xi+boxxsize
22722           yi=mod(yi,boxysize)
22723           if (yi.lt.0) yi=yi+boxysize
22724           zi=mod(zi,boxzsize)
22725           if (zi.lt.0) zi=zi+boxzsize
22726
22727          do j=itmp+1,itmp+nres_molec(5)
22728 !           print *,"WTF",itmp,j,i
22729 ! all parameters were for Ca2+ to approximate single charge divide by two
22730          ndiv=1.0
22731          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22732          wconst=78*ndiv
22733         wdip =1.092777950857032D2
22734         wdip=wdip/wconst
22735         wmodquad=-2.174122713004870D4
22736         wmodquad=wmodquad/wconst
22737         wquad1 = 3.901232068562804D1
22738         wquad1=wquad1/wconst
22739         wquad2 = 3
22740         wquad2=wquad2/wconst
22741         wvan1 = 0.1
22742         wvan2 = 6
22743 !        itmp=0
22744
22745            xj=c(1,j)
22746            yj=c(2,j)
22747            zj=c(3,j)
22748           xj=dmod(xj,boxxsize)
22749           if (xj.lt.0) xj=xj+boxxsize
22750           yj=dmod(yj,boxysize)
22751           if (yj.lt.0) yj=yj+boxysize
22752           zj=dmod(zj,boxzsize)
22753           if (zj.lt.0) zj=zj+boxzsize
22754       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22755       xj_safe=xj
22756       yj_safe=yj
22757       zj_safe=zj
22758       subchap=0
22759       do xshift=-1,1
22760       do yshift=-1,1
22761       do zshift=-1,1
22762           xj=xj_safe+xshift*boxxsize
22763           yj=yj_safe+yshift*boxysize
22764           zj=zj_safe+zshift*boxzsize
22765           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22766           if(dist_temp.lt.dist_init) then
22767             dist_init=dist_temp
22768             xj_temp=xj
22769             yj_temp=yj
22770             zj_temp=zj
22771             subchap=1
22772           endif
22773        enddo
22774        enddo
22775        enddo
22776        if (subchap.eq.1) then
22777           xj=xj_temp-xi
22778           yj=yj_temp-yi
22779           zj=zj_temp-zi
22780        else
22781           xj=xj_safe-xi
22782           yj=yj_safe-yi
22783           zj=zj_safe-zi
22784        endif
22785 !       enddo
22786 !       enddo
22787        rcpm = sqrt(xj**2+yj**2+zj**2)
22788        drcp_norm(1)=xj/rcpm
22789        drcp_norm(2)=yj/rcpm
22790        drcp_norm(3)=zj/rcpm
22791        dcmag=0.0
22792        do k=1,3
22793        dcmag=dcmag+dc(k,i)**2
22794        enddo
22795        dcmag=dsqrt(dcmag)
22796        do k=1,3
22797          myd_norm(k)=dc(k,i)/dcmag
22798        enddo
22799         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22800         drcp_norm(3)*myd_norm(3)
22801         rsecp = rcpm**2
22802         Ir = 1.0d0/rcpm
22803         Irsecp = 1.0d0/rsecp
22804         Irthrp = Irsecp/rcpm
22805         Irfourp = Irthrp/rcpm
22806         Irfiftp = Irfourp/rcpm
22807         Irsistp=Irfiftp/rcpm
22808         Irseven=Irsistp/rcpm
22809         Irtwelv=Irsistp*Irsistp
22810         Irthir=Irtwelv/rcpm
22811         sin2thet = (1-costhet*costhet)
22812         sinthet=sqrt(sin2thet)
22813         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22814              *sin2thet
22815         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22816              2*wvan2**6*Irsistp)
22817         ecation_prot = ecation_prot+E1+E2
22818 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22819         dE1dr = -2*costhet*wdip*Irthrp-&
22820          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22821         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22822           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22823         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22824         do k=1,3
22825           drdpep(k) = -drcp_norm(k)
22826           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22827           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22828           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22829           dEddci(k) = dEdcos*dcosddci(k)
22830         enddo
22831         do k=1,3
22832         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22833         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22834         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22835         enddo
22836        enddo ! j
22837        enddo ! i
22838 !------------------------------------------sidechains
22839 !        do i=1,nres_molec(1)
22840         do i=ibond_start,ibond_end
22841          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22842 !         cycle
22843 !        print *,i,ecation_prot
22844         xi=(c(1,i+nres))
22845         yi=(c(2,i+nres))
22846         zi=(c(3,i+nres))
22847           xi=mod(xi,boxxsize)
22848           if (xi.lt.0) xi=xi+boxxsize
22849           yi=mod(yi,boxysize)
22850           if (yi.lt.0) yi=yi+boxysize
22851           zi=mod(zi,boxzsize)
22852           if (zi.lt.0) zi=zi+boxzsize
22853           do k=1,3
22854             cm1(k)=dc(k,i+nres)
22855           enddo
22856            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22857          do j=itmp+1,itmp+nres_molec(5)
22858          ndiv=1.0
22859          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22860
22861            xj=c(1,j)
22862            yj=c(2,j)
22863            zj=c(3,j)
22864           xj=dmod(xj,boxxsize)
22865           if (xj.lt.0) xj=xj+boxxsize
22866           yj=dmod(yj,boxysize)
22867           if (yj.lt.0) yj=yj+boxysize
22868           zj=dmod(zj,boxzsize)
22869           if (zj.lt.0) zj=zj+boxzsize
22870       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22871       xj_safe=xj
22872       yj_safe=yj
22873       zj_safe=zj
22874       subchap=0
22875       do xshift=-1,1
22876       do yshift=-1,1
22877       do zshift=-1,1
22878           xj=xj_safe+xshift*boxxsize
22879           yj=yj_safe+yshift*boxysize
22880           zj=zj_safe+zshift*boxzsize
22881           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22882           if(dist_temp.lt.dist_init) then
22883             dist_init=dist_temp
22884             xj_temp=xj
22885             yj_temp=yj
22886             zj_temp=zj
22887             subchap=1
22888           endif
22889        enddo
22890        enddo
22891        enddo
22892        if (subchap.eq.1) then
22893           xj=xj_temp-xi
22894           yj=yj_temp-yi
22895           zj=zj_temp-zi
22896        else
22897           xj=xj_safe-xi
22898           yj=yj_safe-yi
22899           zj=zj_safe-zi
22900        endif
22901 !       enddo
22902 !       enddo
22903 ! 15- Glu 16-Asp
22904          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
22905          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
22906          (itype(i,1).eq.25))) then
22907             if(itype(i,1).eq.16) then
22908             inum=1
22909             else
22910             inum=2
22911             endif
22912             do k=1,6
22913             vcatprm(k)=catprm(k,inum)
22914             enddo
22915             dASGL=catprm(7,inum)
22916 !             do k=1,3
22917 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22918                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
22919                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
22920                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
22921
22922 !                valpha(k)=c(k,i)
22923 !                vcat(k)=c(k,j)
22924                 if (subchap.eq.1) then
22925                  vcat(1)=xj_temp
22926                  vcat(2)=yj_temp
22927                  vcat(3)=zj_temp
22928                  else
22929                 vcat(1)=xj_safe
22930                 vcat(2)=yj_safe
22931                 vcat(3)=zj_safe
22932                  endif
22933                 valpha(1)=xi-c(1,i+nres)+c(1,i)
22934                 valpha(2)=yi-c(2,i+nres)+c(2,i)
22935                 valpha(3)=zi-c(3,i+nres)+c(3,i)
22936
22937 !              enddo
22938         do k=1,3
22939           dx(k) = vcat(k)-vcm(k)
22940         enddo
22941         do k=1,3
22942           v1(k)=(vcm(k)-valpha(k))
22943           v2(k)=(vcat(k)-valpha(k))
22944         enddo
22945         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22946         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22947         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22948
22949 !  The weights of the energy function calculated from
22950 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22951           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22952             ndivi=0.5
22953           else
22954             ndivi=1.0
22955           endif
22956          ndiv=1.0
22957          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22958
22959         wh2o=78*ndivi*ndiv
22960         wc = vcatprm(1)
22961         wc=wc/wh2o
22962         wdip =vcatprm(2)
22963         wdip=wdip/wh2o
22964         wquad1 =vcatprm(3)
22965         wquad1=wquad1/wh2o
22966         wquad2 = vcatprm(4)
22967         wquad2=wquad2/wh2o
22968         wquad2p = 1.0d0-wquad2
22969         wvan1 = vcatprm(5)
22970         wvan2 =vcatprm(6)
22971         opt = dx(1)**2+dx(2)**2
22972         rsecp = opt+dx(3)**2
22973         rs = sqrt(rsecp)
22974         rthrp = rsecp*rs
22975         rfourp = rthrp*rs
22976         rsixp = rfourp*rsecp
22977         reight=rsixp*rsecp
22978         Ir = 1.0d0/rs
22979         Irsecp = 1.0d0/rsecp
22980         Irthrp = Irsecp/rs
22981         Irfourp = Irthrp/rs
22982         Irsixp = 1.0d0/rsixp
22983         Ireight=1.0d0/reight
22984         Irtw=Irsixp*Irsixp
22985         Irthir=Irtw/rs
22986         Irfourt=Irthir/rs
22987         opt1 = (4*rs*dx(3)*wdip)
22988         opt2 = 6*rsecp*wquad1*opt
22989         opt3 = wquad1*wquad2p*Irsixp
22990         opt4 = (wvan1*wvan2**12)
22991         opt5 = opt4*12*Irfourt
22992         opt6 = 2*wvan1*wvan2**6
22993         opt7 = 6*opt6*Ireight
22994         opt8 = wdip/v1m
22995         opt10 = wdip/v2m
22996         opt11 = (rsecp*v2m)**2
22997         opt12 = (rsecp*v1m)**2
22998         opt14 = (v1m*v2m*rsecp)**2
22999         opt15 = -wquad1/v2m**2
23000         opt16 = (rthrp*(v1m*v2m)**2)**2
23001         opt17 = (v1m**2*rthrp)**2
23002         opt18 = -wquad1/rthrp
23003         opt19 = (v1m**2*v2m**2)**2
23004         Ec = wc*Ir
23005         do k=1,3
23006           dEcCat(k) = -(dx(k)*wc)*Irthrp
23007           dEcCm(k)=(dx(k)*wc)*Irthrp
23008           dEcCalp(k)=0.0d0
23009         enddo
23010         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23011         do k=1,3
23012           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23013                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23014           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23015                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23016           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23017                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23018                       *v1dpv2)/opt14
23019         enddo
23020         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23021         do k=1,3
23022           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23023                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23024                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23025           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23026                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23027                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23028           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23029                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23030                         v1dpv2**2)/opt19
23031         enddo
23032         Equad2=wquad1*wquad2p*Irthrp
23033         do k=1,3
23034           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23035           dEquad2Cm(k)=3*dx(k)*rs*opt3
23036           dEquad2Calp(k)=0.0d0
23037         enddo
23038         Evan1=opt4*Irtw
23039         do k=1,3
23040           dEvan1Cat(k)=-dx(k)*opt5
23041           dEvan1Cm(k)=dx(k)*opt5
23042           dEvan1Calp(k)=0.0d0
23043         enddo
23044         Evan2=-opt6*Irsixp
23045         do k=1,3
23046           dEvan2Cat(k)=dx(k)*opt7
23047           dEvan2Cm(k)=-dx(k)*opt7
23048           dEvan2Calp(k)=0.0d0
23049         enddo
23050         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23051 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23052
23053         do k=1,3
23054           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23055                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23056 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23057           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23058                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23059           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23060                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23061         enddo
23062             dscmag = 0.0d0
23063             do k=1,3
23064               dscvec(k) = dc(k,i+nres)
23065               dscmag = dscmag+dscvec(k)*dscvec(k)
23066             enddo
23067             dscmag3 = dscmag
23068             dscmag = sqrt(dscmag)
23069             dscmag3 = dscmag3*dscmag
23070             constA = 1.0d0+dASGL/dscmag
23071             constB = 0.0d0
23072             do k=1,3
23073               constB = constB+dscvec(k)*dEtotalCm(k)
23074             enddo
23075             constB = constB*dASGL/dscmag3
23076             do k=1,3
23077               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23078               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23079                constA*dEtotalCm(k)-constB*dscvec(k)
23080 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23081               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23082               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23083              enddo
23084         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23085            if(itype(i,1).eq.14) then
23086             inum=3
23087             else
23088             inum=4
23089             endif
23090             do k=1,6
23091             vcatprm(k)=catprm(k,inum)
23092             enddo
23093             dASGL=catprm(7,inum)
23094 !             do k=1,3
23095 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23096 !                valpha(k)=c(k,i)
23097 !                vcat(k)=c(k,j)
23098 !              enddo
23099                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23100                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23101                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23102                 if (subchap.eq.1) then
23103                  vcat(1)=xj_temp
23104                  vcat(2)=yj_temp
23105                  vcat(3)=zj_temp
23106                  else
23107                 vcat(1)=xj_safe
23108                 vcat(2)=yj_safe
23109                 vcat(3)=zj_safe
23110                 endif
23111                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23112                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23113                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23114
23115
23116         do k=1,3
23117           dx(k) = vcat(k)-vcm(k)
23118         enddo
23119         do k=1,3
23120           v1(k)=(vcm(k)-valpha(k))
23121           v2(k)=(vcat(k)-valpha(k))
23122         enddo
23123         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23124         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23125         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23126 !  The weights of the energy function calculated from
23127 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23128          ndiv=1.0
23129          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23130
23131         wh2o=78*ndiv
23132         wdip =vcatprm(2)
23133         wdip=wdip/wh2o
23134         wquad1 =vcatprm(3)
23135         wquad1=wquad1/wh2o
23136         wquad2 = vcatprm(4)
23137         wquad2=wquad2/wh2o
23138         wquad2p = 1-wquad2
23139         wvan1 = vcatprm(5)
23140         wvan2 =vcatprm(6)
23141         opt = dx(1)**2+dx(2)**2
23142         rsecp = opt+dx(3)**2
23143         rs = sqrt(rsecp)
23144         rthrp = rsecp*rs
23145         rfourp = rthrp*rs
23146         rsixp = rfourp*rsecp
23147         reight=rsixp*rsecp
23148         Ir = 1.0d0/rs
23149         Irsecp = 1/rsecp
23150         Irthrp = Irsecp/rs
23151         Irfourp = Irthrp/rs
23152         Irsixp = 1/rsixp
23153         Ireight=1/reight
23154         Irtw=Irsixp*Irsixp
23155         Irthir=Irtw/rs
23156         Irfourt=Irthir/rs
23157         opt1 = (4*rs*dx(3)*wdip)
23158         opt2 = 6*rsecp*wquad1*opt
23159         opt3 = wquad1*wquad2p*Irsixp
23160         opt4 = (wvan1*wvan2**12)
23161         opt5 = opt4*12*Irfourt
23162         opt6 = 2*wvan1*wvan2**6
23163         opt7 = 6*opt6*Ireight
23164         opt8 = wdip/v1m
23165         opt10 = wdip/v2m
23166         opt11 = (rsecp*v2m)**2
23167         opt12 = (rsecp*v1m)**2
23168         opt14 = (v1m*v2m*rsecp)**2
23169         opt15 = -wquad1/v2m**2
23170         opt16 = (rthrp*(v1m*v2m)**2)**2
23171         opt17 = (v1m**2*rthrp)**2
23172         opt18 = -wquad1/rthrp
23173         opt19 = (v1m**2*v2m**2)**2
23174         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23175         do k=1,3
23176           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23177                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23178          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23179                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23180           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23181                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23182                       *v1dpv2)/opt14
23183         enddo
23184         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23185         do k=1,3
23186           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23187                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23188                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23189           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23190                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23191                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23192           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23193                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23194                         v1dpv2**2)/opt19
23195         enddo
23196         Equad2=wquad1*wquad2p*Irthrp
23197         do k=1,3
23198           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23199           dEquad2Cm(k)=3*dx(k)*rs*opt3
23200           dEquad2Calp(k)=0.0d0
23201         enddo
23202         Evan1=opt4*Irtw
23203         do k=1,3
23204           dEvan1Cat(k)=-dx(k)*opt5
23205           dEvan1Cm(k)=dx(k)*opt5
23206           dEvan1Calp(k)=0.0d0
23207         enddo
23208         Evan2=-opt6*Irsixp
23209         do k=1,3
23210           dEvan2Cat(k)=dx(k)*opt7
23211           dEvan2Cm(k)=-dx(k)*opt7
23212           dEvan2Calp(k)=0.0d0
23213         enddo
23214          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23215         do k=1,3
23216           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23217                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23218           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23219                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23220           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23221                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23222         enddo
23223             dscmag = 0.0d0
23224             do k=1,3
23225               dscvec(k) = c(k,i+nres)-c(k,i)
23226 ! TU SPRAWDZ???
23227 !              dscvec(1) = xj
23228 !              dscvec(2) = yj
23229 !              dscvec(3) = zj
23230
23231               dscmag = dscmag+dscvec(k)*dscvec(k)
23232             enddo
23233             dscmag3 = dscmag
23234             dscmag = sqrt(dscmag)
23235             dscmag3 = dscmag3*dscmag
23236             constA = 1+dASGL/dscmag
23237             constB = 0.0d0
23238             do k=1,3
23239               constB = constB+dscvec(k)*dEtotalCm(k)
23240             enddo
23241             constB = constB*dASGL/dscmag3
23242             do k=1,3
23243               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23244               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23245                constA*dEtotalCm(k)-constB*dscvec(k)
23246               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23247               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23248              enddo
23249            else
23250             rcal = 0.0d0
23251             do k=1,3
23252 !              r(k) = c(k,j)-c(k,i+nres)
23253               r(1) = xj
23254               r(2) = yj
23255               r(3) = zj
23256               rcal = rcal+r(k)*r(k)
23257             enddo
23258             ract=sqrt(rcal)
23259             rocal=1.5
23260             epscalc=0.2
23261             r0p=0.5*(rocal+sig0(itype(i,1)))
23262             r06 = r0p**6
23263             r012 = r06*r06
23264             Evan1=epscalc*(r012/rcal**6)
23265             Evan2=epscalc*2*(r06/rcal**3)
23266             r4 = rcal**4
23267             r7 = rcal**7
23268             do k=1,3
23269               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23270               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23271             enddo
23272             do k=1,3
23273               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23274             enddo
23275                  ecation_prot = ecation_prot+ Evan1+Evan2
23276             do  k=1,3
23277                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23278                dEtotalCm(k)
23279               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23280               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23281              enddo
23282          endif ! 13-16 residues
23283        enddo !j
23284        enddo !i
23285        return
23286        end subroutine ecat_prot
23287
23288 !----------------------------------------------------------------------------
23289 !-----------------------------------------------------------------------------
23290 !-----------------------------------------------------------------------------
23291       subroutine eprot_sc_base(escbase)
23292       use calc_data
23293 !      implicit real*8 (a-h,o-z)
23294 !      include 'DIMENSIONS'
23295 !      include 'COMMON.GEO'
23296 !      include 'COMMON.VAR'
23297 !      include 'COMMON.LOCAL'
23298 !      include 'COMMON.CHAIN'
23299 !      include 'COMMON.DERIV'
23300 !      include 'COMMON.NAMES'
23301 !      include 'COMMON.INTERACT'
23302 !      include 'COMMON.IOUNITS'
23303 !      include 'COMMON.CALC'
23304 !      include 'COMMON.CONTROL'
23305 !      include 'COMMON.SBRIDGE'
23306       logical :: lprn
23307 !el local variables
23308       integer :: iint,itypi,itypi1,itypj,subchap
23309       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23310       real(kind=8) :: evdw,sig0ij
23311       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23312                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23313                     sslipi,sslipj,faclip
23314       integer :: ii
23315       real(kind=8) :: fracinbuf
23316        real (kind=8) :: escbase
23317        real (kind=8),dimension(4):: ener
23318        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23319        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23320         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23321         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23322         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23323         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23324         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23325         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23326        real(kind=8),dimension(3,2)::chead,erhead_tail
23327        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23328        integer troll
23329        eps_out=80.0d0
23330        escbase=0.0d0
23331 !       do i=1,nres_molec(1)
23332         do i=ibond_start,ibond_end
23333         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23334         itypi  = itype(i,1)
23335         dxi    = dc_norm(1,nres+i)
23336         dyi    = dc_norm(2,nres+i)
23337         dzi    = dc_norm(3,nres+i)
23338         dsci_inv = vbld_inv(i+nres)
23339         xi=c(1,nres+i)
23340         yi=c(2,nres+i)
23341         zi=c(3,nres+i)
23342         xi=mod(xi,boxxsize)
23343          if (xi.lt.0) xi=xi+boxxsize
23344         yi=mod(yi,boxysize)
23345          if (yi.lt.0) yi=yi+boxysize
23346         zi=mod(zi,boxzsize)
23347          if (zi.lt.0) zi=zi+boxzsize
23348          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23349            itypj= itype(j,2)
23350            if (itype(j,2).eq.ntyp1_molec(2))cycle
23351            xj=c(1,j+nres)
23352            yj=c(2,j+nres)
23353            zj=c(3,j+nres)
23354            xj=dmod(xj,boxxsize)
23355            if (xj.lt.0) xj=xj+boxxsize
23356            yj=dmod(yj,boxysize)
23357            if (yj.lt.0) yj=yj+boxysize
23358            zj=dmod(zj,boxzsize)
23359            if (zj.lt.0) zj=zj+boxzsize
23360           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23361           xj_safe=xj
23362           yj_safe=yj
23363           zj_safe=zj
23364           subchap=0
23365
23366           do xshift=-1,1
23367           do yshift=-1,1
23368           do zshift=-1,1
23369           xj=xj_safe+xshift*boxxsize
23370           yj=yj_safe+yshift*boxysize
23371           zj=zj_safe+zshift*boxzsize
23372           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23373           if(dist_temp.lt.dist_init) then
23374             dist_init=dist_temp
23375             xj_temp=xj
23376             yj_temp=yj
23377             zj_temp=zj
23378             subchap=1
23379           endif
23380           enddo
23381           enddo
23382           enddo
23383           if (subchap.eq.1) then
23384           xj=xj_temp-xi
23385           yj=yj_temp-yi
23386           zj=zj_temp-zi
23387           else
23388           xj=xj_safe-xi
23389           yj=yj_safe-yi
23390           zj=zj_safe-zi
23391           endif
23392           dxj = dc_norm( 1, nres+j )
23393           dyj = dc_norm( 2, nres+j )
23394           dzj = dc_norm( 3, nres+j )
23395 !          print *,i,j,itypi,itypj
23396           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23397           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23398 !          d1i=0.0d0
23399 !          d1j=0.0d0
23400 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23401 ! Gay-berne var's
23402           sig0ij = sigma_scbase( itypi,itypj )
23403           chi1   = chi_scbase( itypi, itypj,1 )
23404           chi2   = chi_scbase( itypi, itypj,2 )
23405 !          chi1=0.0d0
23406 !          chi2=0.0d0
23407           chi12  = chi1 * chi2
23408           chip1  = chipp_scbase( itypi, itypj,1 )
23409           chip2  = chipp_scbase( itypi, itypj,2 )
23410 !          chip1=0.0d0
23411 !          chip2=0.0d0
23412           chip12 = chip1 * chip2
23413 ! not used by momo potential, but needed by sc_angular which is shared
23414 ! by all energy_potential subroutines
23415           alf1   = 0.0d0
23416           alf2   = 0.0d0
23417           alf12  = 0.0d0
23418           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23419 !       a12sq = a12sq * a12sq
23420 ! charge of amino acid itypi is...
23421           chis1 = chis_scbase(itypi,itypj,1)
23422           chis2 = chis_scbase(itypi,itypj,2)
23423           chis12 = chis1 * chis2
23424           sig1 = sigmap1_scbase(itypi,itypj)
23425           sig2 = sigmap2_scbase(itypi,itypj)
23426 !       write (*,*) "sig1 = ", sig1
23427 !       write (*,*) "sig2 = ", sig2
23428 ! alpha factors from Fcav/Gcav
23429           b1 = alphasur_scbase(1,itypi,itypj)
23430 !          b1=0.0d0
23431           b2 = alphasur_scbase(2,itypi,itypj)
23432           b3 = alphasur_scbase(3,itypi,itypj)
23433           b4 = alphasur_scbase(4,itypi,itypj)
23434 ! used to determine whether we want to do quadrupole calculations
23435 ! used by Fgb
23436        eps_in = epsintab_scbase(itypi,itypj)
23437        if (eps_in.eq.0.0) eps_in=1.0
23438        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23439 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23440 !-------------------------------------------------------------------
23441 ! tail location and distance calculations
23442        DO k = 1,3
23443 ! location of polar head is computed by taking hydrophobic centre
23444 ! and moving by a d1 * dc_norm vector
23445 ! see unres publications for very informative images
23446         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23447         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23448 ! distance
23449 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23450 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23451         Rhead_distance(k) = chead(k,2) - chead(k,1)
23452        END DO
23453 ! pitagoras (root of sum of squares)
23454        Rhead = dsqrt( &
23455           (Rhead_distance(1)*Rhead_distance(1)) &
23456         + (Rhead_distance(2)*Rhead_distance(2)) &
23457         + (Rhead_distance(3)*Rhead_distance(3)))
23458 !-------------------------------------------------------------------
23459 ! zero everything that should be zero'ed
23460        evdwij = 0.0d0
23461        ECL = 0.0d0
23462        Elj = 0.0d0
23463        Equad = 0.0d0
23464        Epol = 0.0d0
23465        Fcav=0.0d0
23466        eheadtail = 0.0d0
23467        dGCLdOM1 = 0.0d0
23468        dGCLdOM2 = 0.0d0
23469        dGCLdOM12 = 0.0d0
23470        dPOLdOM1 = 0.0d0
23471        dPOLdOM2 = 0.0d0
23472           Fcav = 0.0d0
23473           dFdR = 0.0d0
23474           dCAVdOM1  = 0.0d0
23475           dCAVdOM2  = 0.0d0
23476           dCAVdOM12 = 0.0d0
23477           dscj_inv = vbld_inv(j+nres)
23478 !          print *,i,j,dscj_inv,dsci_inv
23479 ! rij holds 1/(distance of Calpha atoms)
23480           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23481           rij  = dsqrt(rrij)
23482 !----------------------------
23483           CALL sc_angular
23484 ! this should be in elgrad_init but om's are calculated by sc_angular
23485 ! which in turn is used by older potentials
23486 ! om = omega, sqom = om^2
23487           sqom1  = om1 * om1
23488           sqom2  = om2 * om2
23489           sqom12 = om12 * om12
23490
23491 ! now we calculate EGB - Gey-Berne
23492 ! It will be summed up in evdwij and saved in evdw
23493           sigsq     = 1.0D0  / sigsq
23494           sig       = sig0ij * dsqrt(sigsq)
23495 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23496           rij_shift = 1.0/rij - sig + sig0ij
23497           IF (rij_shift.le.0.0D0) THEN
23498            evdw = 1.0D20
23499            RETURN
23500           END IF
23501           sigder = -sig * sigsq
23502           rij_shift = 1.0D0 / rij_shift
23503           fac       = rij_shift**expon
23504           c1        = fac  * fac * aa_scbase(itypi,itypj)
23505 !          c1        = 0.0d0
23506           c2        = fac  * bb_scbase(itypi,itypj)
23507 !          c2        = 0.0d0
23508           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23509           eps2der   = eps3rt * evdwij
23510           eps3der   = eps2rt * evdwij
23511 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23512           evdwij    = eps2rt * eps3rt * evdwij
23513           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23514           fac    = -expon * (c1 + evdwij) * rij_shift
23515           sigder = fac * sigder
23516 !          fac    = rij * fac
23517 ! Calculate distance derivative
23518           gg(1) =  fac
23519           gg(2) =  fac
23520           gg(3) =  fac
23521 !          if (b2.gt.0.0) then
23522           fac = chis1 * sqom1 + chis2 * sqom2 &
23523           - 2.0d0 * chis12 * om1 * om2 * om12
23524 ! we will use pom later in Gcav, so dont mess with it!
23525           pom = 1.0d0 - chis1 * chis2 * sqom12
23526           Lambf = (1.0d0 - (fac / pom))
23527           Lambf = dsqrt(Lambf)
23528           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23529 !       write (*,*) "sparrow = ", sparrow
23530           Chif = 1.0d0/rij * sparrow
23531           ChiLambf = Chif * Lambf
23532           eagle = dsqrt(ChiLambf)
23533           bat = ChiLambf ** 11.0d0
23534           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23535           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23536           botsq = bot * bot
23537           Fcav = top / bot
23538 !          print *,i,j,Fcav
23539           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23540           dbot = 12.0d0 * b4 * bat * Lambf
23541           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23542 !       dFdR = 0.0d0
23543 !      write (*,*) "dFcav/dR = ", dFdR
23544           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23545           dbot = 12.0d0 * b4 * bat * Chif
23546           eagle = Lambf * pom
23547           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23548           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23549           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23550               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23551
23552           dFdL = ((dtop * bot - top * dbot) / botsq)
23553 !       dFdL = 0.0d0
23554           dCAVdOM1  = dFdL * ( dFdOM1 )
23555           dCAVdOM2  = dFdL * ( dFdOM2 )
23556           dCAVdOM12 = dFdL * ( dFdOM12 )
23557
23558           ertail(1) = xj*rij
23559           ertail(2) = yj*rij
23560           ertail(3) = zj*rij
23561 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23562 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23563 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23564 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23565 !           print *,"EOMY",eom1,eom2,eom12
23566 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23567 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23568 ! here dtail=0.0
23569 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23570 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23571        DO k = 1, 3
23572 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23573 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23574         pom = ertail(k)
23575 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23576         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23577                   - (( dFdR + gg(k) ) * pom)
23578 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23579 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23580 !     &             - ( dFdR * pom )
23581         pom = ertail(k)
23582 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23583         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23584                   + (( dFdR + gg(k) ) * pom)
23585 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23586 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23587 !c!     &             + ( dFdR * pom )
23588
23589         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23590                   - (( dFdR + gg(k) ) * ertail(k))
23591 !c!     &             - ( dFdR * ertail(k))
23592
23593         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23594                   + (( dFdR + gg(k) ) * ertail(k))
23595 !c!     &             + ( dFdR * ertail(k))
23596
23597         gg(k) = 0.0d0
23598 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23599 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23600       END DO
23601
23602 !          else
23603
23604 !          endif
23605 !Now dipole-dipole
23606          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23607        w1 = wdipdip_scbase(1,itypi,itypj)
23608        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23609        w3 = wdipdip_scbase(2,itypi,itypj)
23610 !c!-------------------------------------------------------------------
23611 !c! ECL
23612        fac = (om12 - 3.0d0 * om1 * om2)
23613        c1 = (w1 / (Rhead**3.0d0)) * fac
23614        c2 = (w2 / Rhead ** 6.0d0)  &
23615          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23616        c3= (w3/ Rhead ** 6.0d0)  &
23617          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23618        ECL = c1 - c2 + c3
23619 !c!       write (*,*) "w1 = ", w1
23620 !c!       write (*,*) "w2 = ", w2
23621 !c!       write (*,*) "om1 = ", om1
23622 !c!       write (*,*) "om2 = ", om2
23623 !c!       write (*,*) "om12 = ", om12
23624 !c!       write (*,*) "fac = ", fac
23625 !c!       write (*,*) "c1 = ", c1
23626 !c!       write (*,*) "c2 = ", c2
23627 !c!       write (*,*) "Ecl = ", Ecl
23628 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23629 !c!       write (*,*) "c2_2 = ",
23630 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23631 !c!-------------------------------------------------------------------
23632 !c! dervative of ECL is GCL...
23633 !c! dECL/dr
23634        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23635        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23636          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23637        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23638          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23639        dGCLdR = c1 - c2 + c3
23640 !c! dECL/dom1
23641        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23642        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23643          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23644        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23645        dGCLdOM1 = c1 - c2 + c3
23646 !c! dECL/dom2
23647        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23648        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23649          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23650        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23651        dGCLdOM2 = c1 - c2 + c3
23652 !c! dECL/dom12
23653        c1 = w1 / (Rhead ** 3.0d0)
23654        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23655        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23656        dGCLdOM12 = c1 - c2 + c3
23657        DO k= 1, 3
23658         erhead(k) = Rhead_distance(k)/Rhead
23659        END DO
23660        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23661        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23662        facd1 = d1i * vbld_inv(i+nres)
23663        facd2 = d1j * vbld_inv(j+nres)
23664        DO k = 1, 3
23665
23666         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23667         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23668                   - dGCLdR * pom
23669         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23670         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23671                   + dGCLdR * pom
23672
23673         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23674                   - dGCLdR * erhead(k)
23675         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23676                   + dGCLdR * erhead(k)
23677        END DO
23678        endif
23679 !now charge with dipole eg. ARG-dG
23680        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23681       alphapol1 = alphapol_scbase(itypi,itypj)
23682        w1        = wqdip_scbase(1,itypi,itypj)
23683        w2        = wqdip_scbase(2,itypi,itypj)
23684 !       w1=0.0d0
23685 !       w2=0.0d0
23686 !       pis       = sig0head_scbase(itypi,itypj)
23687 !       eps_head   = epshead_scbase(itypi,itypj)
23688 !c!-------------------------------------------------------------------
23689 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23690        R1 = 0.0d0
23691        DO k = 1, 3
23692 !c! Calculate head-to-tail distances tail is center of side-chain
23693         R1=R1+(c(k,j+nres)-chead(k,1))**2
23694        END DO
23695 !c! Pitagoras
23696        R1 = dsqrt(R1)
23697
23698 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23699 !c!     &        +dhead(1,1,itypi,itypj))**2))
23700 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23701 !c!     &        +dhead(2,1,itypi,itypj))**2))
23702
23703 !c!-------------------------------------------------------------------
23704 !c! ecl
23705        sparrow  = w1  *  om1
23706        hawk     = w2 *  (1.0d0 - sqom2)
23707        Ecl = sparrow / Rhead**2.0d0 &
23708            - hawk    / Rhead**4.0d0
23709 !c!-------------------------------------------------------------------
23710 !c! derivative of ecl is Gcl
23711 !c! dF/dr part
23712        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23713                 + 4.0d0 * hawk    / Rhead**5.0d0
23714 !c! dF/dom1
23715        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23716 !c! dF/dom2
23717        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23718 !c--------------------------------------------------------------------
23719 !c Polarization energy
23720 !c Epol
23721        MomoFac1 = (1.0d0 - chi1 * sqom2)
23722        RR1  = R1 * R1 / MomoFac1
23723        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23724        fgb1 = sqrt( RR1 + a12sq * ee1)
23725 !       eps_inout_fac=0.0d0
23726        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23727 ! derivative of Epol is Gpol...
23728        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23729                 / (fgb1 ** 5.0d0)
23730        dFGBdR1 = ( (R1 / MomoFac1) &
23731              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23732              / ( 2.0d0 * fgb1 )
23733        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23734                * (2.0d0 - 0.5d0 * ee1) ) &
23735                / (2.0d0 * fgb1)
23736        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23737 !       dPOLdR1 = 0.0d0
23738        dPOLdOM1 = 0.0d0
23739        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23740        DO k = 1, 3
23741         erhead(k) = Rhead_distance(k)/Rhead
23742         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23743        END DO
23744
23745        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23746        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23747        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23748 !       bat=0.0d0
23749        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23750        facd1 = d1i * vbld_inv(i+nres)
23751        facd2 = d1j * vbld_inv(j+nres)
23752 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23753
23754        DO k = 1, 3
23755         hawk = (erhead_tail(k,1) + &
23756         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23757 !        facd1=0.0d0
23758 !        facd2=0.0d0
23759         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23760         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23761                    - dGCLdR * pom &
23762                    - dPOLdR1 *  (erhead_tail(k,1))
23763 !     &             - dGLJdR * pom
23764
23765         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23766         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23767                    + dGCLdR * pom  &
23768                    + dPOLdR1 * (erhead_tail(k,1))
23769 !     &             + dGLJdR * pom
23770
23771
23772         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23773                   - dGCLdR * erhead(k) &
23774                   - dPOLdR1 * erhead_tail(k,1)
23775 !     &             - dGLJdR * erhead(k)
23776
23777         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23778                   + dGCLdR * erhead(k)  &
23779                   + dPOLdR1 * erhead_tail(k,1)
23780 !     &             + dGLJdR * erhead(k)
23781
23782        END DO
23783        endif
23784 !       print *,i,j,evdwij,epol,Fcav,ECL
23785        escbase=escbase+evdwij+epol+Fcav+ECL
23786        call sc_grad_scbase
23787          enddo
23788       enddo
23789
23790       return
23791       end subroutine eprot_sc_base
23792       SUBROUTINE sc_grad_scbase
23793       use calc_data
23794
23795        real (kind=8) :: dcosom1(3),dcosom2(3)
23796        eom1  =    &
23797               eps2der * eps2rt_om1   &
23798             - 2.0D0 * alf1 * eps3der &
23799             + sigder * sigsq_om1     &
23800             + dCAVdOM1               &
23801             + dGCLdOM1               &
23802             + dPOLdOM1
23803
23804        eom2  =  &
23805               eps2der * eps2rt_om2   &
23806             + 2.0D0 * alf2 * eps3der &
23807             + sigder * sigsq_om2     &
23808             + dCAVdOM2               &
23809             + dGCLdOM2               &
23810             + dPOLdOM2
23811
23812        eom12 =    &
23813               evdwij  * eps1_om12     &
23814             + eps2der * eps2rt_om12   &
23815             - 2.0D0 * alf12 * eps3der &
23816             + sigder *sigsq_om12      &
23817             + dCAVdOM12               &
23818             + dGCLdOM12
23819
23820 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23821 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23822 !               gg(1),gg(2),"rozne"
23823        DO k = 1, 3
23824         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23825         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23826         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23827         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23828                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23829                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23830         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23831                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23832                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23833         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23834         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23835        END DO
23836        RETURN
23837       END SUBROUTINE sc_grad_scbase
23838
23839
23840       subroutine epep_sc_base(epepbase)
23841       use calc_data
23842       logical :: lprn
23843 !el local variables
23844       integer :: iint,itypi,itypi1,itypj,subchap
23845       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23846       real(kind=8) :: evdw,sig0ij
23847       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23848                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23849                     sslipi,sslipj,faclip
23850       integer :: ii
23851       real(kind=8) :: fracinbuf
23852        real (kind=8) :: epepbase
23853        real (kind=8),dimension(4):: ener
23854        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23855        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23856         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23857         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23858         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23859         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23860         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23861         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23862        real(kind=8),dimension(3,2)::chead,erhead_tail
23863        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23864        integer troll
23865        eps_out=80.0d0
23866        epepbase=0.0d0
23867 !       do i=1,nres_molec(1)-1
23868         do i=ibond_start,ibond_end
23869         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23870 !C        itypi  = itype(i,1)
23871         dxi    = dc_norm(1,i)
23872         dyi    = dc_norm(2,i)
23873         dzi    = dc_norm(3,i)
23874 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23875         dsci_inv = vbld_inv(i+1)/2.0
23876         xi=(c(1,i)+c(1,i+1))/2.0
23877         yi=(c(2,i)+c(2,i+1))/2.0
23878         zi=(c(3,i)+c(3,i+1))/2.0
23879         xi=mod(xi,boxxsize)
23880          if (xi.lt.0) xi=xi+boxxsize
23881         yi=mod(yi,boxysize)
23882          if (yi.lt.0) yi=yi+boxysize
23883         zi=mod(zi,boxzsize)
23884          if (zi.lt.0) zi=zi+boxzsize
23885          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23886            itypj= itype(j,2)
23887            if (itype(j,2).eq.ntyp1_molec(2))cycle
23888            xj=c(1,j+nres)
23889            yj=c(2,j+nres)
23890            zj=c(3,j+nres)
23891            xj=dmod(xj,boxxsize)
23892            if (xj.lt.0) xj=xj+boxxsize
23893            yj=dmod(yj,boxysize)
23894            if (yj.lt.0) yj=yj+boxysize
23895            zj=dmod(zj,boxzsize)
23896            if (zj.lt.0) zj=zj+boxzsize
23897           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23898           xj_safe=xj
23899           yj_safe=yj
23900           zj_safe=zj
23901           subchap=0
23902
23903           do xshift=-1,1
23904           do yshift=-1,1
23905           do zshift=-1,1
23906           xj=xj_safe+xshift*boxxsize
23907           yj=yj_safe+yshift*boxysize
23908           zj=zj_safe+zshift*boxzsize
23909           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23910           if(dist_temp.lt.dist_init) then
23911             dist_init=dist_temp
23912             xj_temp=xj
23913             yj_temp=yj
23914             zj_temp=zj
23915             subchap=1
23916           endif
23917           enddo
23918           enddo
23919           enddo
23920           if (subchap.eq.1) then
23921           xj=xj_temp-xi
23922           yj=yj_temp-yi
23923           zj=zj_temp-zi
23924           else
23925           xj=xj_safe-xi
23926           yj=yj_safe-yi
23927           zj=zj_safe-zi
23928           endif
23929           dxj = dc_norm( 1, nres+j )
23930           dyj = dc_norm( 2, nres+j )
23931           dzj = dc_norm( 3, nres+j )
23932 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23933 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23934
23935 ! Gay-berne var's
23936           sig0ij = sigma_pepbase(itypj )
23937           chi1   = chi_pepbase(itypj,1 )
23938           chi2   = chi_pepbase(itypj,2 )
23939 !          chi1=0.0d0
23940 !          chi2=0.0d0
23941           chi12  = chi1 * chi2
23942           chip1  = chipp_pepbase(itypj,1 )
23943           chip2  = chipp_pepbase(itypj,2 )
23944 !          chip1=0.0d0
23945 !          chip2=0.0d0
23946           chip12 = chip1 * chip2
23947           chis1 = chis_pepbase(itypj,1)
23948           chis2 = chis_pepbase(itypj,2)
23949           chis12 = chis1 * chis2
23950           sig1 = sigmap1_pepbase(itypj)
23951           sig2 = sigmap2_pepbase(itypj)
23952 !       write (*,*) "sig1 = ", sig1
23953 !       write (*,*) "sig2 = ", sig2
23954        DO k = 1,3
23955 ! location of polar head is computed by taking hydrophobic centre
23956 ! and moving by a d1 * dc_norm vector
23957 ! see unres publications for very informative images
23958         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23959 ! + d1i * dc_norm(k, i+nres)
23960         chead(k,2) = c(k, j+nres)
23961 ! + d1j * dc_norm(k, j+nres)
23962 ! distance
23963 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23964 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23965         Rhead_distance(k) = chead(k,2) - chead(k,1)
23966 !        print *,gvdwc_pepbase(k,i)
23967
23968        END DO
23969        Rhead = dsqrt( &
23970           (Rhead_distance(1)*Rhead_distance(1)) &
23971         + (Rhead_distance(2)*Rhead_distance(2)) &
23972         + (Rhead_distance(3)*Rhead_distance(3)))
23973
23974 ! alpha factors from Fcav/Gcav
23975           b1 = alphasur_pepbase(1,itypj)
23976 !          b1=0.0d0
23977           b2 = alphasur_pepbase(2,itypj)
23978           b3 = alphasur_pepbase(3,itypj)
23979           b4 = alphasur_pepbase(4,itypj)
23980           alf1   = 0.0d0
23981           alf2   = 0.0d0
23982           alf12  = 0.0d0
23983           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23984 !          print *,i,j,rrij
23985           rij  = dsqrt(rrij)
23986 !----------------------------
23987        evdwij = 0.0d0
23988        ECL = 0.0d0
23989        Elj = 0.0d0
23990        Equad = 0.0d0
23991        Epol = 0.0d0
23992        Fcav=0.0d0
23993        eheadtail = 0.0d0
23994        dGCLdOM1 = 0.0d0
23995        dGCLdOM2 = 0.0d0
23996        dGCLdOM12 = 0.0d0
23997        dPOLdOM1 = 0.0d0
23998        dPOLdOM2 = 0.0d0
23999           Fcav = 0.0d0
24000           dFdR = 0.0d0
24001           dCAVdOM1  = 0.0d0
24002           dCAVdOM2  = 0.0d0
24003           dCAVdOM12 = 0.0d0
24004           dscj_inv = vbld_inv(j+nres)
24005           CALL sc_angular
24006 ! this should be in elgrad_init but om's are calculated by sc_angular
24007 ! which in turn is used by older potentials
24008 ! om = omega, sqom = om^2
24009           sqom1  = om1 * om1
24010           sqom2  = om2 * om2
24011           sqom12 = om12 * om12
24012
24013 ! now we calculate EGB - Gey-Berne
24014 ! It will be summed up in evdwij and saved in evdw
24015           sigsq     = 1.0D0  / sigsq
24016           sig       = sig0ij * dsqrt(sigsq)
24017           rij_shift = 1.0/rij - sig + sig0ij
24018           IF (rij_shift.le.0.0D0) THEN
24019            evdw = 1.0D20
24020            RETURN
24021           END IF
24022           sigder = -sig * sigsq
24023           rij_shift = 1.0D0 / rij_shift
24024           fac       = rij_shift**expon
24025           c1        = fac  * fac * aa_pepbase(itypj)
24026 !          c1        = 0.0d0
24027           c2        = fac  * bb_pepbase(itypj)
24028 !          c2        = 0.0d0
24029           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24030           eps2der   = eps3rt * evdwij
24031           eps3der   = eps2rt * evdwij
24032 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24033           evdwij    = eps2rt * eps3rt * evdwij
24034           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24035           fac    = -expon * (c1 + evdwij) * rij_shift
24036           sigder = fac * sigder
24037 !          fac    = rij * fac
24038 ! Calculate distance derivative
24039           gg(1) =  fac
24040           gg(2) =  fac
24041           gg(3) =  fac
24042           fac = chis1 * sqom1 + chis2 * sqom2 &
24043           - 2.0d0 * chis12 * om1 * om2 * om12
24044 ! we will use pom later in Gcav, so dont mess with it!
24045           pom = 1.0d0 - chis1 * chis2 * sqom12
24046           Lambf = (1.0d0 - (fac / pom))
24047           Lambf = dsqrt(Lambf)
24048           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24049 !       write (*,*) "sparrow = ", sparrow
24050           Chif = 1.0d0/rij * sparrow
24051           ChiLambf = Chif * Lambf
24052           eagle = dsqrt(ChiLambf)
24053           bat = ChiLambf ** 11.0d0
24054           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24055           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24056           botsq = bot * bot
24057           Fcav = top / bot
24058 !          print *,i,j,Fcav
24059           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24060           dbot = 12.0d0 * b4 * bat * Lambf
24061           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24062 !       dFdR = 0.0d0
24063 !      write (*,*) "dFcav/dR = ", dFdR
24064           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24065           dbot = 12.0d0 * b4 * bat * Chif
24066           eagle = Lambf * pom
24067           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24068           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24069           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24070               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24071
24072           dFdL = ((dtop * bot - top * dbot) / botsq)
24073 !       dFdL = 0.0d0
24074           dCAVdOM1  = dFdL * ( dFdOM1 )
24075           dCAVdOM2  = dFdL * ( dFdOM2 )
24076           dCAVdOM12 = dFdL * ( dFdOM12 )
24077
24078           ertail(1) = xj*rij
24079           ertail(2) = yj*rij
24080           ertail(3) = zj*rij
24081        DO k = 1, 3
24082 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24083 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24084         pom = ertail(k)
24085 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24086         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24087                   - (( dFdR + gg(k) ) * pom)/2.0
24088 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24089 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24090 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24091 !     &             - ( dFdR * pom )
24092         pom = ertail(k)
24093 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24094         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24095                   + (( dFdR + gg(k) ) * pom)
24096 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24097 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24098 !c!     &             + ( dFdR * pom )
24099
24100         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24101                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24102 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24103
24104 !c!     &             - ( dFdR * ertail(k))
24105
24106         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24107                   + (( dFdR + gg(k) ) * ertail(k))
24108 !c!     &             + ( dFdR * ertail(k))
24109
24110         gg(k) = 0.0d0
24111 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24112 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24113       END DO
24114
24115
24116        w1 = wdipdip_pepbase(1,itypj)
24117        w2 = -wdipdip_pepbase(3,itypj)/2.0
24118        w3 = wdipdip_pepbase(2,itypj)
24119 !       w1=0.0d0
24120 !       w2=0.0d0
24121 !c!-------------------------------------------------------------------
24122 !c! ECL
24123 !       w3=0.0d0
24124        fac = (om12 - 3.0d0 * om1 * om2)
24125        c1 = (w1 / (Rhead**3.0d0)) * fac
24126        c2 = (w2 / Rhead ** 6.0d0)  &
24127          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24128        c3= (w3/ Rhead ** 6.0d0)  &
24129          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24130
24131        ECL = c1 - c2 + c3
24132
24133        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24134        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24135          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24136        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24137          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24138
24139        dGCLdR = c1 - c2 + c3
24140 !c! dECL/dom1
24141        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24142        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24143          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24144        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24145        dGCLdOM1 = c1 - c2 + c3
24146 !c! dECL/dom2
24147        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24148        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24149          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24150        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24151
24152        dGCLdOM2 = c1 - c2 + c3
24153 !c! dECL/dom12
24154        c1 = w1 / (Rhead ** 3.0d0)
24155        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24156        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24157        dGCLdOM12 = c1 - c2 + c3
24158        DO k= 1, 3
24159         erhead(k) = Rhead_distance(k)/Rhead
24160        END DO
24161        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24162        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24163 !       facd1 = d1 * vbld_inv(i+nres)
24164 !       facd2 = d2 * vbld_inv(j+nres)
24165        DO k = 1, 3
24166
24167 !        pom = erhead(k)
24168 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24169 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24170 !                  - dGCLdR * pom
24171         pom = erhead(k)
24172 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24173         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24174                   + dGCLdR * pom
24175
24176         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24177                   - dGCLdR * erhead(k)/2.0d0
24178 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24179         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24180                   - dGCLdR * erhead(k)/2.0d0
24181 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24182         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24183                   + dGCLdR * erhead(k)
24184        END DO
24185 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24186        epepbase=epepbase+evdwij+Fcav+ECL
24187        call sc_grad_pepbase
24188        enddo
24189        enddo
24190       END SUBROUTINE epep_sc_base
24191       SUBROUTINE sc_grad_pepbase
24192       use calc_data
24193
24194        real (kind=8) :: dcosom1(3),dcosom2(3)
24195        eom1  =    &
24196               eps2der * eps2rt_om1   &
24197             - 2.0D0 * alf1 * eps3der &
24198             + sigder * sigsq_om1     &
24199             + dCAVdOM1               &
24200             + dGCLdOM1               &
24201             + dPOLdOM1
24202
24203        eom2  =  &
24204               eps2der * eps2rt_om2   &
24205             + 2.0D0 * alf2 * eps3der &
24206             + sigder * sigsq_om2     &
24207             + dCAVdOM2               &
24208             + dGCLdOM2               &
24209             + dPOLdOM2
24210
24211        eom12 =    &
24212               evdwij  * eps1_om12     &
24213             + eps2der * eps2rt_om12   &
24214             - 2.0D0 * alf12 * eps3der &
24215             + sigder *sigsq_om12      &
24216             + dCAVdOM12               &
24217             + dGCLdOM12
24218 !        om12=0.0
24219 !        eom12=0.0
24220 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24221 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24222 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24223 !                 *dsci_inv*2.0
24224 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24225 !               gg(1),gg(2),"rozne"
24226        DO k = 1, 3
24227         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24228         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24229         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24230         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24231                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24232                  *dsci_inv*2.0 &
24233                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24234         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24235                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24236                  *dsci_inv*2.0 &
24237                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24238 !         print *,eom12,eom2,om12,om2
24239 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24240 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24241         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24242                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24243                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24244         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24245        END DO
24246        RETURN
24247       END SUBROUTINE sc_grad_pepbase
24248       subroutine eprot_sc_phosphate(escpho)
24249       use calc_data
24250 !      implicit real*8 (a-h,o-z)
24251 !      include 'DIMENSIONS'
24252 !      include 'COMMON.GEO'
24253 !      include 'COMMON.VAR'
24254 !      include 'COMMON.LOCAL'
24255 !      include 'COMMON.CHAIN'
24256 !      include 'COMMON.DERIV'
24257 !      include 'COMMON.NAMES'
24258 !      include 'COMMON.INTERACT'
24259 !      include 'COMMON.IOUNITS'
24260 !      include 'COMMON.CALC'
24261 !      include 'COMMON.CONTROL'
24262 !      include 'COMMON.SBRIDGE'
24263       logical :: lprn
24264 !el local variables
24265       integer :: iint,itypi,itypi1,itypj,subchap
24266       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24267       real(kind=8) :: evdw,sig0ij
24268       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24269                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24270                     sslipi,sslipj,faclip,alpha_sco
24271       integer :: ii
24272       real(kind=8) :: fracinbuf
24273        real (kind=8) :: escpho
24274        real (kind=8),dimension(4):: ener
24275        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24276        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24277         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24278         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24279         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24280         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24281         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24282         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24283        real(kind=8),dimension(3,2)::chead,erhead_tail
24284        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24285        integer troll
24286        eps_out=80.0d0
24287        escpho=0.0d0
24288 !       do i=1,nres_molec(1)
24289         do i=ibond_start,ibond_end
24290         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24291         itypi  = itype(i,1)
24292         dxi    = dc_norm(1,nres+i)
24293         dyi    = dc_norm(2,nres+i)
24294         dzi    = dc_norm(3,nres+i)
24295         dsci_inv = vbld_inv(i+nres)
24296         xi=c(1,nres+i)
24297         yi=c(2,nres+i)
24298         zi=c(3,nres+i)
24299         xi=mod(xi,boxxsize)
24300          if (xi.lt.0) xi=xi+boxxsize
24301         yi=mod(yi,boxysize)
24302          if (yi.lt.0) yi=yi+boxysize
24303         zi=mod(zi,boxzsize)
24304          if (zi.lt.0) zi=zi+boxzsize
24305          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24306            itypj= itype(j,2)
24307            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24308             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24309            xj=(c(1,j)+c(1,j+1))/2.0
24310            yj=(c(2,j)+c(2,j+1))/2.0
24311            zj=(c(3,j)+c(3,j+1))/2.0
24312            xj=dmod(xj,boxxsize)
24313            if (xj.lt.0) xj=xj+boxxsize
24314            yj=dmod(yj,boxysize)
24315            if (yj.lt.0) yj=yj+boxysize
24316            zj=dmod(zj,boxzsize)
24317            if (zj.lt.0) zj=zj+boxzsize
24318           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24319           xj_safe=xj
24320           yj_safe=yj
24321           zj_safe=zj
24322           subchap=0
24323           do xshift=-1,1
24324           do yshift=-1,1
24325           do zshift=-1,1
24326           xj=xj_safe+xshift*boxxsize
24327           yj=yj_safe+yshift*boxysize
24328           zj=zj_safe+zshift*boxzsize
24329           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24330           if(dist_temp.lt.dist_init) then
24331             dist_init=dist_temp
24332             xj_temp=xj
24333             yj_temp=yj
24334             zj_temp=zj
24335             subchap=1
24336           endif
24337           enddo
24338           enddo
24339           enddo
24340           if (subchap.eq.1) then
24341           xj=xj_temp-xi
24342           yj=yj_temp-yi
24343           zj=zj_temp-zi
24344           else
24345           xj=xj_safe-xi
24346           yj=yj_safe-yi
24347           zj=zj_safe-zi
24348           endif
24349           dxj = dc_norm( 1,j )
24350           dyj = dc_norm( 2,j )
24351           dzj = dc_norm( 3,j )
24352           dscj_inv = vbld_inv(j+1)
24353
24354 ! Gay-berne var's
24355           sig0ij = sigma_scpho(itypi )
24356           chi1   = chi_scpho(itypi,1 )
24357           chi2   = chi_scpho(itypi,2 )
24358 !          chi1=0.0d0
24359 !          chi2=0.0d0
24360           chi12  = chi1 * chi2
24361           chip1  = chipp_scpho(itypi,1 )
24362           chip2  = chipp_scpho(itypi,2 )
24363 !          chip1=0.0d0
24364 !          chip2=0.0d0
24365           chip12 = chip1 * chip2
24366           chis1 = chis_scpho(itypi,1)
24367           chis2 = chis_scpho(itypi,2)
24368           chis12 = chis1 * chis2
24369           sig1 = sigmap1_scpho(itypi)
24370           sig2 = sigmap2_scpho(itypi)
24371 !       write (*,*) "sig1 = ", sig1
24372 !       write (*,*) "sig1 = ", sig1
24373 !       write (*,*) "sig2 = ", sig2
24374 ! alpha factors from Fcav/Gcav
24375           alf1   = 0.0d0
24376           alf2   = 0.0d0
24377           alf12  = 0.0d0
24378           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24379
24380           b1 = alphasur_scpho(1,itypi)
24381 !          b1=0.0d0
24382           b2 = alphasur_scpho(2,itypi)
24383           b3 = alphasur_scpho(3,itypi)
24384           b4 = alphasur_scpho(4,itypi)
24385 ! used to determine whether we want to do quadrupole calculations
24386 ! used by Fgb
24387        eps_in = epsintab_scpho(itypi)
24388        if (eps_in.eq.0.0) eps_in=1.0
24389        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24390 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24391 !-------------------------------------------------------------------
24392 ! tail location and distance calculations
24393           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24394           d1j = 0.0
24395        DO k = 1,3
24396 ! location of polar head is computed by taking hydrophobic centre
24397 ! and moving by a d1 * dc_norm vector
24398 ! see unres publications for very informative images
24399         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24400         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24401 ! distance
24402 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24403 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24404         Rhead_distance(k) = chead(k,2) - chead(k,1)
24405        END DO
24406 ! pitagoras (root of sum of squares)
24407        Rhead = dsqrt( &
24408           (Rhead_distance(1)*Rhead_distance(1)) &
24409         + (Rhead_distance(2)*Rhead_distance(2)) &
24410         + (Rhead_distance(3)*Rhead_distance(3)))
24411        Rhead_sq=Rhead**2.0
24412 !-------------------------------------------------------------------
24413 ! zero everything that should be zero'ed
24414        evdwij = 0.0d0
24415        ECL = 0.0d0
24416        Elj = 0.0d0
24417        Equad = 0.0d0
24418        Epol = 0.0d0
24419        Fcav=0.0d0
24420        eheadtail = 0.0d0
24421        dGCLdR=0.0d0
24422        dGCLdOM1 = 0.0d0
24423        dGCLdOM2 = 0.0d0
24424        dGCLdOM12 = 0.0d0
24425        dPOLdOM1 = 0.0d0
24426        dPOLdOM2 = 0.0d0
24427           Fcav = 0.0d0
24428           dFdR = 0.0d0
24429           dCAVdOM1  = 0.0d0
24430           dCAVdOM2  = 0.0d0
24431           dCAVdOM12 = 0.0d0
24432           dscj_inv = vbld_inv(j+1)/2.0
24433 !dhead_scbasej(itypi,itypj)
24434 !          print *,i,j,dscj_inv,dsci_inv
24435 ! rij holds 1/(distance of Calpha atoms)
24436           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24437           rij  = dsqrt(rrij)
24438 !----------------------------
24439           CALL sc_angular
24440 ! this should be in elgrad_init but om's are calculated by sc_angular
24441 ! which in turn is used by older potentials
24442 ! om = omega, sqom = om^2
24443           sqom1  = om1 * om1
24444           sqom2  = om2 * om2
24445           sqom12 = om12 * om12
24446
24447 ! now we calculate EGB - Gey-Berne
24448 ! It will be summed up in evdwij and saved in evdw
24449           sigsq     = 1.0D0  / sigsq
24450           sig       = sig0ij * dsqrt(sigsq)
24451 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24452           rij_shift = 1.0/rij - sig + sig0ij
24453           IF (rij_shift.le.0.0D0) THEN
24454            evdw = 1.0D20
24455            RETURN
24456           END IF
24457           sigder = -sig * sigsq
24458           rij_shift = 1.0D0 / rij_shift
24459           fac       = rij_shift**expon
24460           c1        = fac  * fac * aa_scpho(itypi)
24461 !          c1        = 0.0d0
24462           c2        = fac  * bb_scpho(itypi)
24463 !          c2        = 0.0d0
24464           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24465           eps2der   = eps3rt * evdwij
24466           eps3der   = eps2rt * evdwij
24467 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24468           evdwij    = eps2rt * eps3rt * evdwij
24469           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24470           fac    = -expon * (c1 + evdwij) * rij_shift
24471           sigder = fac * sigder
24472 !          fac    = rij * fac
24473 ! Calculate distance derivative
24474           gg(1) =  fac
24475           gg(2) =  fac
24476           gg(3) =  fac
24477           fac = chis1 * sqom1 + chis2 * sqom2 &
24478           - 2.0d0 * chis12 * om1 * om2 * om12
24479 ! we will use pom later in Gcav, so dont mess with it!
24480           pom = 1.0d0 - chis1 * chis2 * sqom12
24481           Lambf = (1.0d0 - (fac / pom))
24482           Lambf = dsqrt(Lambf)
24483           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24484 !       write (*,*) "sparrow = ", sparrow
24485           Chif = 1.0d0/rij * sparrow
24486           ChiLambf = Chif * Lambf
24487           eagle = dsqrt(ChiLambf)
24488           bat = ChiLambf ** 11.0d0
24489           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24490           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24491           botsq = bot * bot
24492           Fcav = top / bot
24493           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24494           dbot = 12.0d0 * b4 * bat * Lambf
24495           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24496 !       dFdR = 0.0d0
24497 !      write (*,*) "dFcav/dR = ", dFdR
24498           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24499           dbot = 12.0d0 * b4 * bat * Chif
24500           eagle = Lambf * pom
24501           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24502           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24503           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24504               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24505
24506           dFdL = ((dtop * bot - top * dbot) / botsq)
24507 !       dFdL = 0.0d0
24508           dCAVdOM1  = dFdL * ( dFdOM1 )
24509           dCAVdOM2  = dFdL * ( dFdOM2 )
24510           dCAVdOM12 = dFdL * ( dFdOM12 )
24511
24512           ertail(1) = xj*rij
24513           ertail(2) = yj*rij
24514           ertail(3) = zj*rij
24515        DO k = 1, 3
24516 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24517 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24518 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24519
24520         pom = ertail(k)
24521 !        print *,pom,gg(k),dFdR
24522 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24523         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24524                   - (( dFdR + gg(k) ) * pom)
24525 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24526 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24527 !     &             - ( dFdR * pom )
24528 !        pom = ertail(k)
24529 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24530 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24531 !                  + (( dFdR + gg(k) ) * pom)
24532 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24533 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24534 !c!     &             + ( dFdR * pom )
24535
24536         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24537                   - (( dFdR + gg(k) ) * ertail(k))
24538 !c!     &             - ( dFdR * ertail(k))
24539
24540         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24541                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24542
24543         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24544                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24545
24546 !c!     &             + ( dFdR * ertail(k))
24547
24548         gg(k) = 0.0d0
24549         ENDDO
24550 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24551 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24552 !      alphapol1 = alphapol_scpho(itypi)
24553        if (wqq_scpho(itypi).ne.0.0) then
24554        Qij=wqq_scpho(itypi)/eps_in
24555        alpha_sco=1.d0/alphi_scpho(itypi)
24556 !       Qij=0.0
24557        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24558 !c! derivative of Ecl is Gcl...
24559        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24560                 (Rhead*alpha_sco+1) ) / Rhead_sq
24561        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24562        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24563        w1        = wqdip_scpho(1,itypi)
24564        w2        = wqdip_scpho(2,itypi)
24565 !       w1=0.0d0
24566 !       w2=0.0d0
24567 !       pis       = sig0head_scbase(itypi,itypj)
24568 !       eps_head   = epshead_scbase(itypi,itypj)
24569 !c!-------------------------------------------------------------------
24570
24571 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24572 !c!     &        +dhead(1,1,itypi,itypj))**2))
24573 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24574 !c!     &        +dhead(2,1,itypi,itypj))**2))
24575
24576 !c!-------------------------------------------------------------------
24577 !c! ecl
24578        sparrow  = w1  *  om1
24579        hawk     = w2 *  (1.0d0 - sqom2)
24580        Ecl = sparrow / Rhead**2.0d0 &
24581            - hawk    / Rhead**4.0d0
24582 !c!-------------------------------------------------------------------
24583        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24584            1.0/rij,sparrow
24585
24586 !c! derivative of ecl is Gcl
24587 !c! dF/dr part
24588        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24589                 + 4.0d0 * hawk    / Rhead**5.0d0
24590 !c! dF/dom1
24591        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24592 !c! dF/dom2
24593        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24594        endif
24595
24596 !c--------------------------------------------------------------------
24597 !c Polarization energy
24598 !c Epol
24599        R1 = 0.0d0
24600        DO k = 1, 3
24601 !c! Calculate head-to-tail distances tail is center of side-chain
24602         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24603        END DO
24604 !c! Pitagoras
24605        R1 = dsqrt(R1)
24606
24607       alphapol1 = alphapol_scpho(itypi)
24608 !      alphapol1=0.0
24609        MomoFac1 = (1.0d0 - chi2 * sqom1)
24610        RR1  = R1 * R1 / MomoFac1
24611        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24612 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24613        fgb1 = sqrt( RR1 + a12sq * ee1)
24614 !       eps_inout_fac=0.0d0
24615        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24616 ! derivative of Epol is Gpol...
24617        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24618                 / (fgb1 ** 5.0d0)
24619        dFGBdR1 = ( (R1 / MomoFac1) &
24620              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24621              / ( 2.0d0 * fgb1 )
24622        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24623                * (2.0d0 - 0.5d0 * ee1) ) &
24624                / (2.0d0 * fgb1)
24625        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24626 !       dPOLdR1 = 0.0d0
24627 !       dPOLdOM1 = 0.0d0
24628        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24629                * (2.0d0 - 0.5d0 * ee1) ) &
24630                / (2.0d0 * fgb1)
24631
24632        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24633        dPOLdOM2 = 0.0
24634        DO k = 1, 3
24635         erhead(k) = Rhead_distance(k)/Rhead
24636         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24637        END DO
24638
24639        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24640        erdxj = scalar( erhead(1), dC_norm(1,j) )
24641        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24642 !       bat=0.0d0
24643        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24644        facd1 = d1i * vbld_inv(i+nres)
24645        facd2 = d1j * vbld_inv(j)
24646 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24647
24648        DO k = 1, 3
24649         hawk = (erhead_tail(k,1) + &
24650         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24651 !        facd1=0.0d0
24652 !        facd2=0.0d0
24653 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24654 !                pom,(erhead_tail(k,1))
24655
24656 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24657         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24658         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24659                    - dGCLdR * pom &
24660                    - dPOLdR1 *  (erhead_tail(k,1))
24661 !     &             - dGLJdR * pom
24662
24663         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24664 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24665 !                   + dGCLdR * pom  &
24666 !                   + dPOLdR1 * (erhead_tail(k,1))
24667 !     &             + dGLJdR * pom
24668
24669
24670         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24671                   - dGCLdR * erhead(k) &
24672                   - dPOLdR1 * erhead_tail(k,1)
24673 !     &             - dGLJdR * erhead(k)
24674
24675         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24676                   + (dGCLdR * erhead(k)  &
24677                   + dPOLdR1 * erhead_tail(k,1))/2.0
24678         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24679                   + (dGCLdR * erhead(k)  &
24680                   + dPOLdR1 * erhead_tail(k,1))/2.0
24681
24682 !     &             + dGLJdR * erhead(k)
24683 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24684
24685        END DO
24686 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24687        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24688         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24689        escpho=escpho+evdwij+epol+Fcav+ECL
24690        call sc_grad_scpho
24691          enddo
24692
24693       enddo
24694
24695       return
24696       end subroutine eprot_sc_phosphate
24697       SUBROUTINE sc_grad_scpho
24698       use calc_data
24699
24700        real (kind=8) :: dcosom1(3),dcosom2(3)
24701        eom1  =    &
24702               eps2der * eps2rt_om1   &
24703             - 2.0D0 * alf1 * eps3der &
24704             + sigder * sigsq_om1     &
24705             + dCAVdOM1               &
24706             + dGCLdOM1               &
24707             + dPOLdOM1
24708
24709        eom2  =  &
24710               eps2der * eps2rt_om2   &
24711             + 2.0D0 * alf2 * eps3der &
24712             + sigder * sigsq_om2     &
24713             + dCAVdOM2               &
24714             + dGCLdOM2               &
24715             + dPOLdOM2
24716
24717        eom12 =    &
24718               evdwij  * eps1_om12     &
24719             + eps2der * eps2rt_om12   &
24720             - 2.0D0 * alf12 * eps3der &
24721             + sigder *sigsq_om12      &
24722             + dCAVdOM12               &
24723             + dGCLdOM12
24724 !        om12=0.0
24725 !        eom12=0.0
24726 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24727 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24728 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24729 !                 *dsci_inv*2.0
24730 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24731 !               gg(1),gg(2),"rozne"
24732        DO k = 1, 3
24733         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24734         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24735         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24736         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24737                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24738                  *dscj_inv*2.0 &
24739                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24740         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24741                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24742                  *dscj_inv*2.0 &
24743                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24744         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24745                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24746                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24747
24748 !         print *,eom12,eom2,om12,om2
24749 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24750 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24751 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24752 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24753 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24754         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24755        END DO
24756        RETURN
24757       END SUBROUTINE sc_grad_scpho
24758       subroutine eprot_pep_phosphate(epeppho)
24759       use calc_data
24760 !      implicit real*8 (a-h,o-z)
24761 !      include 'DIMENSIONS'
24762 !      include 'COMMON.GEO'
24763 !      include 'COMMON.VAR'
24764 !      include 'COMMON.LOCAL'
24765 !      include 'COMMON.CHAIN'
24766 !      include 'COMMON.DERIV'
24767 !      include 'COMMON.NAMES'
24768 !      include 'COMMON.INTERACT'
24769 !      include 'COMMON.IOUNITS'
24770 !      include 'COMMON.CALC'
24771 !      include 'COMMON.CONTROL'
24772 !      include 'COMMON.SBRIDGE'
24773       logical :: lprn
24774 !el local variables
24775       integer :: iint,itypi,itypi1,itypj,subchap
24776       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24777       real(kind=8) :: evdw,sig0ij
24778       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24779                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24780                     sslipi,sslipj,faclip
24781       integer :: ii
24782       real(kind=8) :: fracinbuf
24783        real (kind=8) :: epeppho
24784        real (kind=8),dimension(4):: ener
24785        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24786        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24787         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24788         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24789         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24790         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24791         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24792         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24793        real(kind=8),dimension(3,2)::chead,erhead_tail
24794        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24795        integer troll
24796        real (kind=8) :: dcosom1(3),dcosom2(3)
24797        epeppho=0.0d0
24798 !       do i=1,nres_molec(1)
24799         do i=ibond_start,ibond_end
24800         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24801         itypi  = itype(i,1)
24802         dsci_inv = vbld_inv(i+1)/2.0
24803         dxi    = dc_norm(1,i)
24804         dyi    = dc_norm(2,i)
24805         dzi    = dc_norm(3,i)
24806         xi=(c(1,i)+c(1,i+1))/2.0
24807         yi=(c(2,i)+c(2,i+1))/2.0
24808         zi=(c(3,i)+c(3,i+1))/2.0
24809         xi=mod(xi,boxxsize)
24810          if (xi.lt.0) xi=xi+boxxsize
24811         yi=mod(yi,boxysize)
24812          if (yi.lt.0) yi=yi+boxysize
24813         zi=mod(zi,boxzsize)
24814          if (zi.lt.0) zi=zi+boxzsize
24815          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24816            itypj= itype(j,2)
24817            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24818             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24819            xj=(c(1,j)+c(1,j+1))/2.0
24820            yj=(c(2,j)+c(2,j+1))/2.0
24821            zj=(c(3,j)+c(3,j+1))/2.0
24822            xj=dmod(xj,boxxsize)
24823            if (xj.lt.0) xj=xj+boxxsize
24824            yj=dmod(yj,boxysize)
24825            if (yj.lt.0) yj=yj+boxysize
24826            zj=dmod(zj,boxzsize)
24827            if (zj.lt.0) zj=zj+boxzsize
24828           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24829           xj_safe=xj
24830           yj_safe=yj
24831           zj_safe=zj
24832           subchap=0
24833           do xshift=-1,1
24834           do yshift=-1,1
24835           do zshift=-1,1
24836           xj=xj_safe+xshift*boxxsize
24837           yj=yj_safe+yshift*boxysize
24838           zj=zj_safe+zshift*boxzsize
24839           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24840           if(dist_temp.lt.dist_init) then
24841             dist_init=dist_temp
24842             xj_temp=xj
24843             yj_temp=yj
24844             zj_temp=zj
24845             subchap=1
24846           endif
24847           enddo
24848           enddo
24849           enddo
24850           if (subchap.eq.1) then
24851           xj=xj_temp-xi
24852           yj=yj_temp-yi
24853           zj=zj_temp-zi
24854           else
24855           xj=xj_safe-xi
24856           yj=yj_safe-yi
24857           zj=zj_safe-zi
24858           endif
24859           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24860           rij  = dsqrt(rrij)
24861           dxj = dc_norm( 1,j )
24862           dyj = dc_norm( 2,j )
24863           dzj = dc_norm( 3,j )
24864           dscj_inv = vbld_inv(j+1)/2.0
24865 ! Gay-berne var's
24866           sig0ij = sigma_peppho
24867 !          chi1=0.0d0
24868 !          chi2=0.0d0
24869           chi12  = chi1 * chi2
24870 !          chip1=0.0d0
24871 !          chip2=0.0d0
24872           chip12 = chip1 * chip2
24873 !          chis1 = 0.0d0
24874 !          chis2 = 0.0d0
24875           chis12 = chis1 * chis2
24876           sig1 = sigmap1_peppho
24877           sig2 = sigmap2_peppho
24878 !       write (*,*) "sig1 = ", sig1
24879 !       write (*,*) "sig1 = ", sig1
24880 !       write (*,*) "sig2 = ", sig2
24881 ! alpha factors from Fcav/Gcav
24882           alf1   = 0.0d0
24883           alf2   = 0.0d0
24884           alf12  = 0.0d0
24885           b1 = alphasur_peppho(1)
24886 !          b1=0.0d0
24887           b2 = alphasur_peppho(2)
24888           b3 = alphasur_peppho(3)
24889           b4 = alphasur_peppho(4)
24890           CALL sc_angular
24891        sqom1=om1*om1
24892        evdwij = 0.0d0
24893        ECL = 0.0d0
24894        Elj = 0.0d0
24895        Equad = 0.0d0
24896        Epol = 0.0d0
24897        Fcav=0.0d0
24898        eheadtail = 0.0d0
24899        dGCLdR=0.0d0
24900        dGCLdOM1 = 0.0d0
24901        dGCLdOM2 = 0.0d0
24902        dGCLdOM12 = 0.0d0
24903        dPOLdOM1 = 0.0d0
24904        dPOLdOM2 = 0.0d0
24905           Fcav = 0.0d0
24906           dFdR = 0.0d0
24907           dCAVdOM1  = 0.0d0
24908           dCAVdOM2  = 0.0d0
24909           dCAVdOM12 = 0.0d0
24910           rij_shift = rij
24911           fac       = rij_shift**expon
24912           c1        = fac  * fac * aa_peppho
24913 !          c1        = 0.0d0
24914           c2        = fac  * bb_peppho
24915 !          c2        = 0.0d0
24916           evdwij    =  c1 + c2
24917 ! Now cavity....................
24918        eagle = dsqrt(1.0/rij_shift)
24919        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24920           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24921           botsq = bot * bot
24922           Fcav = top / bot
24923           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24924           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24925           dFdR = ((dtop * bot - top * dbot) / botsq)
24926        w1        = wqdip_peppho(1)
24927        w2        = wqdip_peppho(2)
24928 !       w1=0.0d0
24929 !       w2=0.0d0
24930 !       pis       = sig0head_scbase(itypi,itypj)
24931 !       eps_head   = epshead_scbase(itypi,itypj)
24932 !c!-------------------------------------------------------------------
24933
24934 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24935 !c!     &        +dhead(1,1,itypi,itypj))**2))
24936 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24937 !c!     &        +dhead(2,1,itypi,itypj))**2))
24938
24939 !c!-------------------------------------------------------------------
24940 !c! ecl
24941        sparrow  = w1  *  om1
24942        hawk     = w2 *  (1.0d0 - sqom1)
24943        Ecl = sparrow * rij_shift**2.0d0 &
24944            - hawk    * rij_shift**4.0d0
24945 !c!-------------------------------------------------------------------
24946 !c! derivative of ecl is Gcl
24947 !c! dF/dr part
24948 !       rij_shift=5.0
24949        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24950                 + 4.0d0 * hawk    * rij_shift**5.0d0
24951 !c! dF/dom1
24952        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24953 !c! dF/dom2
24954        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24955        eom1  =    dGCLdOM1+dGCLdOM2
24956        eom2  =    0.0
24957
24958           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24959 !          fac=0.0
24960           gg(1) =  fac*xj*rij
24961           gg(2) =  fac*yj*rij
24962           gg(3) =  fac*zj*rij
24963          do k=1,3
24964          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24965          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24966          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24967          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24968          gg(k)=0.0
24969          enddo
24970
24971       DO k = 1, 3
24972         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24973         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24974         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24975         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24976 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24977         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24978 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24979         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24980                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24981         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24982                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24983         enddo
24984        epeppho=epeppho+evdwij+Fcav+ECL
24985 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24986        enddo
24987        enddo
24988       end subroutine eprot_pep_phosphate
24989 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24990       subroutine emomo(evdw)
24991       use calc_data
24992       use comm_momo
24993 !      implicit real*8 (a-h,o-z)
24994 !      include 'DIMENSIONS'
24995 !      include 'COMMON.GEO'
24996 !      include 'COMMON.VAR'
24997 !      include 'COMMON.LOCAL'
24998 !      include 'COMMON.CHAIN'
24999 !      include 'COMMON.DERIV'
25000 !      include 'COMMON.NAMES'
25001 !      include 'COMMON.INTERACT'
25002 !      include 'COMMON.IOUNITS'
25003 !      include 'COMMON.CALC'
25004 !      include 'COMMON.CONTROL'
25005 !      include 'COMMON.SBRIDGE'
25006       logical :: lprn
25007 !el local variables
25008       integer :: iint,itypi1,subchap,isel
25009       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25010       real(kind=8) :: evdw
25011       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25012                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25013                     sslipi,sslipj,faclip,alpha_sco
25014       integer :: ii
25015       real(kind=8) :: fracinbuf
25016        real (kind=8) :: escpho
25017        real (kind=8),dimension(4):: ener
25018        real(kind=8) :: b1,b2,egb
25019        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25020         Lambf,&
25021         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25022         dFdOM2,dFdL,dFdOM12,&
25023         federmaus,&
25024         d1i,d1j
25025 !       real(kind=8),dimension(3,2)::erhead_tail
25026 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25027        real(kind=8) ::  facd4, adler, Fgb, facd3
25028        integer troll,jj,istate
25029        real (kind=8) :: dcosom1(3),dcosom2(3)
25030        eps_out=80.0d0
25031        sss_ele_cut=1.0d0
25032 !       print *,"EVDW KURW",evdw,nres
25033       do i=iatsc_s,iatsc_e
25034 !        print *,"I am in EVDW",i
25035         itypi=iabs(itype(i,1))
25036 !        if (i.ne.47) cycle
25037         if (itypi.eq.ntyp1) cycle
25038         itypi1=iabs(itype(i+1,1))
25039         xi=c(1,nres+i)
25040         yi=c(2,nres+i)
25041         zi=c(3,nres+i)
25042           xi=dmod(xi,boxxsize)
25043           if (xi.lt.0) xi=xi+boxxsize
25044           yi=dmod(yi,boxysize)
25045           if (yi.lt.0) yi=yi+boxysize
25046           zi=dmod(zi,boxzsize)
25047           if (zi.lt.0) zi=zi+boxzsize
25048
25049        if ((zi.gt.bordlipbot)  &
25050         .and.(zi.lt.bordliptop)) then
25051 !C the energy transfer exist
25052         if (zi.lt.buflipbot) then
25053 !C what fraction I am in
25054          fracinbuf=1.0d0-  &
25055               ((zi-bordlipbot)/lipbufthick)
25056 !C lipbufthick is thickenes of lipid buffore
25057          sslipi=sscalelip(fracinbuf)
25058          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25059         elseif (zi.gt.bufliptop) then
25060          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25061          sslipi=sscalelip(fracinbuf)
25062          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25063         else
25064          sslipi=1.0d0
25065          ssgradlipi=0.0
25066         endif
25067        else
25068          sslipi=0.0d0
25069          ssgradlipi=0.0
25070        endif
25071 !       print *, sslipi,ssgradlipi
25072         dxi=dc_norm(1,nres+i)
25073         dyi=dc_norm(2,nres+i)
25074         dzi=dc_norm(3,nres+i)
25075 !        dsci_inv=dsc_inv(itypi)
25076         dsci_inv=vbld_inv(i+nres)
25077 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25078 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25079 !
25080 ! Calculate SC interaction energy.
25081 !
25082         do iint=1,nint_gr(i)
25083           do j=istart(i,iint),iend(i,iint)
25084 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25085             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25086               call dyn_ssbond_ene(i,j,evdwij)
25087               evdw=evdw+evdwij
25088               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25089                               'evdw',i,j,evdwij,' ss'
25090 !              if (energy_dec) write (iout,*) &
25091 !                              'evdw',i,j,evdwij,' ss'
25092              do k=j+1,iend(i,iint)
25093 !C search over all next residues
25094               if (dyn_ss_mask(k)) then
25095 !C check if they are cysteins
25096 !C              write(iout,*) 'k=',k
25097
25098 !c              write(iout,*) "PRZED TRI", evdwij
25099 !               evdwij_przed_tri=evdwij
25100               call triple_ssbond_ene(i,j,k,evdwij)
25101 !c               if(evdwij_przed_tri.ne.evdwij) then
25102 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25103 !c               endif
25104
25105 !c              write(iout,*) "PO TRI", evdwij
25106 !C call the energy function that removes the artifical triple disulfide
25107 !C bond the soubroutine is located in ssMD.F
25108               evdw=evdw+evdwij
25109               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25110                             'evdw',i,j,evdwij,'tss'
25111               endif!dyn_ss_mask(k)
25112              enddo! k
25113             ELSE
25114 !el            ind=ind+1
25115             itypj=iabs(itype(j,1))
25116             if (itypj.eq.ntyp1) cycle
25117              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25118
25119 !             if (j.ne.78) cycle
25120 !            dscj_inv=dsc_inv(itypj)
25121             dscj_inv=vbld_inv(j+nres)
25122            xj=c(1,j+nres)
25123            yj=c(2,j+nres)
25124            zj=c(3,j+nres)
25125            xj=dmod(xj,boxxsize)
25126            if (xj.lt.0) xj=xj+boxxsize
25127            yj=dmod(yj,boxysize)
25128            if (yj.lt.0) yj=yj+boxysize
25129            zj=dmod(zj,boxzsize)
25130            if (zj.lt.0) zj=zj+boxzsize
25131           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25132           xj_safe=xj
25133           yj_safe=yj
25134           zj_safe=zj
25135           subchap=0
25136
25137           do xshift=-1,1
25138           do yshift=-1,1
25139           do zshift=-1,1
25140           xj=xj_safe+xshift*boxxsize
25141           yj=yj_safe+yshift*boxysize
25142           zj=zj_safe+zshift*boxzsize
25143           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25144           if(dist_temp.lt.dist_init) then
25145             dist_init=dist_temp
25146             xj_temp=xj
25147             yj_temp=yj
25148             zj_temp=zj
25149             subchap=1
25150           endif
25151           enddo
25152           enddo
25153           enddo
25154           if (subchap.eq.1) then
25155           xj=xj_temp-xi
25156           yj=yj_temp-yi
25157           zj=zj_temp-zi
25158           else
25159           xj=xj_safe-xi
25160           yj=yj_safe-yi
25161           zj=zj_safe-zi
25162           endif
25163           dxj = dc_norm( 1, nres+j )
25164           dyj = dc_norm( 2, nres+j )
25165           dzj = dc_norm( 3, nres+j )
25166 !          print *,i,j,itypi,itypj
25167 !          d1i=0.0d0
25168 !          d1j=0.0d0
25169 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25170 ! Gay-berne var's
25171 !1!          sig0ij = sigma_scsc( itypi,itypj )
25172 !          chi1=0.0d0
25173 !          chi2=0.0d0
25174 !          chip1=0.0d0
25175 !          chip2=0.0d0
25176 ! not used by momo potential, but needed by sc_angular which is shared
25177 ! by all energy_potential subroutines
25178           alf1   = 0.0d0
25179           alf2   = 0.0d0
25180           alf12  = 0.0d0
25181           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25182 !       a12sq = a12sq * a12sq
25183 ! charge of amino acid itypi is...
25184           chis1 = chis(itypi,itypj)
25185           chis2 = chis(itypj,itypi)
25186           chis12 = chis1 * chis2
25187           sig1 = sigmap1(itypi,itypj)
25188           sig2 = sigmap2(itypi,itypj)
25189 !       write (*,*) "sig1 = ", sig1
25190 !          chis1=0.0
25191 !          chis2=0.0
25192 !                    chis12 = chis1 * chis2
25193 !          sig1=0.0
25194 !          sig2=0.0
25195 !       write (*,*) "sig2 = ", sig2
25196 ! alpha factors from Fcav/Gcav
25197           b1cav = alphasur(1,itypi,itypj)
25198 !          b1cav=0.0d0
25199           b2cav = alphasur(2,itypi,itypj)
25200           b3cav = alphasur(3,itypi,itypj)
25201           b4cav = alphasur(4,itypi,itypj)
25202 ! used to determine whether we want to do quadrupole calculations
25203        eps_in = epsintab(itypi,itypj)
25204        if (eps_in.eq.0.0) eps_in=1.0
25205
25206        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25207        Rtail = 0.0d0
25208 !       dtail(1,itypi,itypj)=0.0
25209 !       dtail(2,itypi,itypj)=0.0
25210
25211        DO k = 1, 3
25212         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25213         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25214        END DO
25215 !c! tail distances will be themselves usefull elswhere
25216 !c1 (in Gcav, for example)
25217        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25218        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25219        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25220        Rtail = dsqrt( &
25221           (Rtail_distance(1)*Rtail_distance(1)) &
25222         + (Rtail_distance(2)*Rtail_distance(2)) &
25223         + (Rtail_distance(3)*Rtail_distance(3)))
25224
25225 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25226 !-------------------------------------------------------------------
25227 ! tail location and distance calculations
25228        d1 = dhead(1, 1, itypi, itypj)
25229        d2 = dhead(2, 1, itypi, itypj)
25230
25231        DO k = 1,3
25232 ! location of polar head is computed by taking hydrophobic centre
25233 ! and moving by a d1 * dc_norm vector
25234 ! see unres publications for very informative images
25235         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25236         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25237 ! distance
25238 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25239 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25240         Rhead_distance(k) = chead(k,2) - chead(k,1)
25241        END DO
25242 ! pitagoras (root of sum of squares)
25243        Rhead = dsqrt( &
25244           (Rhead_distance(1)*Rhead_distance(1)) &
25245         + (Rhead_distance(2)*Rhead_distance(2)) &
25246         + (Rhead_distance(3)*Rhead_distance(3)))
25247 !-------------------------------------------------------------------
25248 ! zero everything that should be zero'ed
25249        evdwij = 0.0d0
25250        ECL = 0.0d0
25251        Elj = 0.0d0
25252        Equad = 0.0d0
25253        Epol = 0.0d0
25254        Fcav=0.0d0
25255        eheadtail = 0.0d0
25256        dGCLdOM1 = 0.0d0
25257        dGCLdOM2 = 0.0d0
25258        dGCLdOM12 = 0.0d0
25259        dPOLdOM1 = 0.0d0
25260        dPOLdOM2 = 0.0d0
25261           Fcav = 0.0d0
25262           dFdR = 0.0d0
25263           dCAVdOM1  = 0.0d0
25264           dCAVdOM2  = 0.0d0
25265           dCAVdOM12 = 0.0d0
25266           dscj_inv = vbld_inv(j+nres)
25267 !          print *,i,j,dscj_inv,dsci_inv
25268 ! rij holds 1/(distance of Calpha atoms)
25269           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25270           rij  = dsqrt(rrij)
25271 !----------------------------
25272           CALL sc_angular
25273 ! this should be in elgrad_init but om's are calculated by sc_angular
25274 ! which in turn is used by older potentials
25275 ! om = omega, sqom = om^2
25276           sqom1  = om1 * om1
25277           sqom2  = om2 * om2
25278           sqom12 = om12 * om12
25279
25280 ! now we calculate EGB - Gey-Berne
25281 ! It will be summed up in evdwij and saved in evdw
25282           sigsq     = 1.0D0  / sigsq
25283           sig       = sig0ij * dsqrt(sigsq)
25284 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25285           rij_shift = Rtail - sig + sig0ij
25286           IF (rij_shift.le.0.0D0) THEN
25287            evdw = 1.0D20
25288            RETURN
25289           END IF
25290           sigder = -sig * sigsq
25291           rij_shift = 1.0D0 / rij_shift
25292           fac       = rij_shift**expon
25293           c1        = fac  * fac * aa_aq(itypi,itypj)
25294 !          print *,"ADAM",aa_aq(itypi,itypj)
25295
25296 !          c1        = 0.0d0
25297           c2        = fac  * bb_aq(itypi,itypj)
25298 !          c2        = 0.0d0
25299           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25300           eps2der   = eps3rt * evdwij
25301           eps3der   = eps2rt * evdwij
25302 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25303           evdwij    = eps2rt * eps3rt * evdwij
25304 !#ifdef TSCSC
25305 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25306 !           evdw_p = evdw_p + evdwij
25307 !          ELSE
25308 !           evdw_m = evdw_m + evdwij
25309 !          END IF
25310 !#else
25311           evdw = evdw  &
25312               + evdwij
25313 !#endif
25314
25315           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25316           fac    = -expon * (c1 + evdwij) * rij_shift
25317           sigder = fac * sigder
25318 !          fac    = rij * fac
25319 ! Calculate distance derivative
25320           gg(1) =  fac
25321           gg(2) =  fac
25322           gg(3) =  fac
25323 !          if (b2.gt.0.0) then
25324           fac = chis1 * sqom1 + chis2 * sqom2 &
25325           - 2.0d0 * chis12 * om1 * om2 * om12
25326 ! we will use pom later in Gcav, so dont mess with it!
25327           pom = 1.0d0 - chis1 * chis2 * sqom12
25328           Lambf = (1.0d0 - (fac / pom))
25329 !          print *,"fac,pom",fac,pom,Lambf
25330           Lambf = dsqrt(Lambf)
25331           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25332 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25333 !       write (*,*) "sparrow = ", sparrow
25334           Chif = Rtail * sparrow
25335 !           print *,"rij,sparrow",rij , sparrow
25336           ChiLambf = Chif * Lambf
25337           eagle = dsqrt(ChiLambf)
25338           bat = ChiLambf ** 11.0d0
25339           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25340           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25341           botsq = bot * bot
25342 !          print *,top,bot,"bot,top",ChiLambf,Chif
25343           Fcav = top / bot
25344
25345        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25346        dbot = 12.0d0 * b4cav * bat * Lambf
25347        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25348
25349           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25350           dbot = 12.0d0 * b4cav * bat * Chif
25351           eagle = Lambf * pom
25352           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25353           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25354           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25355               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25356
25357           dFdL = ((dtop * bot - top * dbot) / botsq)
25358 !       dFdL = 0.0d0
25359           dCAVdOM1  = dFdL * ( dFdOM1 )
25360           dCAVdOM2  = dFdL * ( dFdOM2 )
25361           dCAVdOM12 = dFdL * ( dFdOM12 )
25362
25363        DO k= 1, 3
25364         ertail(k) = Rtail_distance(k)/Rtail
25365        END DO
25366        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25367        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25368        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25369        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25370        DO k = 1, 3
25371 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25372 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25373         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25374         gvdwx(k,i) = gvdwx(k,i) &
25375                   - (( dFdR + gg(k) ) * pom)
25376 !c!     &             - ( dFdR * pom )
25377         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25378         gvdwx(k,j) = gvdwx(k,j)   &
25379                   + (( dFdR + gg(k) ) * pom)
25380 !c!     &             + ( dFdR * pom )
25381
25382         gvdwc(k,i) = gvdwc(k,i)  &
25383                   - (( dFdR + gg(k) ) * ertail(k))
25384 !c!     &             - ( dFdR * ertail(k))
25385
25386         gvdwc(k,j) = gvdwc(k,j) &
25387                   + (( dFdR + gg(k) ) * ertail(k))
25388 !c!     &             + ( dFdR * ertail(k))
25389
25390         gg(k) = 0.0d0
25391 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25392 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25393       END DO
25394
25395
25396 !c! Compute head-head and head-tail energies for each state
25397
25398           isel = iabs(Qi) + iabs(Qj)
25399 ! double charge for Phophorylated! itype - 25,27,27
25400 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25401 !            Qi=Qi*2
25402 !            Qij=Qij*2
25403 !           endif
25404 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25405 !            Qj=Qj*2
25406 !            Qij=Qij*2
25407 !           endif
25408
25409 !          isel=0
25410           IF (isel.eq.0) THEN
25411 !c! No charges - do nothing
25412            eheadtail = 0.0d0
25413
25414           ELSE IF (isel.eq.4) THEN
25415 !c! Calculate dipole-dipole interactions
25416            CALL edd(ecl)
25417            eheadtail = ECL
25418 !           eheadtail = 0.0d0
25419
25420           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25421 !c! Charge-nonpolar interactions
25422           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25423             Qi=Qi*2
25424             Qij=Qij*2
25425            endif
25426           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25427             Qj=Qj*2
25428             Qij=Qij*2
25429            endif
25430
25431            CALL eqn(epol)
25432            eheadtail = epol
25433 !           eheadtail = 0.0d0
25434
25435           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25436 !c! Nonpolar-charge interactions
25437           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25438             Qi=Qi*2
25439             Qij=Qij*2
25440            endif
25441           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25442             Qj=Qj*2
25443             Qij=Qij*2
25444            endif
25445
25446            CALL enq(epol)
25447            eheadtail = epol
25448 !           eheadtail = 0.0d0
25449
25450           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25451 !c! Charge-dipole interactions
25452           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25453             Qi=Qi*2
25454             Qij=Qij*2
25455            endif
25456           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25457             Qj=Qj*2
25458             Qij=Qij*2
25459            endif
25460
25461            CALL eqd(ecl, elj, epol)
25462            eheadtail = ECL + elj + epol
25463 !           eheadtail = 0.0d0
25464
25465           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25466 !c! Dipole-charge interactions
25467           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25468             Qi=Qi*2
25469             Qij=Qij*2
25470            endif
25471           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25472             Qj=Qj*2
25473             Qij=Qij*2
25474            endif
25475            CALL edq(ecl, elj, epol)
25476           eheadtail = ECL + elj + epol
25477 !           eheadtail = 0.0d0
25478
25479           ELSE IF ((isel.eq.2.and.   &
25480                iabs(Qi).eq.1).and.  &
25481                nstate(itypi,itypj).eq.1) THEN
25482 !c! Same charge-charge interaction ( +/+ or -/- )
25483           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25484             Qi=Qi*2
25485             Qij=Qij*2
25486            endif
25487           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25488             Qj=Qj*2
25489             Qij=Qij*2
25490            endif
25491
25492            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25493            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25494 !           eheadtail = 0.0d0
25495
25496           ELSE IF ((isel.eq.2.and.  &
25497                iabs(Qi).eq.1).and. &
25498                nstate(itypi,itypj).ne.1) THEN
25499 !c! Different charge-charge interaction ( +/- or -/+ )
25500           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25501             Qi=Qi*2
25502             Qij=Qij*2
25503            endif
25504           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25505             Qj=Qj*2
25506             Qij=Qij*2
25507            endif
25508
25509            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25510           END IF
25511        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25512       evdw = evdw  + Fcav + eheadtail
25513
25514        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25515         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25516         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25517         Equad,evdwij+Fcav+eheadtail,evdw
25518 !       evdw = evdw  + Fcav  + eheadtail
25519
25520         iF (nstate(itypi,itypj).eq.1) THEN
25521         CALL sc_grad
25522        END IF
25523 !c!-------------------------------------------------------------------
25524 !c! NAPISY KONCOWE
25525          END DO   ! j
25526         END DO    ! iint
25527        END DO     ! i
25528 !c      write (iout,*) "Number of loop steps in EGB:",ind
25529 !c      energy_dec=.false.
25530 !              print *,"EVDW KURW",evdw,nres
25531
25532        RETURN
25533       END SUBROUTINE emomo
25534 !C------------------------------------------------------------------------------------
25535       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25536       use calc_data
25537       use comm_momo
25538        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25539          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25540 !       integer :: k
25541 !c! Epol and Gpol analytical parameters
25542        alphapol1 = alphapol(itypi,itypj)
25543        alphapol2 = alphapol(itypj,itypi)
25544 !c! Fisocav and Gisocav analytical parameters
25545        al1  = alphiso(1,itypi,itypj)
25546        al2  = alphiso(2,itypi,itypj)
25547        al3  = alphiso(3,itypi,itypj)
25548        al4  = alphiso(4,itypi,itypj)
25549        csig = (1.0d0  &
25550            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25551            + sigiso2(itypi,itypj)**2.0d0))
25552 !c!
25553        pis  = sig0head(itypi,itypj)
25554        eps_head = epshead(itypi,itypj)
25555        Rhead_sq = Rhead * Rhead
25556 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25557 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25558        R1 = 0.0d0
25559        R2 = 0.0d0
25560        DO k = 1, 3
25561 !c! Calculate head-to-tail distances needed by Epol
25562         R1=R1+(ctail(k,2)-chead(k,1))**2
25563         R2=R2+(chead(k,2)-ctail(k,1))**2
25564        END DO
25565 !c! Pitagoras
25566        R1 = dsqrt(R1)
25567        R2 = dsqrt(R2)
25568
25569 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25570 !c!     &        +dhead(1,1,itypi,itypj))**2))
25571 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25572 !c!     &        +dhead(2,1,itypi,itypj))**2))
25573
25574 !c!-------------------------------------------------------------------
25575 !c! Coulomb electrostatic interaction
25576        Ecl = (332.0d0 * Qij) / Rhead
25577 !c! derivative of Ecl is Gcl...
25578        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25579        dGCLdOM1 = 0.0d0
25580        dGCLdOM2 = 0.0d0
25581        dGCLdOM12 = 0.0d0
25582        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25583        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25584        debkap=debaykap(itypi,itypj)
25585        Egb = -(332.0d0 * Qij *&
25586         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25587 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25588 !c! Derivative of Egb is Ggb...
25589        dGGBdFGB = -(-332.0d0 * Qij * &
25590        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25591        -(332.0d0 * Qij *&
25592         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25593        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25594        dGGBdR = dGGBdFGB * dFGBdR
25595 !c!-------------------------------------------------------------------
25596 !c! Fisocav - isotropic cavity creation term
25597 !c! or "how much energy it costs to put charged head in water"
25598        pom = Rhead * csig
25599        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25600        bot = (1.0d0 + al4 * pom**12.0d0)
25601        botsq = bot * bot
25602        FisoCav = top / bot
25603 !      write (*,*) "Rhead = ",Rhead
25604 !      write (*,*) "csig = ",csig
25605 !      write (*,*) "pom = ",pom
25606 !      write (*,*) "al1 = ",al1
25607 !      write (*,*) "al2 = ",al2
25608 !      write (*,*) "al3 = ",al3
25609 !      write (*,*) "al4 = ",al4
25610 !        write (*,*) "top = ",top
25611 !        write (*,*) "bot = ",bot
25612 !c! Derivative of Fisocav is GCV...
25613        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25614        dbot = 12.0d0 * al4 * pom ** 11.0d0
25615        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25616 !c!-------------------------------------------------------------------
25617 !c! Epol
25618 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25619        MomoFac1 = (1.0d0 - chi1 * sqom2)
25620        MomoFac2 = (1.0d0 - chi2 * sqom1)
25621        RR1  = ( R1 * R1 ) / MomoFac1
25622        RR2  = ( R2 * R2 ) / MomoFac2
25623        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25624        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25625        fgb1 = sqrt( RR1 + a12sq * ee1 )
25626        fgb2 = sqrt( RR2 + a12sq * ee2 )
25627        epol = 332.0d0 * eps_inout_fac * ( &
25628       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25629 !c!       epol = 0.0d0
25630        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25631                / (fgb1 ** 5.0d0)
25632        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25633                / (fgb2 ** 5.0d0)
25634        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25635              / ( 2.0d0 * fgb1 )
25636        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25637              / ( 2.0d0 * fgb2 )
25638        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25639                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25640        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25641                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25642        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25643 !c!       dPOLdR1 = 0.0d0
25644        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25645 !c!       dPOLdR2 = 0.0d0
25646        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25647 !c!       dPOLdOM1 = 0.0d0
25648        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25649 !c!       dPOLdOM2 = 0.0d0
25650 !c!-------------------------------------------------------------------
25651 !c! Elj
25652 !c! Lennard-Jones 6-12 interaction between heads
25653        pom = (pis / Rhead)**6.0d0
25654        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25655 !c! derivative of Elj is Glj
25656        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25657              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25658 !c!-------------------------------------------------------------------
25659 !c! Return the results
25660 !c! These things do the dRdX derivatives, that is
25661 !c! allow us to change what we see from function that changes with
25662 !c! distance to function that changes with LOCATION (of the interaction
25663 !c! site)
25664        DO k = 1, 3
25665         erhead(k) = Rhead_distance(k)/Rhead
25666         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25667         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25668        END DO
25669
25670        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25671        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25672        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25673        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25674        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25675        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25676        facd1 = d1 * vbld_inv(i+nres)
25677        facd2 = d2 * vbld_inv(j+nres)
25678        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25679        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25680
25681 !c! Now we add appropriate partial derivatives (one in each dimension)
25682        DO k = 1, 3
25683         hawk   = (erhead_tail(k,1) + &
25684         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25685         condor = (erhead_tail(k,2) + &
25686         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25687
25688         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25689         gvdwx(k,i) = gvdwx(k,i) &
25690                   - dGCLdR * pom&
25691                   - dGGBdR * pom&
25692                   - dGCVdR * pom&
25693                   - dPOLdR1 * hawk&
25694                   - dPOLdR2 * (erhead_tail(k,2)&
25695       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25696                   - dGLJdR * pom
25697
25698         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25699         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25700                    + dGGBdR * pom+ dGCVdR * pom&
25701                   + dPOLdR1 * (erhead_tail(k,1)&
25702       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25703                   + dPOLdR2 * condor + dGLJdR * pom
25704
25705         gvdwc(k,i) = gvdwc(k,i)  &
25706                   - dGCLdR * erhead(k)&
25707                   - dGGBdR * erhead(k)&
25708                   - dGCVdR * erhead(k)&
25709                   - dPOLdR1 * erhead_tail(k,1)&
25710                   - dPOLdR2 * erhead_tail(k,2)&
25711                   - dGLJdR * erhead(k)
25712
25713         gvdwc(k,j) = gvdwc(k,j)         &
25714                   + dGCLdR * erhead(k) &
25715                   + dGGBdR * erhead(k) &
25716                   + dGCVdR * erhead(k) &
25717                   + dPOLdR1 * erhead_tail(k,1) &
25718                   + dPOLdR2 * erhead_tail(k,2)&
25719                   + dGLJdR * erhead(k)
25720
25721        END DO
25722        RETURN
25723       END SUBROUTINE eqq
25724 !c!-------------------------------------------------------------------
25725       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25726       use comm_momo
25727       use calc_data
25728
25729        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25730        double precision ener(4)
25731        double precision dcosom1(3),dcosom2(3)
25732 !c! used in Epol derivatives
25733        double precision facd3, facd4
25734        double precision federmaus, adler
25735        integer istate,ii,jj
25736        real (kind=8) :: Fgb
25737 !       print *,"CALLING EQUAD"
25738 !c! Epol and Gpol analytical parameters
25739        alphapol1 = alphapol(itypi,itypj)
25740        alphapol2 = alphapol(itypj,itypi)
25741 !c! Fisocav and Gisocav analytical parameters
25742        al1  = alphiso(1,itypi,itypj)
25743        al2  = alphiso(2,itypi,itypj)
25744        al3  = alphiso(3,itypi,itypj)
25745        al4  = alphiso(4,itypi,itypj)
25746        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25747             + sigiso2(itypi,itypj)**2.0d0))
25748 !c!
25749        w1   = wqdip(1,itypi,itypj)
25750        w2   = wqdip(2,itypi,itypj)
25751        pis  = sig0head(itypi,itypj)
25752        eps_head = epshead(itypi,itypj)
25753 !c! First things first:
25754 !c! We need to do sc_grad's job with GB and Fcav
25755        eom1  = eps2der * eps2rt_om1 &
25756              - 2.0D0 * alf1 * eps3der&
25757              + sigder * sigsq_om1&
25758              + dCAVdOM1
25759        eom2  = eps2der * eps2rt_om2 &
25760              + 2.0D0 * alf2 * eps3der&
25761              + sigder * sigsq_om2&
25762              + dCAVdOM2
25763        eom12 =  evdwij  * eps1_om12 &
25764              + eps2der * eps2rt_om12 &
25765              - 2.0D0 * alf12 * eps3der&
25766              + sigder *sigsq_om12&
25767              + dCAVdOM12
25768 !c! now some magical transformations to project gradient into
25769 !c! three cartesian vectors
25770        DO k = 1, 3
25771         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25772         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25773         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25774 !c! this acts on hydrophobic center of interaction
25775         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25776                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25777                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25778         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25779                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25780                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25781 !c! this acts on Calpha
25782         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25783         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25784        END DO
25785 !c! sc_grad is done, now we will compute
25786        eheadtail = 0.0d0
25787        eom1 = 0.0d0
25788        eom2 = 0.0d0
25789        eom12 = 0.0d0
25790        DO istate = 1, nstate(itypi,itypj)
25791 !c*************************************************************
25792         IF (istate.ne.1) THEN
25793          IF (istate.lt.3) THEN
25794           ii = 1
25795          ELSE
25796           ii = 2
25797          END IF
25798         jj = istate/ii
25799         d1 = dhead(1,ii,itypi,itypj)
25800         d2 = dhead(2,jj,itypi,itypj)
25801         DO k = 1,3
25802          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25803          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25804          Rhead_distance(k) = chead(k,2) - chead(k,1)
25805         END DO
25806 !c! pitagoras (root of sum of squares)
25807         Rhead = dsqrt( &
25808                (Rhead_distance(1)*Rhead_distance(1))  &
25809              + (Rhead_distance(2)*Rhead_distance(2))  &
25810              + (Rhead_distance(3)*Rhead_distance(3)))
25811         END IF
25812         Rhead_sq = Rhead * Rhead
25813
25814 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25815 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25816         R1 = 0.0d0
25817         R2 = 0.0d0
25818         DO k = 1, 3
25819 !c! Calculate head-to-tail distances
25820          R1=R1+(ctail(k,2)-chead(k,1))**2
25821          R2=R2+(chead(k,2)-ctail(k,1))**2
25822         END DO
25823 !c! Pitagoras
25824         R1 = dsqrt(R1)
25825         R2 = dsqrt(R2)
25826         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25827 !c!        Ecl = 0.0d0
25828 !c!        write (*,*) "Ecl = ", Ecl
25829 !c! derivative of Ecl is Gcl...
25830         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25831 !c!        dGCLdR = 0.0d0
25832         dGCLdOM1 = 0.0d0
25833         dGCLdOM2 = 0.0d0
25834         dGCLdOM12 = 0.0d0
25835 !c!-------------------------------------------------------------------
25836 !c! Generalised Born Solvent Polarization
25837         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25838         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25839         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25840 !c!        Egb = 0.0d0
25841 !c!      write (*,*) "a1*a2 = ", a12sq
25842 !c!      write (*,*) "Rhead = ", Rhead
25843 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25844 !c!      write (*,*) "ee = ", ee
25845 !c!      write (*,*) "Fgb = ", Fgb
25846 !c!      write (*,*) "fac = ", eps_inout_fac
25847 !c!      write (*,*) "Qij = ", Qij
25848 !c!      write (*,*) "Egb = ", Egb
25849 !c! Derivative of Egb is Ggb...
25850 !c! dFGBdR is used by Quad's later...
25851         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25852         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25853                / ( 2.0d0 * Fgb )
25854         dGGBdR = dGGBdFGB * dFGBdR
25855 !c!        dGGBdR = 0.0d0
25856 !c!-------------------------------------------------------------------
25857 !c! Fisocav - isotropic cavity creation term
25858         pom = Rhead * csig
25859         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25860         bot = (1.0d0 + al4 * pom**12.0d0)
25861         botsq = bot * bot
25862         FisoCav = top / bot
25863         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25864         dbot = 12.0d0 * al4 * pom ** 11.0d0
25865         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25866 !c!        dGCVdR = 0.0d0
25867 !c!-------------------------------------------------------------------
25868 !c! Polarization energy
25869 !c! Epol
25870         MomoFac1 = (1.0d0 - chi1 * sqom2)
25871         MomoFac2 = (1.0d0 - chi2 * sqom1)
25872         RR1  = ( R1 * R1 ) / MomoFac1
25873         RR2  = ( R2 * R2 ) / MomoFac2
25874         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25875         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25876         fgb1 = sqrt( RR1 + a12sq * ee1 )
25877         fgb2 = sqrt( RR2 + a12sq * ee2 )
25878         epol = 332.0d0 * eps_inout_fac * (&
25879         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25880 !c!        epol = 0.0d0
25881 !c! derivative of Epol is Gpol...
25882         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25883                   / (fgb1 ** 5.0d0)
25884         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25885                   / (fgb2 ** 5.0d0)
25886         dFGBdR1 = ( (R1 / MomoFac1) &
25887                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25888                 / ( 2.0d0 * fgb1 )
25889         dFGBdR2 = ( (R2 / MomoFac2) &
25890                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25891                 / ( 2.0d0 * fgb2 )
25892         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25893                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25894                  / ( 2.0d0 * fgb1 )
25895         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25896                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25897                  / ( 2.0d0 * fgb2 )
25898         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25899 !c!        dPOLdR1 = 0.0d0
25900         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25901 !c!        dPOLdR2 = 0.0d0
25902         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25903 !c!        dPOLdOM1 = 0.0d0
25904         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25905         pom = (pis / Rhead)**6.0d0
25906         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25907 !c!        Elj = 0.0d0
25908 !c! derivative of Elj is Glj
25909         dGLJdR = 4.0d0 * eps_head &
25910             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25911             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25912 !c!        dGLJdR = 0.0d0
25913 !c!-------------------------------------------------------------------
25914 !c! Equad
25915        IF (Wqd.ne.0.0d0) THEN
25916         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25917              - 37.5d0  * ( sqom1 + sqom2 ) &
25918              + 157.5d0 * ( sqom1 * sqom2 ) &
25919              - 45.0d0  * om1*om2*om12
25920         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25921         Equad = fac * Beta1
25922 !c!        Equad = 0.0d0
25923 !c! derivative of Equad...
25924         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25925 !c!        dQUADdR = 0.0d0
25926         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25927 !c!        dQUADdOM1 = 0.0d0
25928         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25929 !c!        dQUADdOM2 = 0.0d0
25930         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25931        ELSE
25932          Beta1 = 0.0d0
25933          Equad = 0.0d0
25934         END IF
25935 !c!-------------------------------------------------------------------
25936 !c! Return the results
25937 !c! Angular stuff
25938         eom1 = dPOLdOM1 + dQUADdOM1
25939         eom2 = dPOLdOM2 + dQUADdOM2
25940         eom12 = dQUADdOM12
25941 !c! now some magical transformations to project gradient into
25942 !c! three cartesian vectors
25943         DO k = 1, 3
25944          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25945          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25946          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25947         END DO
25948 !c! Radial stuff
25949         DO k = 1, 3
25950          erhead(k) = Rhead_distance(k)/Rhead
25951          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25952          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25953         END DO
25954         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25955         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25956         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25957         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25958         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25959         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25960         facd1 = d1 * vbld_inv(i+nres)
25961         facd2 = d2 * vbld_inv(j+nres)
25962         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25963         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25964         DO k = 1, 3
25965          hawk   = erhead_tail(k,1) + &
25966          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25967          condor = erhead_tail(k,2) + &
25968          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25969
25970          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25971 !c! this acts on hydrophobic center of interaction
25972          gheadtail(k,1,1) = gheadtail(k,1,1) &
25973                          - dGCLdR * pom &
25974                          - dGGBdR * pom &
25975                          - dGCVdR * pom &
25976                          - dPOLdR1 * hawk &
25977                          - dPOLdR2 * (erhead_tail(k,2) &
25978       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25979                          - dGLJdR * pom &
25980                          - dQUADdR * pom&
25981                          - tuna(k) &
25982                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25983                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25984
25985          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25986 !c! this acts on hydrophobic center of interaction
25987          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25988                          + dGCLdR * pom      &
25989                          + dGGBdR * pom      &
25990                          + dGCVdR * pom      &
25991                          + dPOLdR1 * (erhead_tail(k,1) &
25992       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25993                          + dPOLdR2 * condor &
25994                          + dGLJdR * pom &
25995                          + dQUADdR * pom &
25996                          + tuna(k) &
25997                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25998                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25999
26000 !c! this acts on Calpha
26001          gheadtail(k,3,1) = gheadtail(k,3,1)  &
26002                          - dGCLdR * erhead(k)&
26003                          - dGGBdR * erhead(k)&
26004                          - dGCVdR * erhead(k)&
26005                          - dPOLdR1 * erhead_tail(k,1)&
26006                          - dPOLdR2 * erhead_tail(k,2)&
26007                          - dGLJdR * erhead(k) &
26008                          - dQUADdR * erhead(k)&
26009                          - tuna(k)
26010 !c! this acts on Calpha
26011          gheadtail(k,4,1) = gheadtail(k,4,1)   &
26012                           + dGCLdR * erhead(k) &
26013                           + dGGBdR * erhead(k) &
26014                           + dGCVdR * erhead(k) &
26015                           + dPOLdR1 * erhead_tail(k,1) &
26016                           + dPOLdR2 * erhead_tail(k,2) &
26017                           + dGLJdR * erhead(k) &
26018                           + dQUADdR * erhead(k)&
26019                           + tuna(k)
26020         END DO
26021         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26022         eheadtail = eheadtail &
26023                   + wstate(istate, itypi, itypj) &
26024                   * dexp(-betaT * ener(istate))
26025 !c! foreach cartesian dimension
26026         DO k = 1, 3
26027 !c! foreach of two gvdwx and gvdwc
26028          DO l = 1, 4
26029           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26030                            + wstate( istate, itypi, itypj ) &
26031                            * dexp(-betaT * ener(istate)) &
26032                            * gheadtail(k,l,1)
26033           gheadtail(k,l,1) = 0.0d0
26034          END DO
26035         END DO
26036        END DO
26037 !c! Here ended the gigantic DO istate = 1, 4, which starts
26038 !c! at the beggining of the subroutine
26039
26040        DO k = 1, 3
26041         DO l = 1, 4
26042          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26043         END DO
26044         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26045         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26046         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26047         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26048         DO l = 1, 4
26049          gheadtail(k,l,1) = 0.0d0
26050          gheadtail(k,l,2) = 0.0d0
26051         END DO
26052        END DO
26053        eheadtail = (-dlog(eheadtail)) / betaT
26054        dPOLdOM1 = 0.0d0
26055        dPOLdOM2 = 0.0d0
26056        dQUADdOM1 = 0.0d0
26057        dQUADdOM2 = 0.0d0
26058        dQUADdOM12 = 0.0d0
26059        RETURN
26060       END SUBROUTINE energy_quad
26061 !!-----------------------------------------------------------
26062       SUBROUTINE eqn(Epol)
26063       use comm_momo
26064       use calc_data
26065
26066       double precision  facd4, federmaus,epol
26067       alphapol1 = alphapol(itypi,itypj)
26068 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26069        R1 = 0.0d0
26070        DO k = 1, 3
26071 !c! Calculate head-to-tail distances
26072         R1=R1+(ctail(k,2)-chead(k,1))**2
26073        END DO
26074 !c! Pitagoras
26075        R1 = dsqrt(R1)
26076
26077 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26078 !c!     &        +dhead(1,1,itypi,itypj))**2))
26079 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26080 !c!     &        +dhead(2,1,itypi,itypj))**2))
26081 !c--------------------------------------------------------------------
26082 !c Polarization energy
26083 !c Epol
26084        MomoFac1 = (1.0d0 - chi1 * sqom2)
26085        RR1  = R1 * R1 / MomoFac1
26086        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26087        fgb1 = sqrt( RR1 + a12sq * ee1)
26088        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26089        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26090                / (fgb1 ** 5.0d0)
26091        dFGBdR1 = ( (R1 / MomoFac1) &
26092               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26093               / ( 2.0d0 * fgb1 )
26094        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26095                 * (2.0d0 - 0.5d0 * ee1) ) &
26096                 / (2.0d0 * fgb1)
26097        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26098 !c!       dPOLdR1 = 0.0d0
26099        dPOLdOM1 = 0.0d0
26100        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26101        DO k = 1, 3
26102         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26103        END DO
26104        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26105        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26106        facd1 = d1 * vbld_inv(i+nres)
26107        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26108
26109        DO k = 1, 3
26110         hawk = (erhead_tail(k,1) + &
26111         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26112
26113         gvdwx(k,i) = gvdwx(k,i) &
26114                    - dPOLdR1 * hawk
26115         gvdwx(k,j) = gvdwx(k,j) &
26116                    + dPOLdR1 * (erhead_tail(k,1) &
26117        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26118
26119         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26120         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26121
26122        END DO
26123        RETURN
26124       END SUBROUTINE eqn
26125       SUBROUTINE enq(Epol)
26126       use calc_data
26127       use comm_momo
26128        double precision facd3, adler,epol
26129        alphapol2 = alphapol(itypj,itypi)
26130 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26131        R2 = 0.0d0
26132        DO k = 1, 3
26133 !c! Calculate head-to-tail distances
26134         R2=R2+(chead(k,2)-ctail(k,1))**2
26135        END DO
26136 !c! Pitagoras
26137        R2 = dsqrt(R2)
26138
26139 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26140 !c!     &        +dhead(1,1,itypi,itypj))**2))
26141 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26142 !c!     &        +dhead(2,1,itypi,itypj))**2))
26143 !c------------------------------------------------------------------------
26144 !c Polarization energy
26145        MomoFac2 = (1.0d0 - chi2 * sqom1)
26146        RR2  = R2 * R2 / MomoFac2
26147        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26148        fgb2 = sqrt(RR2  + a12sq * ee2)
26149        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26150        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26151                 / (fgb2 ** 5.0d0)
26152        dFGBdR2 = ( (R2 / MomoFac2)  &
26153               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26154               / (2.0d0 * fgb2)
26155        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26156                 * (2.0d0 - 0.5d0 * ee2) ) &
26157                 / (2.0d0 * fgb2)
26158        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26159 !c!       dPOLdR2 = 0.0d0
26160        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26161 !c!       dPOLdOM1 = 0.0d0
26162        dPOLdOM2 = 0.0d0
26163 !c!-------------------------------------------------------------------
26164 !c! Return the results
26165 !c! (See comments in Eqq)
26166        DO k = 1, 3
26167         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26168        END DO
26169        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26170        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26171        facd2 = d2 * vbld_inv(j+nres)
26172        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26173        DO k = 1, 3
26174         condor = (erhead_tail(k,2) &
26175        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26176
26177         gvdwx(k,i) = gvdwx(k,i) &
26178                    - dPOLdR2 * (erhead_tail(k,2) &
26179        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26180         gvdwx(k,j) = gvdwx(k,j)   &
26181                    + dPOLdR2 * condor
26182
26183         gvdwc(k,i) = gvdwc(k,i) &
26184                    - dPOLdR2 * erhead_tail(k,2)
26185         gvdwc(k,j) = gvdwc(k,j) &
26186                    + dPOLdR2 * erhead_tail(k,2)
26187
26188        END DO
26189       RETURN
26190       END SUBROUTINE enq
26191       SUBROUTINE eqd(Ecl,Elj,Epol)
26192       use calc_data
26193       use comm_momo
26194        double precision  facd4, federmaus,ecl,elj,epol
26195        alphapol1 = alphapol(itypi,itypj)
26196        w1        = wqdip(1,itypi,itypj)
26197        w2        = wqdip(2,itypi,itypj)
26198        pis       = sig0head(itypi,itypj)
26199        eps_head   = epshead(itypi,itypj)
26200 !c!-------------------------------------------------------------------
26201 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26202        R1 = 0.0d0
26203        DO k = 1, 3
26204 !c! Calculate head-to-tail distances
26205         R1=R1+(ctail(k,2)-chead(k,1))**2
26206        END DO
26207 !c! Pitagoras
26208        R1 = dsqrt(R1)
26209
26210 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26211 !c!     &        +dhead(1,1,itypi,itypj))**2))
26212 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26213 !c!     &        +dhead(2,1,itypi,itypj))**2))
26214
26215 !c!-------------------------------------------------------------------
26216 !c! ecl
26217        sparrow  = w1 * Qi * om1
26218        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26219        Ecl = sparrow / Rhead**2.0d0 &
26220            - hawk    / Rhead**4.0d0
26221        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26222                  + 4.0d0 * hawk    / Rhead**5.0d0
26223 !c! dF/dom1
26224        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26225 !c! dF/dom2
26226        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26227 !c--------------------------------------------------------------------
26228 !c Polarization energy
26229 !c Epol
26230        MomoFac1 = (1.0d0 - chi1 * sqom2)
26231        RR1  = R1 * R1 / MomoFac1
26232        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26233        fgb1 = sqrt( RR1 + a12sq * ee1)
26234        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26235 !c!       epol = 0.0d0
26236 !c!------------------------------------------------------------------
26237 !c! derivative of Epol is Gpol...
26238        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26239                / (fgb1 ** 5.0d0)
26240        dFGBdR1 = ( (R1 / MomoFac1)  &
26241              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26242              / ( 2.0d0 * fgb1 )
26243        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26244                * (2.0d0 - 0.5d0 * ee1) ) &
26245                / (2.0d0 * fgb1)
26246        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26247 !c!       dPOLdR1 = 0.0d0
26248        dPOLdOM1 = 0.0d0
26249        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26250 !c!       dPOLdOM2 = 0.0d0
26251 !c!-------------------------------------------------------------------
26252 !c! Elj
26253        pom = (pis / Rhead)**6.0d0
26254        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26255 !c! derivative of Elj is Glj
26256        dGLJdR = 4.0d0 * eps_head &
26257           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26258           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26259        DO k = 1, 3
26260         erhead(k) = Rhead_distance(k)/Rhead
26261         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26262        END DO
26263
26264        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26265        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26266        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26267        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26268        facd1 = d1 * vbld_inv(i+nres)
26269        facd2 = d2 * vbld_inv(j+nres)
26270        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26271
26272        DO k = 1, 3
26273         hawk = (erhead_tail(k,1) +  &
26274         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26275
26276         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26277         gvdwx(k,i) = gvdwx(k,i)  &
26278                    - dGCLdR * pom&
26279                    - dPOLdR1 * hawk &
26280                    - dGLJdR * pom
26281
26282         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26283         gvdwx(k,j) = gvdwx(k,j)    &
26284                    + dGCLdR * pom  &
26285                    + dPOLdR1 * (erhead_tail(k,1) &
26286        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26287                    + dGLJdR * pom
26288
26289
26290         gvdwc(k,i) = gvdwc(k,i)          &
26291                    - dGCLdR * erhead(k)  &
26292                    - dPOLdR1 * erhead_tail(k,1) &
26293                    - dGLJdR * erhead(k)
26294
26295         gvdwc(k,j) = gvdwc(k,j)          &
26296                    + dGCLdR * erhead(k)  &
26297                    + dPOLdR1 * erhead_tail(k,1) &
26298                    + dGLJdR * erhead(k)
26299
26300        END DO
26301        RETURN
26302       END SUBROUTINE eqd
26303       SUBROUTINE edq(Ecl,Elj,Epol)
26304 !       IMPLICIT NONE
26305        use comm_momo
26306       use calc_data
26307
26308       double precision  facd3, adler,ecl,elj,epol
26309        alphapol2 = alphapol(itypj,itypi)
26310        w1        = wqdip(1,itypi,itypj)
26311        w2        = wqdip(2,itypi,itypj)
26312        pis       = sig0head(itypi,itypj)
26313        eps_head  = epshead(itypi,itypj)
26314 !c!-------------------------------------------------------------------
26315 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26316        R2 = 0.0d0
26317        DO k = 1, 3
26318 !c! Calculate head-to-tail distances
26319         R2=R2+(chead(k,2)-ctail(k,1))**2
26320        END DO
26321 !c! Pitagoras
26322        R2 = dsqrt(R2)
26323
26324 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26325 !c!     &        +dhead(1,1,itypi,itypj))**2))
26326 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26327 !c!     &        +dhead(2,1,itypi,itypj))**2))
26328
26329
26330 !c!-------------------------------------------------------------------
26331 !c! ecl
26332        sparrow  = w1 * Qi * om1
26333        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26334        ECL = sparrow / Rhead**2.0d0 &
26335            - hawk    / Rhead**4.0d0
26336 !c!-------------------------------------------------------------------
26337 !c! derivative of ecl is Gcl
26338 !c! dF/dr part
26339        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26340                  + 4.0d0 * hawk    / Rhead**5.0d0
26341 !c! dF/dom1
26342        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26343 !c! dF/dom2
26344        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26345 !c--------------------------------------------------------------------
26346 !c Polarization energy
26347 !c Epol
26348        MomoFac2 = (1.0d0 - chi2 * sqom1)
26349        RR2  = R2 * R2 / MomoFac2
26350        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26351        fgb2 = sqrt(RR2  + a12sq * ee2)
26352        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26353        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26354                / (fgb2 ** 5.0d0)
26355        dFGBdR2 = ( (R2 / MomoFac2)  &
26356                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26357                / (2.0d0 * fgb2)
26358        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26359                 * (2.0d0 - 0.5d0 * ee2) ) &
26360                 / (2.0d0 * fgb2)
26361        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26362 !c!       dPOLdR2 = 0.0d0
26363        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26364 !c!       dPOLdOM1 = 0.0d0
26365        dPOLdOM2 = 0.0d0
26366 !c!-------------------------------------------------------------------
26367 !c! Elj
26368        pom = (pis / Rhead)**6.0d0
26369        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26370 !c! derivative of Elj is Glj
26371        dGLJdR = 4.0d0 * eps_head &
26372            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26373            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26374 !c!-------------------------------------------------------------------
26375 !c! Return the results
26376 !c! (see comments in Eqq)
26377        DO k = 1, 3
26378         erhead(k) = Rhead_distance(k)/Rhead
26379         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26380        END DO
26381        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26382        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26383        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26384        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26385        facd1 = d1 * vbld_inv(i+nres)
26386        facd2 = d2 * vbld_inv(j+nres)
26387        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26388        DO k = 1, 3
26389         condor = (erhead_tail(k,2) &
26390        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26391
26392         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26393         gvdwx(k,i) = gvdwx(k,i) &
26394                   - dGCLdR * pom &
26395                   - dPOLdR2 * (erhead_tail(k,2) &
26396        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26397                   - dGLJdR * pom
26398
26399         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26400         gvdwx(k,j) = gvdwx(k,j) &
26401                   + dGCLdR * pom &
26402                   + dPOLdR2 * condor &
26403                   + dGLJdR * pom
26404
26405
26406         gvdwc(k,i) = gvdwc(k,i) &
26407                   - dGCLdR * erhead(k) &
26408                   - dPOLdR2 * erhead_tail(k,2) &
26409                   - dGLJdR * erhead(k)
26410
26411         gvdwc(k,j) = gvdwc(k,j) &
26412                   + dGCLdR * erhead(k) &
26413                   + dPOLdR2 * erhead_tail(k,2) &
26414                   + dGLJdR * erhead(k)
26415
26416        END DO
26417        RETURN
26418       END SUBROUTINE edq
26419       SUBROUTINE edd(ECL)
26420 !       IMPLICIT NONE
26421        use comm_momo
26422       use calc_data
26423
26424        double precision ecl
26425 !c!       csig = sigiso(itypi,itypj)
26426        w1 = wqdip(1,itypi,itypj)
26427        w2 = wqdip(2,itypi,itypj)
26428 !c!-------------------------------------------------------------------
26429 !c! ECL
26430        fac = (om12 - 3.0d0 * om1 * om2)
26431        c1 = (w1 / (Rhead**3.0d0)) * fac
26432        c2 = (w2 / Rhead ** 6.0d0) &
26433           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26434        ECL = c1 - c2
26435 !c!       write (*,*) "w1 = ", w1
26436 !c!       write (*,*) "w2 = ", w2
26437 !c!       write (*,*) "om1 = ", om1
26438 !c!       write (*,*) "om2 = ", om2
26439 !c!       write (*,*) "om12 = ", om12
26440 !c!       write (*,*) "fac = ", fac
26441 !c!       write (*,*) "c1 = ", c1
26442 !c!       write (*,*) "c2 = ", c2
26443 !c!       write (*,*) "Ecl = ", Ecl
26444 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26445 !c!       write (*,*) "c2_2 = ",
26446 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26447 !c!-------------------------------------------------------------------
26448 !c! dervative of ECL is GCL...
26449 !c! dECL/dr
26450        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26451        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26452           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26453        dGCLdR = c1 - c2
26454 !c! dECL/dom1
26455        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26456        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26457           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26458        dGCLdOM1 = c1 - c2
26459 !c! dECL/dom2
26460        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26461        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26462           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26463        dGCLdOM2 = c1 - c2
26464 !c! dECL/dom12
26465        c1 = w1 / (Rhead ** 3.0d0)
26466        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26467        dGCLdOM12 = c1 - c2
26468 !c!-------------------------------------------------------------------
26469 !c! Return the results
26470 !c! (see comments in Eqq)
26471        DO k= 1, 3
26472         erhead(k) = Rhead_distance(k)/Rhead
26473        END DO
26474        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26475        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26476        facd1 = d1 * vbld_inv(i+nres)
26477        facd2 = d2 * vbld_inv(j+nres)
26478        DO k = 1, 3
26479
26480         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26481         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26482         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26483         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26484
26485         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26486         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26487        END DO
26488        RETURN
26489       END SUBROUTINE edd
26490       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26491 !       IMPLICIT NONE
26492        use comm_momo
26493       use calc_data
26494
26495        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26496        eps_out=80.0d0
26497        itypi = itype(i,1)
26498        itypj = itype(j,1)
26499 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26500 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26501 !c!       t_bath = 300
26502 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26503        Rb=0.001986d0
26504        BetaT = 1.0d0 / (298.0d0 * Rb)
26505 !c! Gay-berne var's
26506        sig0ij = sigma( itypi,itypj )
26507        chi1   = chi( itypi, itypj )
26508        chi2   = chi( itypj, itypi )
26509        chi12  = chi1 * chi2
26510        chip1  = chipp( itypi, itypj )
26511        chip2  = chipp( itypj, itypi )
26512        chip12 = chip1 * chip2
26513 !       chi1=0.0
26514 !       chi2=0.0
26515 !       chi12=0.0
26516 !       chip1=0.0
26517 !       chip2=0.0
26518 !       chip12=0.0
26519 !c! not used by momo potential, but needed by sc_angular which is shared
26520 !c! by all energy_potential subroutines
26521        alf1   = 0.0d0
26522        alf2   = 0.0d0
26523        alf12  = 0.0d0
26524 !c! location, location, location
26525 !       xj  = c( 1, nres+j ) - xi
26526 !       yj  = c( 2, nres+j ) - yi
26527 !       zj  = c( 3, nres+j ) - zi
26528        dxj = dc_norm( 1, nres+j )
26529        dyj = dc_norm( 2, nres+j )
26530        dzj = dc_norm( 3, nres+j )
26531 !c! distance from center of chain(?) to polar/charged head
26532 !c!       write (*,*) "istate = ", 1
26533 !c!       write (*,*) "ii = ", 1
26534 !c!       write (*,*) "jj = ", 1
26535        d1 = dhead(1, 1, itypi, itypj)
26536        d2 = dhead(2, 1, itypi, itypj)
26537 !c! ai*aj from Fgb
26538        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26539 !c!       a12sq = a12sq * a12sq
26540 !c! charge of amino acid itypi is...
26541        Qi  = icharge(itypi)
26542        Qj  = icharge(itypj)
26543        Qij = Qi * Qj
26544 !c! chis1,2,12
26545        chis1 = chis(itypi,itypj)
26546        chis2 = chis(itypj,itypi)
26547        chis12 = chis1 * chis2
26548        sig1 = sigmap1(itypi,itypj)
26549        sig2 = sigmap2(itypi,itypj)
26550 !c!       write (*,*) "sig1 = ", sig1
26551 !c!       write (*,*) "sig2 = ", sig2
26552 !c! alpha factors from Fcav/Gcav
26553        b1cav = alphasur(1,itypi,itypj)
26554 !       b1cav=0.0
26555        b2cav = alphasur(2,itypi,itypj)
26556        b3cav = alphasur(3,itypi,itypj)
26557        b4cav = alphasur(4,itypi,itypj)
26558        wqd = wquad(itypi, itypj)
26559 !c! used by Fgb
26560        eps_in = epsintab(itypi,itypj)
26561        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26562 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
26563 !c!-------------------------------------------------------------------
26564 !c! tail location and distance calculations
26565        Rtail = 0.0d0
26566        DO k = 1, 3
26567         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26568         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26569        END DO
26570 !c! tail distances will be themselves usefull elswhere
26571 !c1 (in Gcav, for example)
26572        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26573        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26574        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26575        Rtail = dsqrt(  &
26576           (Rtail_distance(1)*Rtail_distance(1))  &
26577         + (Rtail_distance(2)*Rtail_distance(2))  &
26578         + (Rtail_distance(3)*Rtail_distance(3)))
26579 !c!-------------------------------------------------------------------
26580 !c! Calculate location and distance between polar heads
26581 !c! distance between heads
26582 !c! for each one of our three dimensional space...
26583        d1 = dhead(1, 1, itypi, itypj)
26584        d2 = dhead(2, 1, itypi, itypj)
26585
26586        DO k = 1,3
26587 !c! location of polar head is computed by taking hydrophobic centre
26588 !c! and moving by a d1 * dc_norm vector
26589 !c! see unres publications for very informative images
26590         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26591         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26592 !c! distance
26593 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26594 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26595         Rhead_distance(k) = chead(k,2) - chead(k,1)
26596        END DO
26597 !c! pitagoras (root of sum of squares)
26598        Rhead = dsqrt(   &
26599           (Rhead_distance(1)*Rhead_distance(1)) &
26600         + (Rhead_distance(2)*Rhead_distance(2)) &
26601         + (Rhead_distance(3)*Rhead_distance(3)))
26602 !c!-------------------------------------------------------------------
26603 !c! zero everything that should be zero'ed
26604        Egb = 0.0d0
26605        ECL = 0.0d0
26606        Elj = 0.0d0
26607        Equad = 0.0d0
26608        Epol = 0.0d0
26609        eheadtail = 0.0d0
26610        dGCLdOM1 = 0.0d0
26611        dGCLdOM2 = 0.0d0
26612        dGCLdOM12 = 0.0d0
26613        dPOLdOM1 = 0.0d0
26614        dPOLdOM2 = 0.0d0
26615        RETURN
26616       END SUBROUTINE elgrad_init
26617
26618       double precision function tschebyshev(m,n,x,y)
26619       implicit none
26620       integer i,m,n
26621       double precision x(n),y,yy(0:maxvar),aux
26622 !c Tschebyshev polynomial. Note that the first term is omitted
26623 !c m=0: the constant term is included
26624 !c m=1: the constant term is not included
26625       yy(0)=1.0d0
26626       yy(1)=y
26627       do i=2,n
26628         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
26629       enddo
26630       aux=0.0d0
26631       do i=m,n
26632         aux=aux+x(i)*yy(i)
26633       enddo
26634       tschebyshev=aux
26635       return
26636       end function tschebyshev
26637 !C--------------------------------------------------------------------------
26638       double precision function gradtschebyshev(m,n,x,y)
26639       implicit none
26640       integer i,m,n
26641       double precision x(n+1),y,yy(0:maxvar),aux
26642 !c Tschebyshev polynomial. Note that the first term is omitted
26643 !c m=0: the constant term is included
26644 !c m=1: the constant term is not included
26645       yy(0)=1.0d0
26646       yy(1)=2.0d0*y
26647       do i=2,n
26648         yy(i)=2*y*yy(i-1)-yy(i-2)
26649       enddo
26650       aux=0.0d0
26651       do i=m,n
26652         aux=aux+x(i+1)*yy(i)*(i+1)
26653 !C        print *, x(i+1),yy(i),i
26654       enddo
26655       gradtschebyshev=aux
26656       return
26657       end function gradtschebyshev
26658
26659
26660
26661
26662
26663       end module energy