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,ecations_prot_amber
 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       call ecats_prot_amber(ecations_prot_amber)
 855       if (nres_molec(2).gt.0) then
 856       call eprot_sc_base(escbase)
 857       call epep_sc_base(epepbase)
 858       call eprot_sc_phosphate(escpho)
 859       call eprot_pep_phosphate(epeppho)
 860       else
 861       epepbase=0.0
 862       escbase=0.0
 863       escpho=0.0
 864       epeppho=0.0
 865       endif
 866 !      call ecatcat(ecationcation)
 867 !      print *,"after ebend", wtor_nucl
 868 #ifdef TIMING
 869       time_enecalc=time_enecalc+MPI_Wtime()-time00
 870 #endif
 871 !      print *,"Processor",myrank," computed Uconstr"
 872 #ifdef TIMING
 873       time00=MPI_Wtime()
 874 #endif
 875 !
 876 ! Sum the energies
 877 !
 878       energia(1)=evdw
 879 #ifdef SCP14
 880       energia(2)=evdw2-evdw2_14
 881       energia(18)=evdw2_14
 882 #else
 883       energia(2)=evdw2
 884       energia(18)=0.0d0
 885 #endif
 886 #ifdef SPLITELE
 887       energia(3)=ees
 888       energia(16)=evdw1
 889 #else
 890       energia(3)=ees+evdw1
 891       energia(16)=0.0d0
 892 #endif
 893       energia(4)=ecorr
 894       energia(5)=ecorr5
 895       energia(6)=ecorr6
 896       energia(7)=eel_loc
 897       energia(8)=eello_turn3
 898       energia(9)=eello_turn4
 899       energia(10)=eturn6
 900       energia(11)=ebe
 901       energia(12)=escloc
 902       energia(13)=etors
 903       energia(14)=etors_d
 904       energia(15)=ehpb
 905       energia(19)=edihcnstr
 906       energia(17)=estr
 907       energia(20)=Uconst+Uconst_back
 908       energia(21)=esccor
 909       energia(22)=eliptran
 910       energia(23)=Eafmforce
 911       energia(24)=ethetacnstr
 912       energia(25)=etube
 913 !---------------------------------------------------------------
 914       energia(26)=evdwpp
 915       energia(27)=eespp
 916       energia(28)=evdwpsb
 917       energia(29)=eelpsb
 918       energia(30)=evdwsb
 919       energia(31)=eelsb
 920       energia(32)=estr_nucl
 921       energia(33)=ebe_nucl
 922       energia(34)=esbloc
 923       energia(35)=etors_nucl
 924       energia(36)=etors_d_nucl
 925       energia(37)=ecorr_nucl
 926       energia(38)=ecorr3_nucl
 927 !----------------------------------------------------------------------
 928 !    Here are the energies showed per procesor if the are more processors
 929 !    per molecule then we sum it up in sum_energy subroutine
 930 !      print *," Processor",myrank," calls SUM_ENERGY"
 931       energia(42)=ecation_prot
 932       energia(41)=ecationcation
 933       energia(46)=escbase
 934       energia(47)=epepbase
 935       energia(48)=escpho
 936       energia(49)=epeppho
 937       energia(50)=ecations_prot_amber
 938       call sum_energy(energia,.true.)
 939       if (dyn_ss) call dyn_set_nss
 940 !      print *," Processor",myrank," left SUM_ENERGY"
 941 #ifdef TIMING
 942       time_sumene=time_sumene+MPI_Wtime()-time00
 943 #endif
 944 !        call enerprint(energia)
 945 !elwrite(iout,*)"finish etotal"
 946       return
 947       end subroutine etotal
 948 !-----------------------------------------------------------------------------
 949       subroutine sum_energy(energia,reduce)
 950 !      implicit real*8 (a-h,o-z)
 951 !      include 'DIMENSIONS'
 952 #ifndef ISNAN
 953       external proc_proc
 954 #ifdef WINPGI
 955 !MS$ATTRIBUTES C ::  proc_proc
 956 #endif
 957 #endif
 958 #ifdef MPI
 959       include "mpif.h"
 960 #endif
 961 !      include 'COMMON.SETUP'
 962 !      include 'COMMON.IOUNITS'
 963       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 964 !      include 'COMMON.FFIELD'
 965 !      include 'COMMON.DERIV'
 966 !      include 'COMMON.INTERACT'
 967 !      include 'COMMON.SBRIDGE'
 968 !      include 'COMMON.CHAIN'
 969 !      include 'COMMON.VAR'
 970 !      include 'COMMON.CONTROL'
 971 !      include 'COMMON.TIME1'
 972       logical :: reduce
 973       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 974       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 975       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 976         eliptran,etube, Eafmforce,ethetacnstr
 977       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 978                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 979                       ecorr3_nucl
 980       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
 981       real(kind=8) :: escbase,epepbase,escpho,epeppho
 982       integer :: i
 983 #ifdef MPI
 984       integer :: ierr
 985       real(kind=8) :: time00
 986       if (nfgtasks.gt.1 .and. reduce) then
 987
 988 #ifdef DEBUG
 989         write (iout,*) "energies before REDUCE"
 990         call enerprint(energia)
 991         call flush(iout)
 992 #endif
 993         do i=0,n_ene
 994           enebuff(i)=energia(i)
 995         enddo
 996         time00=MPI_Wtime()
 997         call MPI_Barrier(FG_COMM,IERR)
 998         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 999         time00=MPI_Wtime()
1000         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1001           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1002 #ifdef DEBUG
1003         write (iout,*) "energies after REDUCE"
1004         call enerprint(energia)
1005         call flush(iout)
1006 #endif
1007         time_Reduce=time_Reduce+MPI_Wtime()-time00
1008       endif
1009       if (fg_rank.eq.0) then
1010 #endif
1011       evdw=energia(1)
1012 #ifdef SCP14
1013       evdw2=energia(2)+energia(18)
1014       evdw2_14=energia(18)
1015 #else
1016       evdw2=energia(2)
1017 #endif
1018 #ifdef SPLITELE
1019       ees=energia(3)
1020       evdw1=energia(16)
1021 #else
1022       ees=energia(3)
1023       evdw1=0.0d0
1024 #endif
1025       ecorr=energia(4)
1026       ecorr5=energia(5)
1027       ecorr6=energia(6)
1028       eel_loc=energia(7)
1029       eello_turn3=energia(8)
1030       eello_turn4=energia(9)
1031       eturn6=energia(10)
1032       ebe=energia(11)
1033       escloc=energia(12)
1034       etors=energia(13)
1035       etors_d=energia(14)
1036       ehpb=energia(15)
1037       edihcnstr=energia(19)
1038       estr=energia(17)
1039       Uconst=energia(20)
1040       esccor=energia(21)
1041       eliptran=energia(22)
1042       Eafmforce=energia(23)
1043       ethetacnstr=energia(24)
1044       etube=energia(25)
1045       evdwpp=energia(26)
1046       eespp=energia(27)
1047       evdwpsb=energia(28)
1048       eelpsb=energia(29)
1049       evdwsb=energia(30)
1050       eelsb=energia(31)
1051       estr_nucl=energia(32)
1052       ebe_nucl=energia(33)
1053       esbloc=energia(34)
1054       etors_nucl=energia(35)
1055       etors_d_nucl=energia(36)
1056       ecorr_nucl=energia(37)
1057       ecorr3_nucl=energia(38)
1058       ecation_prot=energia(42)
1059       ecationcation=energia(41)
1060       escbase=energia(46)
1061       epepbase=energia(47)
1062       escpho=energia(48)
1063       epeppho=energia(49)
1064       ecations_prot_amber=energia(50)
1065
1066 !      energia(41)=ecation_prot
1067 !      energia(42)=ecationcation
1068
1069
1070 #ifdef SPLITELE
1071       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1072        +wang*ebe+wtor*etors+wscloc*escloc &
1073        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1074        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1075        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1076        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1077        +Eafmforce+ethetacnstr  &
1078        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1079        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1080        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1081        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1082        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1083        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+ecations_prot_amber
1084 #else
1085       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1086        +wang*ebe+wtor*etors+wscloc*escloc &
1087        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1088        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1089        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1090        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1091        +Eafmforce+ethetacnstr &
1092        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1093        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1094        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1095        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1096        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1097        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+ecations_prot_amber
1098 #endif
1099       energia(0)=etot
1100 ! detecting NaNQ
1101 #ifdef ISNAN
1102 #ifdef AIX
1103       if (isnan(etot).ne.0) energia(0)=1.0d+99
1104 #else
1105       if (isnan(etot)) energia(0)=1.0d+99
1106 #endif
1107 #else
1108       i=0
1109 #ifdef WINPGI
1110       idumm=proc_proc(etot,i)
1111 #else
1112       call proc_proc(etot,i)
1113 #endif
1114       if(i.eq.1)energia(0)=1.0d+99
1115 #endif
1116 #ifdef MPI
1117       endif
1118 #endif
1119 !      call enerprint(energia)
1120       call flush(iout)
1121       return
1122       end subroutine sum_energy
1123 !-----------------------------------------------------------------------------
1124       subroutine rescale_weights(t_bath)
1125 !      implicit real*8 (a-h,o-z)
1126 #ifdef MPI
1127       include 'mpif.h'
1128 #endif
1129 !      include 'DIMENSIONS'
1130 !      include 'COMMON.IOUNITS'
1131 !      include 'COMMON.FFIELD'
1132 !      include 'COMMON.SBRIDGE'
1133       real(kind=8) :: kfac=2.4d0
1134       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1135 !el local variables
1136       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1137       real(kind=8) :: T0=3.0d2
1138       integer :: ierror
1139 !      facT=temp0/t_bath
1140 !      facT=2*temp0/(t_bath+temp0)
1141       if (rescale_mode.eq.0) then
1142         facT(1)=1.0d0
1143         facT(2)=1.0d0
1144         facT(3)=1.0d0
1145         facT(4)=1.0d0
1146         facT(5)=1.0d0
1147         facT(6)=1.0d0
1148       else if (rescale_mode.eq.1) then
1149         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1150         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1151         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1152         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1153         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1154 #ifdef WHAM_RUN
1155 !#if defined(WHAM_RUN) || defined(CLUSTER)
1156 #if defined(FUNCTH)
1157 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1158         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1159 #elif defined(FUNCT)
1160         facT(6)=t_bath/T0
1161 #else
1162         facT(6)=1.0d0
1163 #endif
1164 #endif
1165       else if (rescale_mode.eq.2) then
1166         x=t_bath/temp0
1167         x2=x*x
1168         x3=x2*x
1169         x4=x3*x
1170         x5=x4*x
1171         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1172         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1173         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1174         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1175         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1176 #ifdef WHAM_RUN
1177 !#if defined(WHAM_RUN) || defined(CLUSTER)
1178 #if defined(FUNCTH)
1179         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1180 #elif defined(FUNCT)
1181         facT(6)=t_bath/T0
1182 #else
1183         facT(6)=1.0d0
1184 #endif
1185 #endif
1186       else
1187         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1188         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1189 #ifdef MPI
1190        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1191 #endif
1192        stop 555
1193       endif
1194       welec=weights(3)*fact(1)
1195       wcorr=weights(4)*fact(3)
1196       wcorr5=weights(5)*fact(4)
1197       wcorr6=weights(6)*fact(5)
1198       wel_loc=weights(7)*fact(2)
1199       wturn3=weights(8)*fact(2)
1200       wturn4=weights(9)*fact(3)
1201       wturn6=weights(10)*fact(5)
1202       wtor=weights(13)*fact(1)
1203       wtor_d=weights(14)*fact(2)
1204       wsccor=weights(21)*fact(1)
1205       welpsb=weights(28)*fact(1)
1206       wcorr_nucl= weights(37)*fact(1)
1207       wcorr3_nucl=weights(38)*fact(2)
1208       wtor_nucl=  weights(35)*fact(1)
1209       wtor_d_nucl=weights(36)*fact(2)
1210       wpepbase=weights(47)*fact(1)
1211       return
1212       end subroutine rescale_weights
1213 !-----------------------------------------------------------------------------
1214       subroutine enerprint(energia)
1215 !      implicit real*8 (a-h,o-z)
1216 !      include 'DIMENSIONS'
1217 !      include 'COMMON.IOUNITS'
1218 !      include 'COMMON.FFIELD'
1219 !      include 'COMMON.SBRIDGE'
1220 !      include 'COMMON.MD'
1221       real(kind=8) :: energia(0:n_ene)
1222 !el local variables
1223       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1224       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1225       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1226        etube,ethetacnstr,Eafmforce
1227       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1228                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1229                       ecorr3_nucl
1230       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1231       real(kind=8) :: escbase,epepbase,escpho,epeppho
1232
1233       etot=energia(0)
1234       evdw=energia(1)
1235       evdw2=energia(2)
1236 #ifdef SCP14
1237       evdw2=energia(2)+energia(18)
1238 #else
1239       evdw2=energia(2)
1240 #endif
1241       ees=energia(3)
1242 #ifdef SPLITELE
1243       evdw1=energia(16)
1244 #endif
1245       ecorr=energia(4)
1246       ecorr5=energia(5)
1247       ecorr6=energia(6)
1248       eel_loc=energia(7)
1249       eello_turn3=energia(8)
1250       eello_turn4=energia(9)
1251       eello_turn6=energia(10)
1252       ebe=energia(11)
1253       escloc=energia(12)
1254       etors=energia(13)
1255       etors_d=energia(14)
1256       ehpb=energia(15)
1257       edihcnstr=energia(19)
1258       estr=energia(17)
1259       Uconst=energia(20)
1260       esccor=energia(21)
1261       eliptran=energia(22)
1262       Eafmforce=energia(23)
1263       ethetacnstr=energia(24)
1264       etube=energia(25)
1265       evdwpp=energia(26)
1266       eespp=energia(27)
1267       evdwpsb=energia(28)
1268       eelpsb=energia(29)
1269       evdwsb=energia(30)
1270       eelsb=energia(31)
1271       estr_nucl=energia(32)
1272       ebe_nucl=energia(33)
1273       esbloc=energia(34)
1274       etors_nucl=energia(35)
1275       etors_d_nucl=energia(36)
1276       ecorr_nucl=energia(37)
1277       ecorr3_nucl=energia(38)
1278       ecation_prot=energia(42)
1279       ecationcation=energia(41)
1280       escbase=energia(46)
1281       epepbase=energia(47)
1282       escpho=energia(48)
1283       epeppho=energia(49)
1284       ecations_prot_amber=energia(50)
1285 #ifdef SPLITELE
1286       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1287         estr,wbond,ebe,wang,&
1288         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1289         ecorr,wcorr,&
1290         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1291         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1292         edihcnstr,ethetacnstr,ebr*nss,&
1293         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1294         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1295         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1296         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1297         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1298         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1299         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1300         ecations_prot_amber,etot
1301    10 format (/'Virtual-chain energies:'// &
1302        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1303        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1304        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1305        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1306        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1307        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1308        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1309        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1310        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1311        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1312        ' (SS bridges & dist. cnstr.)'/ &
1313        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1314        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1315        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1316        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1317        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1318        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1319        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1320        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1321        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1322        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1323        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1324        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1325        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1326        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1327        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1328        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1329        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1330        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1331        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1332        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1333        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1334        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1335        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1336        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1337        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1338        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1339        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1340        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1341        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1342        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1343        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1344        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1345        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1346        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1347        'ETOT=  ',1pE16.6,' (total)')
1348 #else
1349       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1350         estr,wbond,ebe,wang,&
1351         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1352         ecorr,wcorr,&
1353         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1354         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1355         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1356         etube,wtube, &
1357         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1358         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1359         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1360         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1361         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1362         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1363         ecations_prot_amber,etot
1364    10 format (/'Virtual-chain energies:'// &
1365        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1366        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1367        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1368        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1369        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1370        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1371        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1372        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1373        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1374        ' (SS bridges & dist. cnstr.)'/ &
1375        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1376        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1377        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1378        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1379        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1380        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1381        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1382        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1383        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1384        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1385        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1386        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1387        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1388        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1389        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1390        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1391        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1392        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1393        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1394        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1395        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1396        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1397        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1398        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1399        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1400        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1401        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1402        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1403        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1404        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1405        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1406        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1407        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1408        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1409        'ETOT=  ',1pE16.6,' (total)')
1410 #endif
1411       return
1412       end subroutine enerprint
1413 !-----------------------------------------------------------------------------
1414       subroutine elj(evdw)
1415 !
1416 ! This subroutine calculates the interaction energy of nonbonded side chains
1417 ! assuming the LJ potential of interaction.
1418 !
1419 !      implicit real*8 (a-h,o-z)
1420 !      include 'DIMENSIONS'
1421       real(kind=8),parameter :: accur=1.0d-10
1422 !      include 'COMMON.GEO'
1423 !      include 'COMMON.VAR'
1424 !      include 'COMMON.LOCAL'
1425 !      include 'COMMON.CHAIN'
1426 !      include 'COMMON.DERIV'
1427 !      include 'COMMON.INTERACT'
1428 !      include 'COMMON.TORSION'
1429 !      include 'COMMON.SBRIDGE'
1430 !      include 'COMMON.NAMES'
1431 !      include 'COMMON.IOUNITS'
1432 !      include 'COMMON.CONTACTS'
1433       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1434       integer :: num_conti
1435 !el local variables
1436       integer :: i,itypi,iint,j,itypi1,itypj,k
1437       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1438       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1439       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1440
1441 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1442       evdw=0.0D0
1443 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1444 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1445 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1446 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1447
1448       do i=iatsc_s,iatsc_e
1449         itypi=iabs(itype(i,1))
1450         if (itypi.eq.ntyp1) cycle
1451         itypi1=iabs(itype(i+1,1))
1452         xi=c(1,nres+i)
1453         yi=c(2,nres+i)
1454         zi=c(3,nres+i)
1455 ! Change 12/1/95
1456         num_conti=0
1457 !
1458 ! Calculate SC interaction energy.
1459 !
1460         do iint=1,nint_gr(i)
1461 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1462 !d   &                  'iend=',iend(i,iint)
1463           do j=istart(i,iint),iend(i,iint)
1464             itypj=iabs(itype(j,1))
1465             if (itypj.eq.ntyp1) cycle
1466             xj=c(1,nres+j)-xi
1467             yj=c(2,nres+j)-yi
1468             zj=c(3,nres+j)-zi
1469 ! Change 12/1/95 to calculate four-body interactions
1470             rij=xj*xj+yj*yj+zj*zj
1471             rrij=1.0D0/rij
1472 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1473             eps0ij=eps(itypi,itypj)
1474             fac=rrij**expon2
1475             e1=fac*fac*aa_aq(itypi,itypj)
1476             e2=fac*bb_aq(itypi,itypj)
1477             evdwij=e1+e2
1478 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1479 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1480 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1481 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1482 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1483 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1484             evdw=evdw+evdwij
1485 !
1486 ! Calculate the components of the gradient in DC and X
1487 !
1488             fac=-rrij*(e1+evdwij)
1489             gg(1)=xj*fac
1490             gg(2)=yj*fac
1491             gg(3)=zj*fac
1492             do k=1,3
1493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1497             enddo
1498 !grad            do k=i,j-1
1499 !grad              do l=1,3
1500 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1501 !grad              enddo
1502 !grad            enddo
1503 !
1504 ! 12/1/95, revised on 5/20/97
1505 !
1506 ! Calculate the contact function. The ith column of the array JCONT will
1507 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1508 ! greater than I). The arrays FACONT and GACONT will contain the values of
1509 ! the contact function and its derivative.
1510 !
1511 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1512 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1513 ! Uncomment next line, if the correlation interactions are contact function only
1514             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1515               rij=dsqrt(rij)
1516               sigij=sigma(itypi,itypj)
1517               r0ij=rs0(itypi,itypj)
1518 !
1519 ! Check whether the SC's are not too far to make a contact.
1520 !
1521               rcut=1.5d0*r0ij
1522               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1523 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1524 !
1525               if (fcont.gt.0.0D0) then
1526 ! If the SC-SC distance if close to sigma, apply spline.
1527 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1528 !Adam &             fcont1,fprimcont1)
1529 !Adam           fcont1=1.0d0-fcont1
1530 !Adam           if (fcont1.gt.0.0d0) then
1531 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1532 !Adam             fcont=fcont*fcont1
1533 !Adam           endif
1534 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1535 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1536 !ga             do k=1,3
1537 !ga               gg(k)=gg(k)*eps0ij
1538 !ga             enddo
1539 !ga             eps0ij=-evdwij*eps0ij
1540 ! Uncomment for AL's type of SC correlation interactions.
1541 !adam           eps0ij=-evdwij
1542                 num_conti=num_conti+1
1543                 jcont(num_conti,i)=j
1544                 facont(num_conti,i)=fcont*eps0ij
1545                 fprimcont=eps0ij*fprimcont/rij
1546                 fcont=expon*fcont
1547 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1548 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1549 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1550 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1551                 gacont(1,num_conti,i)=-fprimcont*xj
1552                 gacont(2,num_conti,i)=-fprimcont*yj
1553                 gacont(3,num_conti,i)=-fprimcont*zj
1554 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1555 !d              write (iout,'(2i3,3f10.5)')
1556 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1557               endif
1558             endif
1559           enddo      ! j
1560         enddo        ! iint
1561 ! Change 12/1/95
1562         num_cont(i)=num_conti
1563       enddo          ! i
1564       do i=1,nct
1565         do j=1,3
1566           gvdwc(j,i)=expon*gvdwc(j,i)
1567           gvdwx(j,i)=expon*gvdwx(j,i)
1568         enddo
1569       enddo
1570 !******************************************************************************
1571 !
1572 !                              N O T E !!!
1573 !
1574 ! To save time, the factor of EXPON has been extracted from ALL components
1575 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1576 ! use!
1577 !
1578 !******************************************************************************
1579       return
1580       end subroutine elj
1581 !-----------------------------------------------------------------------------
1582       subroutine eljk(evdw)
1583 !
1584 ! This subroutine calculates the interaction energy of nonbonded side chains
1585 ! assuming the LJK potential of interaction.
1586 !
1587 !      implicit real*8 (a-h,o-z)
1588 !      include 'DIMENSIONS'
1589 !      include 'COMMON.GEO'
1590 !      include 'COMMON.VAR'
1591 !      include 'COMMON.LOCAL'
1592 !      include 'COMMON.CHAIN'
1593 !      include 'COMMON.DERIV'
1594 !      include 'COMMON.INTERACT'
1595 !      include 'COMMON.IOUNITS'
1596 !      include 'COMMON.NAMES'
1597       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1598       logical :: scheck
1599 !el local variables
1600       integer :: i,iint,j,itypi,itypi1,k,itypj
1601       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1602       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1603
1604 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1605       evdw=0.0D0
1606       do i=iatsc_s,iatsc_e
1607         itypi=iabs(itype(i,1))
1608         if (itypi.eq.ntyp1) cycle
1609         itypi1=iabs(itype(i+1,1))
1610         xi=c(1,nres+i)
1611         yi=c(2,nres+i)
1612         zi=c(3,nres+i)
1613 !
1614 ! Calculate SC interaction energy.
1615 !
1616         do iint=1,nint_gr(i)
1617           do j=istart(i,iint),iend(i,iint)
1618             itypj=iabs(itype(j,1))
1619             if (itypj.eq.ntyp1) cycle
1620             xj=c(1,nres+j)-xi
1621             yj=c(2,nres+j)-yi
1622             zj=c(3,nres+j)-zi
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             fac_augm=rrij**expon
1625             e_augm=augm(itypi,itypj)*fac_augm
1626             r_inv_ij=dsqrt(rrij)
1627             rij=1.0D0/r_inv_ij
1628             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1629             fac=r_shift_inv**expon
1630             e1=fac*fac*aa_aq(itypi,itypj)
1631             e2=fac*bb_aq(itypi,itypj)
1632             evdwij=e_augm+e1+e2
1633 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1634 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1635 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1636 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1637 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1638 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1639 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1640             evdw=evdw+evdwij
1641 !
1642 ! Calculate the components of the gradient in DC and X
1643 !
1644             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1645             gg(1)=xj*fac
1646             gg(2)=yj*fac
1647             gg(3)=zj*fac
1648             do k=1,3
1649               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1650               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1651               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1652               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1653             enddo
1654 !grad            do k=i,j-1
1655 !grad              do l=1,3
1656 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1657 !grad              enddo
1658 !grad            enddo
1659           enddo      ! j
1660         enddo        ! iint
1661       enddo          ! i
1662       do i=1,nct
1663         do j=1,3
1664           gvdwc(j,i)=expon*gvdwc(j,i)
1665           gvdwx(j,i)=expon*gvdwx(j,i)
1666         enddo
1667       enddo
1668       return
1669       end subroutine eljk
1670 !-----------------------------------------------------------------------------
1671       subroutine ebp(evdw)
1672 !
1673 ! This subroutine calculates the interaction energy of nonbonded side chains
1674 ! assuming the Berne-Pechukas potential of interaction.
1675 !
1676       use comm_srutu
1677       use calc_data
1678 !      implicit real*8 (a-h,o-z)
1679 !      include 'DIMENSIONS'
1680 !      include 'COMMON.GEO'
1681 !      include 'COMMON.VAR'
1682 !      include 'COMMON.LOCAL'
1683 !      include 'COMMON.CHAIN'
1684 !      include 'COMMON.DERIV'
1685 !      include 'COMMON.NAMES'
1686 !      include 'COMMON.INTERACT'
1687 !      include 'COMMON.IOUNITS'
1688 !      include 'COMMON.CALC'
1689       use comm_srutu
1690 !el      integer :: icall
1691 !el      common /srutu/ icall
1692 !     double precision rrsave(maxdim)
1693       logical :: lprn
1694 !el local variables
1695       integer :: iint,itypi,itypi1,itypj
1696       real(kind=8) :: rrij,xi,yi,zi
1697       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1698
1699 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1700       evdw=0.0D0
1701 !     if (icall.eq.0) then
1702 !       lprn=.true.
1703 !     else
1704         lprn=.false.
1705 !     endif
1706 !el      ind=0
1707       do i=iatsc_s,iatsc_e
1708         itypi=iabs(itype(i,1))
1709         if (itypi.eq.ntyp1) cycle
1710         itypi1=iabs(itype(i+1,1))
1711         xi=c(1,nres+i)
1712         yi=c(2,nres+i)
1713         zi=c(3,nres+i)
1714         dxi=dc_norm(1,nres+i)
1715         dyi=dc_norm(2,nres+i)
1716         dzi=dc_norm(3,nres+i)
1717 !        dsci_inv=dsc_inv(itypi)
1718         dsci_inv=vbld_inv(i+nres)
1719 !
1720 ! Calculate SC interaction energy.
1721 !
1722         do iint=1,nint_gr(i)
1723           do j=istart(i,iint),iend(i,iint)
1724 !el            ind=ind+1
1725             itypj=iabs(itype(j,1))
1726             if (itypj.eq.ntyp1) cycle
1727 !            dscj_inv=dsc_inv(itypj)
1728             dscj_inv=vbld_inv(j+nres)
1729             chi1=chi(itypi,itypj)
1730             chi2=chi(itypj,itypi)
1731             chi12=chi1*chi2
1732             chip1=chip(itypi)
1733             chip2=chip(itypj)
1734             chip12=chip1*chip2
1735             alf1=alp(itypi)
1736             alf2=alp(itypj)
1737             alf12=0.5D0*(alf1+alf2)
1738 ! For diagnostics only!!!
1739 !           chi1=0.0D0
1740 !           chi2=0.0D0
1741 !           chi12=0.0D0
1742 !           chip1=0.0D0
1743 !           chip2=0.0D0
1744 !           chip12=0.0D0
1745 !           alf1=0.0D0
1746 !           alf2=0.0D0
1747 !           alf12=0.0D0
1748             xj=c(1,nres+j)-xi
1749             yj=c(2,nres+j)-yi
1750             zj=c(3,nres+j)-zi
1751             dxj=dc_norm(1,nres+j)
1752             dyj=dc_norm(2,nres+j)
1753             dzj=dc_norm(3,nres+j)
1754             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1755 !d          if (icall.eq.0) then
1756 !d            rrsave(ind)=rrij
1757 !d          else
1758 !d            rrij=rrsave(ind)
1759 !d          endif
1760             rij=dsqrt(rrij)
1761 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1762             call sc_angular
1763 ! Calculate whole angle-dependent part of epsilon and contributions
1764 ! to its derivatives
1765             fac=(rrij*sigsq)**expon2
1766             e1=fac*fac*aa_aq(itypi,itypj)
1767             e2=fac*bb_aq(itypi,itypj)
1768             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1769             eps2der=evdwij*eps3rt
1770             eps3der=evdwij*eps2rt
1771             evdwij=evdwij*eps2rt*eps3rt
1772             evdw=evdw+evdwij
1773             if (lprn) then
1774             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1776 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1777 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1778 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1779 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1780 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1781 !d     &        evdwij
1782             endif
1783 ! Calculate gradient components.
1784             e1=e1*eps1*eps2rt**2*eps3rt**2
1785             fac=-expon*(e1+evdwij)
1786             sigder=fac/sigsq
1787             fac=rrij*fac
1788 ! Calculate radial part of the gradient
1789             gg(1)=xj*fac
1790             gg(2)=yj*fac
1791             gg(3)=zj*fac
1792 ! Calculate the angular part of the gradient and sum add the contributions
1793 ! to the appropriate components of the Cartesian gradient.
1794             call sc_grad
1795           enddo      ! j
1796         enddo        ! iint
1797       enddo          ! i
1798 !     stop
1799       return
1800       end subroutine ebp
1801 !-----------------------------------------------------------------------------
1802       subroutine egb(evdw)
1803 !
1804 ! This subroutine calculates the interaction energy of nonbonded side chains
1805 ! assuming the Gay-Berne potential of interaction.
1806 !
1807       use calc_data
1808 !      implicit real*8 (a-h,o-z)
1809 !      include 'DIMENSIONS'
1810 !      include 'COMMON.GEO'
1811 !      include 'COMMON.VAR'
1812 !      include 'COMMON.LOCAL'
1813 !      include 'COMMON.CHAIN'
1814 !      include 'COMMON.DERIV'
1815 !      include 'COMMON.NAMES'
1816 !      include 'COMMON.INTERACT'
1817 !      include 'COMMON.IOUNITS'
1818 !      include 'COMMON.CALC'
1819 !      include 'COMMON.CONTROL'
1820 !      include 'COMMON.SBRIDGE'
1821       logical :: lprn
1822 !el local variables
1823       integer :: iint,itypi,itypi1,itypj,subchap
1824       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1825       real(kind=8) :: evdw,sig0ij
1826       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1827                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1828                     sslipi,sslipj,faclip
1829       integer :: ii
1830       real(kind=8) :: fracinbuf
1831
1832 !cccc      energy_dec=.false.
1833 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1834       evdw=0.0D0
1835       lprn=.false.
1836 !     if (icall.eq.0) lprn=.false.
1837 !el      ind=0
1838       dCAVdOM2=0.0d0
1839       dGCLdOM2=0.0d0
1840       dPOLdOM2=0.0d0
1841       dCAVdOM1=0.0d0
1842       dGCLdOM1=0.0d0
1843       dPOLdOM1=0.0d0
1844
1845
1846       do i=iatsc_s,iatsc_e
1847 !C        print *,"I am in EVDW",i
1848         itypi=iabs(itype(i,1))
1849 !        if (i.ne.47) cycle
1850         if (itypi.eq.ntyp1) cycle
1851         itypi1=iabs(itype(i+1,1))
1852         xi=c(1,nres+i)
1853         yi=c(2,nres+i)
1854         zi=c(3,nres+i)
1855           xi=dmod(xi,boxxsize)
1856           if (xi.lt.0) xi=xi+boxxsize
1857           yi=dmod(yi,boxysize)
1858           if (yi.lt.0) yi=yi+boxysize
1859           zi=dmod(zi,boxzsize)
1860           if (zi.lt.0) zi=zi+boxzsize
1861
1862        if ((zi.gt.bordlipbot)  &
1863         .and.(zi.lt.bordliptop)) then
1864 !C the energy transfer exist
1865         if (zi.lt.buflipbot) then
1866 !C what fraction I am in
1867          fracinbuf=1.0d0-  &
1868               ((zi-bordlipbot)/lipbufthick)
1869 !C lipbufthick is thickenes of lipid buffore
1870          sslipi=sscalelip(fracinbuf)
1871          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1872         elseif (zi.gt.bufliptop) then
1873          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1874          sslipi=sscalelip(fracinbuf)
1875          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1876         else
1877          sslipi=1.0d0
1878          ssgradlipi=0.0
1879         endif
1880        else
1881          sslipi=0.0d0
1882          ssgradlipi=0.0
1883        endif
1884 !       print *, sslipi,ssgradlipi
1885         dxi=dc_norm(1,nres+i)
1886         dyi=dc_norm(2,nres+i)
1887         dzi=dc_norm(3,nres+i)
1888 !        dsci_inv=dsc_inv(itypi)
1889         dsci_inv=vbld_inv(i+nres)
1890 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1891 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1892 !
1893 ! Calculate SC interaction energy.
1894 !
1895         do iint=1,nint_gr(i)
1896           do j=istart(i,iint),iend(i,iint)
1897             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1898               call dyn_ssbond_ene(i,j,evdwij)
1899               evdw=evdw+evdwij
1900               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1901                               'evdw',i,j,evdwij,' ss'
1902 !              if (energy_dec) write (iout,*) &
1903 !                              'evdw',i,j,evdwij,' ss'
1904              do k=j+1,iend(i,iint)
1905 !C search over all next residues
1906               if (dyn_ss_mask(k)) then
1907 !C check if they are cysteins
1908 !C              write(iout,*) 'k=',k
1909
1910 !c              write(iout,*) "PRZED TRI", evdwij
1911 !               evdwij_przed_tri=evdwij
1912               call triple_ssbond_ene(i,j,k,evdwij)
1913 !c               if(evdwij_przed_tri.ne.evdwij) then
1914 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1915 !c               endif
1916
1917 !c              write(iout,*) "PO TRI", evdwij
1918 !C call the energy function that removes the artifical triple disulfide
1919 !C bond the soubroutine is located in ssMD.F
1920               evdw=evdw+evdwij
1921               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1922                             'evdw',i,j,evdwij,'tss'
1923               endif!dyn_ss_mask(k)
1924              enddo! k
1925             ELSE
1926 !el            ind=ind+1
1927             itypj=iabs(itype(j,1))
1928             if (itypj.eq.ntyp1) cycle
1929 !             if (j.ne.78) cycle
1930 !            dscj_inv=dsc_inv(itypj)
1931             dscj_inv=vbld_inv(j+nres)
1932 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1933 !              1.0d0/vbld(j+nres) !d
1934 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1935             sig0ij=sigma(itypi,itypj)
1936             chi1=chi(itypi,itypj)
1937             chi2=chi(itypj,itypi)
1938             chi12=chi1*chi2
1939             chip1=chip(itypi)
1940             chip2=chip(itypj)
1941             chip12=chip1*chip2
1942             alf1=alp(itypi)
1943             alf2=alp(itypj)
1944             alf12=0.5D0*(alf1+alf2)
1945 ! For diagnostics only!!!
1946 !           chi1=0.0D0
1947 !           chi2=0.0D0
1948 !           chi12=0.0D0
1949 !           chip1=0.0D0
1950 !           chip2=0.0D0
1951 !           chip12=0.0D0
1952 !           alf1=0.0D0
1953 !           alf2=0.0D0
1954 !           alf12=0.0D0
1955            xj=c(1,nres+j)
1956            yj=c(2,nres+j)
1957            zj=c(3,nres+j)
1958           xj=dmod(xj,boxxsize)
1959           if (xj.lt.0) xj=xj+boxxsize
1960           yj=dmod(yj,boxysize)
1961           if (yj.lt.0) yj=yj+boxysize
1962           zj=dmod(zj,boxzsize)
1963           if (zj.lt.0) zj=zj+boxzsize
1964 !          print *,"tu",xi,yi,zi,xj,yj,zj
1965 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1966 ! this fragment set correct epsilon for lipid phase
1967        if ((zj.gt.bordlipbot)  &
1968        .and.(zj.lt.bordliptop)) then
1969 !C the energy transfer exist
1970         if (zj.lt.buflipbot) then
1971 !C what fraction I am in
1972          fracinbuf=1.0d0-     &
1973              ((zj-bordlipbot)/lipbufthick)
1974 !C lipbufthick is thickenes of lipid buffore
1975          sslipj=sscalelip(fracinbuf)
1976          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1977         elseif (zj.gt.bufliptop) then
1978          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1979          sslipj=sscalelip(fracinbuf)
1980          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1981         else
1982          sslipj=1.0d0
1983          ssgradlipj=0.0
1984         endif
1985        else
1986          sslipj=0.0d0
1987          ssgradlipj=0.0
1988        endif
1989       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1990        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1991       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1992        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1993 !------------------------------------------------
1994       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1995       xj_safe=xj
1996       yj_safe=yj
1997       zj_safe=zj
1998       subchap=0
1999       do xshift=-1,1
2000       do yshift=-1,1
2001       do zshift=-1,1
2002           xj=xj_safe+xshift*boxxsize
2003           yj=yj_safe+yshift*boxysize
2004           zj=zj_safe+zshift*boxzsize
2005           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2006           if(dist_temp.lt.dist_init) then
2007             dist_init=dist_temp
2008             xj_temp=xj
2009             yj_temp=yj
2010             zj_temp=zj
2011             subchap=1
2012           endif
2013        enddo
2014        enddo
2015        enddo
2016        if (subchap.eq.1) then
2017           xj=xj_temp-xi
2018           yj=yj_temp-yi
2019           zj=zj_temp-zi
2020        else
2021           xj=xj_safe-xi
2022           yj=yj_safe-yi
2023           zj=zj_safe-zi
2024        endif
2025             dxj=dc_norm(1,nres+j)
2026             dyj=dc_norm(2,nres+j)
2027             dzj=dc_norm(3,nres+j)
2028 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2029 !            write (iout,*) "j",j," dc_norm",& !d
2030 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2031 !          write(iout,*)"rrij ",rrij
2032 !          write(iout,*)"xj yj zj ", xj, yj, zj
2033 !          write(iout,*)"xi yi zi ", xi, yi, zi
2034 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2035             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2036             rij=dsqrt(rrij)
2037             sss_ele_cut=sscale_ele(1.0d0/(rij))
2038             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2039 !            print *,sss_ele_cut,sss_ele_grad,&
2040 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2041             if (sss_ele_cut.le.0.0) cycle
2042 ! Calculate angle-dependent terms of energy and contributions to their
2043 ! derivatives.
2044             call sc_angular
2045             sigsq=1.0D0/sigsq
2046             sig=sig0ij*dsqrt(sigsq)
2047             rij_shift=1.0D0/rij-sig+sig0ij
2048 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2049 !            "sig0ij",sig0ij
2050 ! for diagnostics; uncomment
2051 !            rij_shift=1.2*sig0ij
2052 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2053             if (rij_shift.le.0.0D0) then
2054               evdw=1.0D20
2055 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2056 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2057 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2058               return
2059             endif
2060             sigder=-sig*sigsq
2061 !---------------------------------------------------------------
2062             rij_shift=1.0D0/rij_shift
2063             fac=rij_shift**expon
2064             faclip=fac
2065             e1=fac*fac*aa!(itypi,itypj)
2066             e2=fac*bb!(itypi,itypj)
2067             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2068             eps2der=evdwij*eps3rt
2069             eps3der=evdwij*eps2rt
2070 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2071 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2072 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2073             evdwij=evdwij*eps2rt*eps3rt
2074             evdw=evdw+evdwij*sss_ele_cut
2075             if (lprn) then
2076             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2077             epsi=bb**2/aa!(itypi,itypj)
2078             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2079               restyp(itypi,1),i,restyp(itypj,1),j, &
2080               epsi,sigm,chi1,chi2,chip1,chip2, &
2081               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2082               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2083               evdwij
2084             endif
2085
2086             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2087                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2088 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2089 !            if (energy_dec) write (iout,*) &
2090 !                             'evdw',i,j,evdwij
2091 !                       print *,"ZALAMKA", evdw
2092
2093 ! Calculate gradient components.
2094             e1=e1*eps1*eps2rt**2*eps3rt**2
2095             fac=-expon*(e1+evdwij)*rij_shift
2096             sigder=fac*sigder
2097             fac=rij*fac
2098 !            print *,'before fac',fac,rij,evdwij
2099             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2100             *rij
2101 !            print *,'grad part scale',fac,   &
2102 !             evdwij*sss_ele_grad/sss_ele_cut &
2103 !            /sigma(itypi,itypj)*rij
2104 !            fac=0.0d0
2105 ! Calculate the radial part of the gradient
2106             gg(1)=xj*fac
2107             gg(2)=yj*fac
2108             gg(3)=zj*fac
2109 !C Calculate the radial part of the gradient
2110             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2111        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2112         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2113        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2114             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2115             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2116
2117 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2118 ! Calculate angular part of the gradient.
2119             call sc_grad
2120             ENDIF    ! dyn_ss
2121           enddo      ! j
2122         enddo        ! iint
2123       enddo          ! i
2124 !       print *,"ZALAMKA", evdw
2125 !      write (iout,*) "Number of loop steps in EGB:",ind
2126 !ccc      energy_dec=.false.
2127       return
2128       end subroutine egb
2129 !-----------------------------------------------------------------------------
2130       subroutine egbv(evdw)
2131 !
2132 ! This subroutine calculates the interaction energy of nonbonded side chains
2133 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2134 !
2135       use comm_srutu
2136       use calc_data
2137 !      implicit real*8 (a-h,o-z)
2138 !      include 'DIMENSIONS'
2139 !      include 'COMMON.GEO'
2140 !      include 'COMMON.VAR'
2141 !      include 'COMMON.LOCAL'
2142 !      include 'COMMON.CHAIN'
2143 !      include 'COMMON.DERIV'
2144 !      include 'COMMON.NAMES'
2145 !      include 'COMMON.INTERACT'
2146 !      include 'COMMON.IOUNITS'
2147 !      include 'COMMON.CALC'
2148       use comm_srutu
2149 !el      integer :: icall
2150 !el      common /srutu/ icall
2151       logical :: lprn
2152 !el local variables
2153       integer :: iint,itypi,itypi1,itypj
2154       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2155       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2156
2157 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2158       evdw=0.0D0
2159       lprn=.false.
2160 !     if (icall.eq.0) lprn=.true.
2161 !el      ind=0
2162       do i=iatsc_s,iatsc_e
2163         itypi=iabs(itype(i,1))
2164         if (itypi.eq.ntyp1) cycle
2165         itypi1=iabs(itype(i+1,1))
2166         xi=c(1,nres+i)
2167         yi=c(2,nres+i)
2168         zi=c(3,nres+i)
2169         dxi=dc_norm(1,nres+i)
2170         dyi=dc_norm(2,nres+i)
2171         dzi=dc_norm(3,nres+i)
2172 !        dsci_inv=dsc_inv(itypi)
2173         dsci_inv=vbld_inv(i+nres)
2174 !
2175 ! Calculate SC interaction energy.
2176 !
2177         do iint=1,nint_gr(i)
2178           do j=istart(i,iint),iend(i,iint)
2179 !el            ind=ind+1
2180             itypj=iabs(itype(j,1))
2181             if (itypj.eq.ntyp1) cycle
2182 !            dscj_inv=dsc_inv(itypj)
2183             dscj_inv=vbld_inv(j+nres)
2184             sig0ij=sigma(itypi,itypj)
2185             r0ij=r0(itypi,itypj)
2186             chi1=chi(itypi,itypj)
2187             chi2=chi(itypj,itypi)
2188             chi12=chi1*chi2
2189             chip1=chip(itypi)
2190             chip2=chip(itypj)
2191             chip12=chip1*chip2
2192             alf1=alp(itypi)
2193             alf2=alp(itypj)
2194             alf12=0.5D0*(alf1+alf2)
2195 ! For diagnostics only!!!
2196 !           chi1=0.0D0
2197 !           chi2=0.0D0
2198 !           chi12=0.0D0
2199 !           chip1=0.0D0
2200 !           chip2=0.0D0
2201 !           chip12=0.0D0
2202 !           alf1=0.0D0
2203 !           alf2=0.0D0
2204 !           alf12=0.0D0
2205             xj=c(1,nres+j)-xi
2206             yj=c(2,nres+j)-yi
2207             zj=c(3,nres+j)-zi
2208             dxj=dc_norm(1,nres+j)
2209             dyj=dc_norm(2,nres+j)
2210             dzj=dc_norm(3,nres+j)
2211             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2212             rij=dsqrt(rrij)
2213 ! Calculate angle-dependent terms of energy and contributions to their
2214 ! derivatives.
2215             call sc_angular
2216             sigsq=1.0D0/sigsq
2217             sig=sig0ij*dsqrt(sigsq)
2218             rij_shift=1.0D0/rij-sig+r0ij
2219 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2220             if (rij_shift.le.0.0D0) then
2221               evdw=1.0D20
2222               return
2223             endif
2224             sigder=-sig*sigsq
2225 !---------------------------------------------------------------
2226             rij_shift=1.0D0/rij_shift
2227             fac=rij_shift**expon
2228             e1=fac*fac*aa_aq(itypi,itypj)
2229             e2=fac*bb_aq(itypi,itypj)
2230             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2231             eps2der=evdwij*eps3rt
2232             eps3der=evdwij*eps2rt
2233             fac_augm=rrij**expon
2234             e_augm=augm(itypi,itypj)*fac_augm
2235             evdwij=evdwij*eps2rt*eps3rt
2236             evdw=evdw+evdwij+e_augm
2237             if (lprn) then
2238             sigm=dabs(aa_aq(itypi,itypj)/&
2239             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2240             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2241             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2242               restyp(itypi,1),i,restyp(itypj,1),j,&
2243               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2244               chi1,chi2,chip1,chip2,&
2245               eps1,eps2rt**2,eps3rt**2,&
2246               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2247               evdwij+e_augm
2248             endif
2249 ! Calculate gradient components.
2250             e1=e1*eps1*eps2rt**2*eps3rt**2
2251             fac=-expon*(e1+evdwij)*rij_shift
2252             sigder=fac*sigder
2253             fac=rij*fac-2*expon*rrij*e_augm
2254 ! Calculate the radial part of the gradient
2255             gg(1)=xj*fac
2256             gg(2)=yj*fac
2257             gg(3)=zj*fac
2258 ! Calculate angular part of the gradient.
2259             call sc_grad
2260           enddo      ! j
2261         enddo        ! iint
2262       enddo          ! i
2263       end subroutine egbv
2264 !-----------------------------------------------------------------------------
2265 !el      subroutine sc_angular in module geometry
2266 !-----------------------------------------------------------------------------
2267       subroutine e_softsphere(evdw)
2268 !
2269 ! This subroutine calculates the interaction energy of nonbonded side chains
2270 ! assuming the LJ potential of interaction.
2271 !
2272 !      implicit real*8 (a-h,o-z)
2273 !      include 'DIMENSIONS'
2274       real(kind=8),parameter :: accur=1.0d-10
2275 !      include 'COMMON.GEO'
2276 !      include 'COMMON.VAR'
2277 !      include 'COMMON.LOCAL'
2278 !      include 'COMMON.CHAIN'
2279 !      include 'COMMON.DERIV'
2280 !      include 'COMMON.INTERACT'
2281 !      include 'COMMON.TORSION'
2282 !      include 'COMMON.SBRIDGE'
2283 !      include 'COMMON.NAMES'
2284 !      include 'COMMON.IOUNITS'
2285 !      include 'COMMON.CONTACTS'
2286       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2287 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2288 !el local variables
2289       integer :: i,iint,j,itypi,itypi1,itypj,k
2290       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2291       real(kind=8) :: fac
2292
2293       evdw=0.0D0
2294       do i=iatsc_s,iatsc_e
2295         itypi=iabs(itype(i,1))
2296         if (itypi.eq.ntyp1) cycle
2297         itypi1=iabs(itype(i+1,1))
2298         xi=c(1,nres+i)
2299         yi=c(2,nres+i)
2300         zi=c(3,nres+i)
2301 !
2302 ! Calculate SC interaction energy.
2303 !
2304         do iint=1,nint_gr(i)
2305 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2306 !d   &                  'iend=',iend(i,iint)
2307           do j=istart(i,iint),iend(i,iint)
2308             itypj=iabs(itype(j,1))
2309             if (itypj.eq.ntyp1) cycle
2310             xj=c(1,nres+j)-xi
2311             yj=c(2,nres+j)-yi
2312             zj=c(3,nres+j)-zi
2313             rij=xj*xj+yj*yj+zj*zj
2314 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2315             r0ij=r0(itypi,itypj)
2316             r0ijsq=r0ij*r0ij
2317 !            print *,i,j,r0ij,dsqrt(rij)
2318             if (rij.lt.r0ijsq) then
2319               evdwij=0.25d0*(rij-r0ijsq)**2
2320               fac=rij-r0ijsq
2321             else
2322               evdwij=0.0d0
2323               fac=0.0d0
2324             endif
2325             evdw=evdw+evdwij
2326 !
2327 ! Calculate the components of the gradient in DC and X
2328 !
2329             gg(1)=xj*fac
2330             gg(2)=yj*fac
2331             gg(3)=zj*fac
2332             do k=1,3
2333               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2334               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2335               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2336               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2337             enddo
2338 !grad            do k=i,j-1
2339 !grad              do l=1,3
2340 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2341 !grad              enddo
2342 !grad            enddo
2343           enddo ! j
2344         enddo ! iint
2345       enddo ! i
2346       return
2347       end subroutine e_softsphere
2348 !-----------------------------------------------------------------------------
2349       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2350 !
2351 ! Soft-sphere potential of p-p interaction
2352 !
2353 !      implicit real*8 (a-h,o-z)
2354 !      include 'DIMENSIONS'
2355 !      include 'COMMON.CONTROL'
2356 !      include 'COMMON.IOUNITS'
2357 !      include 'COMMON.GEO'
2358 !      include 'COMMON.VAR'
2359 !      include 'COMMON.LOCAL'
2360 !      include 'COMMON.CHAIN'
2361 !      include 'COMMON.DERIV'
2362 !      include 'COMMON.INTERACT'
2363 !      include 'COMMON.CONTACTS'
2364 !      include 'COMMON.TORSION'
2365 !      include 'COMMON.VECTORS'
2366 !      include 'COMMON.FFIELD'
2367       real(kind=8),dimension(3) :: ggg
2368 !d      write(iout,*) 'In EELEC_soft_sphere'
2369 !el local variables
2370       integer :: i,j,k,num_conti,iteli,itelj
2371       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2372       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2373       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2374
2375       ees=0.0D0
2376       evdw1=0.0D0
2377       eel_loc=0.0d0
2378       eello_turn3=0.0d0
2379       eello_turn4=0.0d0
2380 !el      ind=0
2381       do i=iatel_s,iatel_e
2382         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2383         dxi=dc(1,i)
2384         dyi=dc(2,i)
2385         dzi=dc(3,i)
2386         xmedi=c(1,i)+0.5d0*dxi
2387         ymedi=c(2,i)+0.5d0*dyi
2388         zmedi=c(3,i)+0.5d0*dzi
2389         num_conti=0
2390 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2391         do j=ielstart(i),ielend(i)
2392           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2393 !el          ind=ind+1
2394           iteli=itel(i)
2395           itelj=itel(j)
2396           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2397           r0ij=rpp(iteli,itelj)
2398           r0ijsq=r0ij*r0ij
2399           dxj=dc(1,j)
2400           dyj=dc(2,j)
2401           dzj=dc(3,j)
2402           xj=c(1,j)+0.5D0*dxj-xmedi
2403           yj=c(2,j)+0.5D0*dyj-ymedi
2404           zj=c(3,j)+0.5D0*dzj-zmedi
2405           rij=xj*xj+yj*yj+zj*zj
2406           if (rij.lt.r0ijsq) then
2407             evdw1ij=0.25d0*(rij-r0ijsq)**2
2408             fac=rij-r0ijsq
2409           else
2410             evdw1ij=0.0d0
2411             fac=0.0d0
2412           endif
2413           evdw1=evdw1+evdw1ij
2414 !
2415 ! Calculate contributions to the Cartesian gradient.
2416 !
2417           ggg(1)=fac*xj
2418           ggg(2)=fac*yj
2419           ggg(3)=fac*zj
2420           do k=1,3
2421             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2422             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2423           enddo
2424 !
2425 ! Loop over residues i+1 thru j-1.
2426 !
2427 !grad          do k=i+1,j-1
2428 !grad            do l=1,3
2429 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2430 !grad            enddo
2431 !grad          enddo
2432         enddo ! j
2433       enddo   ! i
2434 !grad      do i=nnt,nct-1
2435 !grad        do k=1,3
2436 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2437 !grad        enddo
2438 !grad        do j=i+1,nct-1
2439 !grad          do k=1,3
2440 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2441 !grad          enddo
2442 !grad        enddo
2443 !grad      enddo
2444       return
2445       end subroutine eelec_soft_sphere
2446 !-----------------------------------------------------------------------------
2447       subroutine vec_and_deriv
2448 !      implicit real*8 (a-h,o-z)
2449 !      include 'DIMENSIONS'
2450 #ifdef MPI
2451       include 'mpif.h'
2452 #endif
2453 !      include 'COMMON.IOUNITS'
2454 !      include 'COMMON.GEO'
2455 !      include 'COMMON.VAR'
2456 !      include 'COMMON.LOCAL'
2457 !      include 'COMMON.CHAIN'
2458 !      include 'COMMON.VECTORS'
2459 !      include 'COMMON.SETUP'
2460 !      include 'COMMON.TIME1'
2461       real(kind=8),dimension(3,3,2) :: uyder,uzder
2462       real(kind=8),dimension(2) :: vbld_inv_temp
2463 ! Compute the local reference systems. For reference system (i), the
2464 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2465 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2466 !el local variables
2467       integer :: i,j,k,l
2468       real(kind=8) :: facy,fac,costh
2469
2470 #ifdef PARVEC
2471       do i=ivec_start,ivec_end
2472 #else
2473       do i=1,nres-1
2474 #endif
2475           if (i.eq.nres-1) then
2476 ! Case of the last full residue
2477 ! Compute the Z-axis
2478             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2479             costh=dcos(pi-theta(nres))
2480             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2481             do k=1,3
2482               uz(k,i)=fac*uz(k,i)
2483             enddo
2484 ! Compute the derivatives of uz
2485             uzder(1,1,1)= 0.0d0
2486             uzder(2,1,1)=-dc_norm(3,i-1)
2487             uzder(3,1,1)= dc_norm(2,i-1)
2488             uzder(1,2,1)= dc_norm(3,i-1)
2489             uzder(2,2,1)= 0.0d0
2490             uzder(3,2,1)=-dc_norm(1,i-1)
2491             uzder(1,3,1)=-dc_norm(2,i-1)
2492             uzder(2,3,1)= dc_norm(1,i-1)
2493             uzder(3,3,1)= 0.0d0
2494             uzder(1,1,2)= 0.0d0
2495             uzder(2,1,2)= dc_norm(3,i)
2496             uzder(3,1,2)=-dc_norm(2,i)
2497             uzder(1,2,2)=-dc_norm(3,i)
2498             uzder(2,2,2)= 0.0d0
2499             uzder(3,2,2)= dc_norm(1,i)
2500             uzder(1,3,2)= dc_norm(2,i)
2501             uzder(2,3,2)=-dc_norm(1,i)
2502             uzder(3,3,2)= 0.0d0
2503 ! Compute the Y-axis
2504             facy=fac
2505             do k=1,3
2506               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2507             enddo
2508 ! Compute the derivatives of uy
2509             do j=1,3
2510               do k=1,3
2511                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2512                               -dc_norm(k,i)*dc_norm(j,i-1)
2513                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2514               enddo
2515               uyder(j,j,1)=uyder(j,j,1)-costh
2516               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2517             enddo
2518             do j=1,2
2519               do k=1,3
2520                 do l=1,3
2521                   uygrad(l,k,j,i)=uyder(l,k,j)
2522                   uzgrad(l,k,j,i)=uzder(l,k,j)
2523                 enddo
2524               enddo
2525             enddo
2526             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2527             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2528             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2529             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2530           else
2531 ! Other residues
2532 ! Compute the Z-axis
2533             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2534             costh=dcos(pi-theta(i+2))
2535             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2536             do k=1,3
2537               uz(k,i)=fac*uz(k,i)
2538             enddo
2539 ! Compute the derivatives of uz
2540             uzder(1,1,1)= 0.0d0
2541             uzder(2,1,1)=-dc_norm(3,i+1)
2542             uzder(3,1,1)= dc_norm(2,i+1)
2543             uzder(1,2,1)= dc_norm(3,i+1)
2544             uzder(2,2,1)= 0.0d0
2545             uzder(3,2,1)=-dc_norm(1,i+1)
2546             uzder(1,3,1)=-dc_norm(2,i+1)
2547             uzder(2,3,1)= dc_norm(1,i+1)
2548             uzder(3,3,1)= 0.0d0
2549             uzder(1,1,2)= 0.0d0
2550             uzder(2,1,2)= dc_norm(3,i)
2551             uzder(3,1,2)=-dc_norm(2,i)
2552             uzder(1,2,2)=-dc_norm(3,i)
2553             uzder(2,2,2)= 0.0d0
2554             uzder(3,2,2)= dc_norm(1,i)
2555             uzder(1,3,2)= dc_norm(2,i)
2556             uzder(2,3,2)=-dc_norm(1,i)
2557             uzder(3,3,2)= 0.0d0
2558 ! Compute the Y-axis
2559             facy=fac
2560             do k=1,3
2561               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2562             enddo
2563 ! Compute the derivatives of uy
2564             do j=1,3
2565               do k=1,3
2566                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2567                               -dc_norm(k,i)*dc_norm(j,i+1)
2568                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2569               enddo
2570               uyder(j,j,1)=uyder(j,j,1)-costh
2571               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2572             enddo
2573             do j=1,2
2574               do k=1,3
2575                 do l=1,3
2576                   uygrad(l,k,j,i)=uyder(l,k,j)
2577                   uzgrad(l,k,j,i)=uzder(l,k,j)
2578                 enddo
2579               enddo
2580             enddo
2581             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2582             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2583             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2584             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2585           endif
2586       enddo
2587       do i=1,nres-1
2588         vbld_inv_temp(1)=vbld_inv(i+1)
2589         if (i.lt.nres-1) then
2590           vbld_inv_temp(2)=vbld_inv(i+2)
2591           else
2592           vbld_inv_temp(2)=vbld_inv(i)
2593           endif
2594         do j=1,2
2595           do k=1,3
2596             do l=1,3
2597               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2598               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2599             enddo
2600           enddo
2601         enddo
2602       enddo
2603 #if defined(PARVEC) && defined(MPI)
2604       if (nfgtasks1.gt.1) then
2605         time00=MPI_Wtime()
2606 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2607 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2608 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2609         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2610          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2611          FG_COMM1,IERR)
2612         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2613          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2614          FG_COMM1,IERR)
2615         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2616          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2617          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2618         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2619          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2620          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2621         time_gather=time_gather+MPI_Wtime()-time00
2622       endif
2623 !      if (fg_rank.eq.0) then
2624 !        write (iout,*) "Arrays UY and UZ"
2625 !        do i=1,nres-1
2626 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2627 !     &     (uz(k,i),k=1,3)
2628 !        enddo
2629 !      endif
2630 #endif
2631       return
2632       end subroutine vec_and_deriv
2633 !-----------------------------------------------------------------------------
2634       subroutine check_vecgrad
2635 !      implicit real*8 (a-h,o-z)
2636 !      include 'DIMENSIONS'
2637 !      include 'COMMON.IOUNITS'
2638 !      include 'COMMON.GEO'
2639 !      include 'COMMON.VAR'
2640 !      include 'COMMON.LOCAL'
2641 !      include 'COMMON.CHAIN'
2642 !      include 'COMMON.VECTORS'
2643       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2644       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2645       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2646       real(kind=8),dimension(3) :: erij
2647       real(kind=8) :: delta=1.0d-7
2648 !el local variables
2649       integer :: i,j,k,l
2650
2651       call vec_and_deriv
2652 !d      do i=1,nres
2653 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2654 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2655 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2656 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2657 !d     &     (dc_norm(if90,i),if90=1,3)
2658 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2659 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2660 !d          write(iout,'(a)')
2661 !d      enddo
2662       do i=1,nres
2663         do j=1,2
2664           do k=1,3
2665             do l=1,3
2666               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2667               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2668             enddo
2669           enddo
2670         enddo
2671       enddo
2672       call vec_and_deriv
2673       do i=1,nres
2674         do j=1,3
2675           uyt(j,i)=uy(j,i)
2676           uzt(j,i)=uz(j,i)
2677         enddo
2678       enddo
2679       do i=1,nres
2680 !d        write (iout,*) 'i=',i
2681         do k=1,3
2682           erij(k)=dc_norm(k,i)
2683         enddo
2684         do j=1,3
2685           do k=1,3
2686             dc_norm(k,i)=erij(k)
2687           enddo
2688           dc_norm(j,i)=dc_norm(j,i)+delta
2689 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2690 !          do k=1,3
2691 !            dc_norm(k,i)=dc_norm(k,i)/fac
2692 !          enddo
2693 !          write (iout,*) (dc_norm(k,i),k=1,3)
2694 !          write (iout,*) (erij(k),k=1,3)
2695           call vec_and_deriv
2696           do k=1,3
2697             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2698             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2699             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2700             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2701           enddo
2702 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2703 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2704 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2705         enddo
2706         do k=1,3
2707           dc_norm(k,i)=erij(k)
2708         enddo
2709 !d        do k=1,3
2710 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2711 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2712 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2713 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2714 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2715 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2716 !d          write (iout,'(a)')
2717 !d        enddo
2718       enddo
2719       return
2720       end subroutine check_vecgrad
2721 !-----------------------------------------------------------------------------
2722       subroutine set_matrices
2723 !      implicit real*8 (a-h,o-z)
2724 !      include 'DIMENSIONS'
2725 #ifdef MPI
2726       include "mpif.h"
2727 !      include "COMMON.SETUP"
2728       integer :: IERR
2729       integer :: status(MPI_STATUS_SIZE)
2730 #endif
2731 !      include 'COMMON.IOUNITS'
2732 !      include 'COMMON.GEO'
2733 !      include 'COMMON.VAR'
2734 !      include 'COMMON.LOCAL'
2735 !      include 'COMMON.CHAIN'
2736 !      include 'COMMON.DERIV'
2737 !      include 'COMMON.INTERACT'
2738 !      include 'COMMON.CONTACTS'
2739 !      include 'COMMON.TORSION'
2740 !      include 'COMMON.VECTORS'
2741 !      include 'COMMON.FFIELD'
2742       real(kind=8) :: auxvec(2),auxmat(2,2)
2743       integer :: i,iti1,iti,k,l
2744       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2745        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2746 !       print *,"in set matrices"
2747 !
2748 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2749 ! to calculate the el-loc multibody terms of various order.
2750 !
2751 !AL el      mu=0.0d0
2752
2753 #ifdef PARMAT
2754       do i=ivec_start+2,ivec_end+2
2755 #else
2756       do i=3,nres+1
2757 #endif
2758         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2759           if (itype(i-2,1).eq.0) then
2760           iti = nloctyp
2761           else
2762           iti = itype2loc(itype(i-2,1))
2763           endif
2764         else
2765           iti=nloctyp
2766         endif
2767 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2768         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2769           iti1 = itype2loc(itype(i-1,1))
2770         else
2771           iti1=nloctyp
2772         endif
2773 !        print *,i,itype(i-2,1),iti
2774 #ifdef NEWCORR
2775         cost1=dcos(theta(i-1))
2776         sint1=dsin(theta(i-1))
2777         sint1sq=sint1*sint1
2778         sint1cub=sint1sq*sint1
2779         sint1cost1=2*sint1*cost1
2780 !        print *,"cost1",cost1,theta(i-1)
2781 !c        write (iout,*) "bnew1",i,iti
2782 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2783 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2784 !c        write (iout,*) "bnew2",i,iti
2785 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2786 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2787         k=1
2788 !        print *,bnew1(1,k,iti),"bnew1"
2789         do k=1,2
2790           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2791 !          print *,b1k
2792 !          write(*,*) shape(b1)
2793 !          if(.not.allocated(b1)) print *, "WTF?"
2794           b1(k,i-2)=sint1*b1k
2795 !
2796 !             print *,b1(k,i-2)
2797
2798           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2799                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2800 !             print *,gtb1(k,i-2)
2801
2802           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2803           b2(k,i-2)=sint1*b2k
2804 !             print *,b2(k,i-2)
2805
2806           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2807                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2808 !             print *,gtb2(k,i-2)
2809
2810         enddo
2811 !        print *,b1k,b2k
2812         do k=1,2
2813           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2814           cc(1,k,i-2)=sint1sq*aux
2815           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2816                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2817           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2818           dd(1,k,i-2)=sint1sq*aux
2819           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2820                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2821         enddo
2822 !        print *,"after cc"
2823         cc(2,1,i-2)=cc(1,2,i-2)
2824         cc(2,2,i-2)=-cc(1,1,i-2)
2825         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2826         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2827         dd(2,1,i-2)=dd(1,2,i-2)
2828         dd(2,2,i-2)=-dd(1,1,i-2)
2829         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2830         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2831 !        print *,"after dd"
2832
2833         do k=1,2
2834           do l=1,2
2835             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2836             EE(l,k,i-2)=sint1sq*aux
2837             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2838           enddo
2839         enddo
2840         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2841         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2842         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2843         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2844         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2845         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2846         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2847 !        print *,"after ee"
2848
2849 !c        b1tilde(1,i-2)=b1(1,i-2)
2850 !c        b1tilde(2,i-2)=-b1(2,i-2)
2851 !c        b2tilde(1,i-2)=b2(1,i-2)
2852 !c        b2tilde(2,i-2)=-b2(2,i-2)
2853 #ifdef DEBUG
2854         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2855         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2856         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2857         write (iout,*) 'theta=', theta(i-1)
2858 #endif
2859 #else
2860         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2861 !         write(iout,*) "i,",molnum(i)
2862 !         print *, "i,",molnum(i),i,itype(i-2,1)
2863         if (molnum(i).eq.1) then
2864           iti = itype2loc(itype(i-2,1))
2865         else
2866           iti=nloctyp
2867         endif
2868         else
2869           iti=nloctyp
2870         endif
2871 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2872 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2873         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2874           iti1 = itype2loc(itype(i-1,1))
2875         else
2876           iti1=nloctyp
2877         endif
2878 !        print *,i,iti
2879         b1(1,i-2)=b(3,iti)
2880         b1(2,i-2)=b(5,iti)
2881         b2(1,i-2)=b(2,iti)
2882         b2(2,i-2)=b(4,iti)
2883         do k=1,2
2884           do l=1,2
2885            CC(k,l,i-2)=ccold(k,l,iti)
2886            DD(k,l,i-2)=ddold(k,l,iti)
2887            EE(k,l,i-2)=eeold(k,l,iti)
2888           enddo
2889         enddo
2890 #endif
2891         b1tilde(1,i-2)= b1(1,i-2)
2892         b1tilde(2,i-2)=-b1(2,i-2)
2893         b2tilde(1,i-2)= b2(1,i-2)
2894         b2tilde(2,i-2)=-b2(2,i-2)
2895 !c
2896         Ctilde(1,1,i-2)= CC(1,1,i-2)
2897         Ctilde(1,2,i-2)= CC(1,2,i-2)
2898         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2899         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2900 !c
2901         Dtilde(1,1,i-2)= DD(1,1,i-2)
2902         Dtilde(1,2,i-2)= DD(1,2,i-2)
2903         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2904         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2905       enddo
2906 #ifdef PARMAT
2907       do i=ivec_start+2,ivec_end+2
2908 #else
2909       do i=3,nres+1
2910 #endif
2911
2912 !      print *,i,"i"
2913         if (i .lt. nres+1) then
2914           sin1=dsin(phi(i))
2915           cos1=dcos(phi(i))
2916           sintab(i-2)=sin1
2917           costab(i-2)=cos1
2918           obrot(1,i-2)=cos1
2919           obrot(2,i-2)=sin1
2920           sin2=dsin(2*phi(i))
2921           cos2=dcos(2*phi(i))
2922           sintab2(i-2)=sin2
2923           costab2(i-2)=cos2
2924           obrot2(1,i-2)=cos2
2925           obrot2(2,i-2)=sin2
2926           Ug(1,1,i-2)=-cos1
2927           Ug(1,2,i-2)=-sin1
2928           Ug(2,1,i-2)=-sin1
2929           Ug(2,2,i-2)= cos1
2930           Ug2(1,1,i-2)=-cos2
2931           Ug2(1,2,i-2)=-sin2
2932           Ug2(2,1,i-2)=-sin2
2933           Ug2(2,2,i-2)= cos2
2934         else
2935           costab(i-2)=1.0d0
2936           sintab(i-2)=0.0d0
2937           obrot(1,i-2)=1.0d0
2938           obrot(2,i-2)=0.0d0
2939           obrot2(1,i-2)=0.0d0
2940           obrot2(2,i-2)=0.0d0
2941           Ug(1,1,i-2)=1.0d0
2942           Ug(1,2,i-2)=0.0d0
2943           Ug(2,1,i-2)=0.0d0
2944           Ug(2,2,i-2)=1.0d0
2945           Ug2(1,1,i-2)=0.0d0
2946           Ug2(1,2,i-2)=0.0d0
2947           Ug2(2,1,i-2)=0.0d0
2948           Ug2(2,2,i-2)=0.0d0
2949         endif
2950         if (i .gt. 3 .and. i .lt. nres+1) then
2951           obrot_der(1,i-2)=-sin1
2952           obrot_der(2,i-2)= cos1
2953           Ugder(1,1,i-2)= sin1
2954           Ugder(1,2,i-2)=-cos1
2955           Ugder(2,1,i-2)=-cos1
2956           Ugder(2,2,i-2)=-sin1
2957           dwacos2=cos2+cos2
2958           dwasin2=sin2+sin2
2959           obrot2_der(1,i-2)=-dwasin2
2960           obrot2_der(2,i-2)= dwacos2
2961           Ug2der(1,1,i-2)= dwasin2
2962           Ug2der(1,2,i-2)=-dwacos2
2963           Ug2der(2,1,i-2)=-dwacos2
2964           Ug2der(2,2,i-2)=-dwasin2
2965         else
2966           obrot_der(1,i-2)=0.0d0
2967           obrot_der(2,i-2)=0.0d0
2968           Ugder(1,1,i-2)=0.0d0
2969           Ugder(1,2,i-2)=0.0d0
2970           Ugder(2,1,i-2)=0.0d0
2971           Ugder(2,2,i-2)=0.0d0
2972           obrot2_der(1,i-2)=0.0d0
2973           obrot2_der(2,i-2)=0.0d0
2974           Ug2der(1,1,i-2)=0.0d0
2975           Ug2der(1,2,i-2)=0.0d0
2976           Ug2der(2,1,i-2)=0.0d0
2977           Ug2der(2,2,i-2)=0.0d0
2978         endif
2979 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2980         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2981            if (itype(i-2,1).eq.0) then
2982           iti=ntortyp+1
2983            else
2984           iti = itype2loc(itype(i-2,1))
2985            endif
2986         else
2987           iti=nloctyp
2988         endif
2989 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2990         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2991            if (itype(i-1,1).eq.0) then
2992           iti1=nloctyp
2993            else
2994           iti1 = itype2loc(itype(i-1,1))
2995            endif
2996         else
2997           iti1=nloctyp
2998         endif
2999 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3000 !d        write (iout,*) '*******i',i,' iti1',iti
3001 !        write (iout,*) 'b1',b1(:,iti)
3002 !        write (iout,*) 'b2',b2(:,i-2)
3003 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3004 !        if (i .gt. iatel_s+2) then
3005         if (i .gt. nnt+2) then
3006           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3007 #ifdef NEWCORR
3008           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3009 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3010 #endif
3011
3012           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3013           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3014           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3015           then
3016           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3017           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3018           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3019           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3020           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3021           endif
3022         else
3023           do k=1,2
3024             Ub2(k,i-2)=0.0d0
3025             Ctobr(k,i-2)=0.0d0
3026             Dtobr2(k,i-2)=0.0d0
3027             do l=1,2
3028               EUg(l,k,i-2)=0.0d0
3029               CUg(l,k,i-2)=0.0d0
3030               DUg(l,k,i-2)=0.0d0
3031               DtUg2(l,k,i-2)=0.0d0
3032             enddo
3033           enddo
3034         endif
3035         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3036         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3037         do k=1,2
3038           muder(k,i-2)=Ub2der(k,i-2)
3039         enddo
3040 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3041         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3042           if (itype(i-1,1).eq.0) then
3043            iti1=nloctyp
3044           elseif (itype(i-1,1).le.ntyp) then
3045             iti1 = itype2loc(itype(i-1,1))
3046           else
3047             iti1=nloctyp
3048           endif
3049         else
3050           iti1=nloctyp
3051         endif
3052         do k=1,2
3053           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3054         enddo
3055         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3056         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3057         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3058 !d        write (iout,*) 'mu1',mu1(:,i-2)
3059 !d        write (iout,*) 'mu2',mu2(:,i-2)
3060         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3061         then
3062         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3063         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3064         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3065         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3066         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3067 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3068         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3069         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3070         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3071         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3072         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3073         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3074         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3075         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3076         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3077         endif
3078       enddo
3079 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3080 ! The order of matrices is from left to right.
3081       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3082       then
3083 !      do i=max0(ivec_start,2),ivec_end
3084       do i=2,nres-1
3085         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3086         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3087         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3088         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3089         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3090         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3091         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3092         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3093       enddo
3094       endif
3095 #if defined(MPI) && defined(PARMAT)
3096 #ifdef DEBUG
3097 !      if (fg_rank.eq.0) then
3098         write (iout,*) "Arrays UG and UGDER before GATHER"
3099         do i=1,nres-1
3100           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3101            ((ug(l,k,i),l=1,2),k=1,2),&
3102            ((ugder(l,k,i),l=1,2),k=1,2)
3103         enddo
3104         write (iout,*) "Arrays UG2 and UG2DER"
3105         do i=1,nres-1
3106           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3107            ((ug2(l,k,i),l=1,2),k=1,2),&
3108            ((ug2der(l,k,i),l=1,2),k=1,2)
3109         enddo
3110         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3111         do i=1,nres-1
3112           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3113            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3114            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3115         enddo
3116         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3117         do i=1,nres-1
3118           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3119            costab(i),sintab(i),costab2(i),sintab2(i)
3120         enddo
3121         write (iout,*) "Array MUDER"
3122         do i=1,nres-1
3123           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3124         enddo
3125 !      endif
3126 #endif
3127       if (nfgtasks.gt.1) then
3128         time00=MPI_Wtime()
3129 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3130 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3131 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3132 #ifdef MATGATHER
3133         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3134          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3135          FG_COMM1,IERR)
3136         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3137          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3138          FG_COMM1,IERR)
3139         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3140          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3141          FG_COMM1,IERR)
3142         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3143          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3144          FG_COMM1,IERR)
3145         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3146          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3147          FG_COMM1,IERR)
3148         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3149          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3150          FG_COMM1,IERR)
3151         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3152          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3153          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3154         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3155          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3156          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3157         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3158          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3159          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3160         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3161          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3162          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3163         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3164         then
3165         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3166          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3167          FG_COMM1,IERR)
3168         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3172          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3173          FG_COMM1,IERR)
3174        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3175          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3176          FG_COMM1,IERR)
3177         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3178          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3179          FG_COMM1,IERR)
3180         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3181          ivec_count(fg_rank1),&
3182          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3183          FG_COMM1,IERR)
3184         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3189          FG_COMM1,IERR)
3190         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3197          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3198          FG_COMM1,IERR)
3199         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3200          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3203          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3204          FG_COMM1,IERR)
3205         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3206          ivec_count(fg_rank1),&
3207          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3208          FG_COMM1,IERR)
3209         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3210          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3211          FG_COMM1,IERR)
3212        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3213          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3214          FG_COMM1,IERR)
3215         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3217          FG_COMM1,IERR)
3218        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3220          FG_COMM1,IERR)
3221         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3222          ivec_count(fg_rank1),&
3223          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3224          FG_COMM1,IERR)
3225         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3226          ivec_count(fg_rank1),&
3227          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3228          FG_COMM1,IERR)
3229         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3230          ivec_count(fg_rank1),&
3231          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3232          MPI_MAT2,FG_COMM1,IERR)
3233         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3234          ivec_count(fg_rank1),&
3235          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3236          MPI_MAT2,FG_COMM1,IERR)
3237         endif
3238 #else
3239 ! Passes matrix info through the ring
3240       isend=fg_rank1
3241       irecv=fg_rank1-1
3242       if (irecv.lt.0) irecv=nfgtasks1-1
3243       iprev=irecv
3244       inext=fg_rank1+1
3245       if (inext.ge.nfgtasks1) inext=0
3246       do i=1,nfgtasks1-1
3247 !        write (iout,*) "isend",isend," irecv",irecv
3248 !        call flush(iout)
3249         lensend=lentyp(isend)
3250         lenrecv=lentyp(irecv)
3251 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3252 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3253 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3254 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3255 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3256 !        write (iout,*) "Gather ROTAT1"
3257 !        call flush(iout)
3258 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3259 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3260 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3261 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3262 !        write (iout,*) "Gather ROTAT2"
3263 !        call flush(iout)
3264         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3265          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3266          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3267          iprev,4400+irecv,FG_COMM,status,IERR)
3268 !        write (iout,*) "Gather ROTAT_OLD"
3269 !        call flush(iout)
3270         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3271          MPI_PRECOMP11(lensend),inext,5500+isend,&
3272          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3273          iprev,5500+irecv,FG_COMM,status,IERR)
3274 !        write (iout,*) "Gather PRECOMP11"
3275 !        call flush(iout)
3276         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3277          MPI_PRECOMP12(lensend),inext,6600+isend,&
3278          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3279          iprev,6600+irecv,FG_COMM,status,IERR)
3280 !        write (iout,*) "Gather PRECOMP12"
3281 !        call flush(iout)
3282         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3283         then
3284         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3285          MPI_ROTAT2(lensend),inext,7700+isend,&
3286          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3287          iprev,7700+irecv,FG_COMM,status,IERR)
3288 !        write (iout,*) "Gather PRECOMP21"
3289 !        call flush(iout)
3290         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3291          MPI_PRECOMP22(lensend),inext,8800+isend,&
3292          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3293          iprev,8800+irecv,FG_COMM,status,IERR)
3294 !        write (iout,*) "Gather PRECOMP22"
3295 !        call flush(iout)
3296         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3297          MPI_PRECOMP23(lensend),inext,9900+isend,&
3298          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3299          MPI_PRECOMP23(lenrecv),&
3300          iprev,9900+irecv,FG_COMM,status,IERR)
3301 !        write (iout,*) "Gather PRECOMP23"
3302 !        call flush(iout)
3303         endif
3304         isend=irecv
3305         irecv=irecv-1
3306         if (irecv.lt.0) irecv=nfgtasks1-1
3307       enddo
3308 #endif
3309         time_gather=time_gather+MPI_Wtime()-time00
3310       endif
3311 #ifdef DEBUG
3312 !      if (fg_rank.eq.0) then
3313         write (iout,*) "Arrays UG and UGDER"
3314         do i=1,nres-1
3315           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3316            ((ug(l,k,i),l=1,2),k=1,2),&
3317            ((ugder(l,k,i),l=1,2),k=1,2)
3318         enddo
3319         write (iout,*) "Arrays UG2 and UG2DER"
3320         do i=1,nres-1
3321           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3322            ((ug2(l,k,i),l=1,2),k=1,2),&
3323            ((ug2der(l,k,i),l=1,2),k=1,2)
3324         enddo
3325         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3326         do i=1,nres-1
3327           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3328            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3329            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3330         enddo
3331         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3332         do i=1,nres-1
3333           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3334            costab(i),sintab(i),costab2(i),sintab2(i)
3335         enddo
3336         write (iout,*) "Array MUDER"
3337         do i=1,nres-1
3338           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3339         enddo
3340 !      endif
3341 #endif
3342 #endif
3343 !d      do i=1,nres
3344 !d        iti = itortyp(itype(i,1))
3345 !d        write (iout,*) i
3346 !d        do j=1,2
3347 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3348 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3349 !d        enddo
3350 !d      enddo
3351       return
3352       end subroutine set_matrices
3353 !-----------------------------------------------------------------------------
3354       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3355 !
3356 ! This subroutine calculates the average interaction energy and its gradient
3357 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3358 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3359 ! The potential depends both on the distance of peptide-group centers and on
3360 ! the orientation of the CA-CA virtual bonds.
3361 !
3362       use comm_locel
3363 !      implicit real*8 (a-h,o-z)
3364 #ifdef MPI
3365       include 'mpif.h'
3366 #endif
3367 !      include 'DIMENSIONS'
3368 !      include 'COMMON.CONTROL'
3369 !      include 'COMMON.SETUP'
3370 !      include 'COMMON.IOUNITS'
3371 !      include 'COMMON.GEO'
3372 !      include 'COMMON.VAR'
3373 !      include 'COMMON.LOCAL'
3374 !      include 'COMMON.CHAIN'
3375 !      include 'COMMON.DERIV'
3376 !      include 'COMMON.INTERACT'
3377 !      include 'COMMON.CONTACTS'
3378 !      include 'COMMON.TORSION'
3379 !      include 'COMMON.VECTORS'
3380 !      include 'COMMON.FFIELD'
3381 !      include 'COMMON.TIME1'
3382       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3383       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3384       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3385 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3386       real(kind=8),dimension(4) :: muij
3387 !el      integer :: num_conti,j1,j2
3388 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3389 !el        dz_normi,xmedi,ymedi,zmedi
3390
3391 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3392 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3393 !el          num_conti,j1,j2
3394
3395 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3396 #ifdef MOMENT
3397       real(kind=8) :: scal_el=1.0d0
3398 #else
3399       real(kind=8) :: scal_el=0.5d0
3400 #endif
3401 ! 12/13/98
3402 ! 13-go grudnia roku pamietnego...
3403       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3404                                              0.0d0,1.0d0,0.0d0,&
3405                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3406 !el local variables
3407       integer :: i,k,j
3408       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3409       real(kind=8) :: fac,t_eelecij,fracinbuf
3410
3411
3412 !d      write(iout,*) 'In EELEC'
3413 !        print *,"IN EELEC"
3414 !d      do i=1,nloctyp
3415 !d        write(iout,*) 'Type',i
3416 !d        write(iout,*) 'B1',B1(:,i)
3417 !d        write(iout,*) 'B2',B2(:,i)
3418 !d        write(iout,*) 'CC',CC(:,:,i)
3419 !d        write(iout,*) 'DD',DD(:,:,i)
3420 !d        write(iout,*) 'EE',EE(:,:,i)
3421 !d      enddo
3422 !d      call check_vecgrad
3423 !d      stop
3424 !      ees=0.0d0  !AS
3425 !      evdw1=0.0d0
3426 !      eel_loc=0.0d0
3427 !      eello_turn3=0.0d0
3428 !      eello_turn4=0.0d0
3429       t_eelecij=0.0d0
3430       ees=0.0D0
3431       evdw1=0.0D0
3432       eel_loc=0.0d0
3433       eello_turn3=0.0d0
3434       eello_turn4=0.0d0
3435 !
3436
3437       if (icheckgrad.eq.1) then
3438 !el
3439 !        do i=0,2*nres+2
3440 !          dc_norm(1,i)=0.0d0
3441 !          dc_norm(2,i)=0.0d0
3442 !          dc_norm(3,i)=0.0d0
3443 !        enddo
3444         do i=1,nres-1
3445           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3446           do k=1,3
3447             dc_norm(k,i)=dc(k,i)*fac
3448           enddo
3449 !          write (iout,*) 'i',i,' fac',fac
3450         enddo
3451       endif
3452 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3453 !        wturn6
3454       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3455           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3456           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3457 !        call vec_and_deriv
3458 #ifdef TIMING
3459         time01=MPI_Wtime()
3460 #endif
3461 !        print *, "before set matrices"
3462         call set_matrices
3463 !        print *, "after set matrices"
3464
3465 #ifdef TIMING
3466         time_mat=time_mat+MPI_Wtime()-time01
3467 #endif
3468       endif
3469 !       print *, "after set matrices"
3470 !d      do i=1,nres-1
3471 !d        write (iout,*) 'i=',i
3472 !d        do k=1,3
3473 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3474 !d        enddo
3475 !d        do k=1,3
3476 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3477 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3478 !d        enddo
3479 !d      enddo
3480       t_eelecij=0.0d0
3481       ees=0.0D0
3482       evdw1=0.0D0
3483       eel_loc=0.0d0
3484       eello_turn3=0.0d0
3485       eello_turn4=0.0d0
3486 !el      ind=0
3487       do i=1,nres
3488         num_cont_hb(i)=0
3489       enddo
3490 !d      print '(a)','Enter EELEC'
3491 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3492 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3493 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3494       do i=1,nres
3495         gel_loc_loc(i)=0.0d0
3496         gcorr_loc(i)=0.0d0
3497       enddo
3498 !
3499 !
3500 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3501 !
3502 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3503 !
3504
3505
3506 !        print *,"before iturn3 loop"
3507       do i=iturn3_start,iturn3_end
3508         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3509         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3510         dxi=dc(1,i)
3511         dyi=dc(2,i)
3512         dzi=dc(3,i)
3513         dx_normi=dc_norm(1,i)
3514         dy_normi=dc_norm(2,i)
3515         dz_normi=dc_norm(3,i)
3516         xmedi=c(1,i)+0.5d0*dxi
3517         ymedi=c(2,i)+0.5d0*dyi
3518         zmedi=c(3,i)+0.5d0*dzi
3519           xmedi=dmod(xmedi,boxxsize)
3520           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3521           ymedi=dmod(ymedi,boxysize)
3522           if (ymedi.lt.0) ymedi=ymedi+boxysize
3523           zmedi=dmod(zmedi,boxzsize)
3524           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3525         num_conti=0
3526        if ((zmedi.gt.bordlipbot) &
3527         .and.(zmedi.lt.bordliptop)) then
3528 !C the energy transfer exist
3529         if (zmedi.lt.buflipbot) then
3530 !C what fraction I am in
3531          fracinbuf=1.0d0- &
3532                ((zmedi-bordlipbot)/lipbufthick)
3533 !C lipbufthick is thickenes of lipid buffore
3534          sslipi=sscalelip(fracinbuf)
3535          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3536         elseif (zmedi.gt.bufliptop) then
3537          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3538          sslipi=sscalelip(fracinbuf)
3539          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3540         else
3541          sslipi=1.0d0
3542          ssgradlipi=0.0
3543         endif
3544        else
3545          sslipi=0.0d0
3546          ssgradlipi=0.0
3547        endif
3548 !       print *,i,sslipi,ssgradlipi
3549        call eelecij(i,i+2,ees,evdw1,eel_loc)
3550         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3551         num_cont_hb(i)=num_conti
3552       enddo
3553       do i=iturn4_start,iturn4_end
3554         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3555           .or. itype(i+3,1).eq.ntyp1 &
3556           .or. itype(i+4,1).eq.ntyp1) cycle
3557 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3558         dxi=dc(1,i)
3559         dyi=dc(2,i)
3560         dzi=dc(3,i)
3561         dx_normi=dc_norm(1,i)
3562         dy_normi=dc_norm(2,i)
3563         dz_normi=dc_norm(3,i)
3564         xmedi=c(1,i)+0.5d0*dxi
3565         ymedi=c(2,i)+0.5d0*dyi
3566         zmedi=c(3,i)+0.5d0*dzi
3567           xmedi=dmod(xmedi,boxxsize)
3568           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3569           ymedi=dmod(ymedi,boxysize)
3570           if (ymedi.lt.0) ymedi=ymedi+boxysize
3571           zmedi=dmod(zmedi,boxzsize)
3572           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3573        if ((zmedi.gt.bordlipbot)  &
3574        .and.(zmedi.lt.bordliptop)) then
3575 !C the energy transfer exist
3576         if (zmedi.lt.buflipbot) then
3577 !C what fraction I am in
3578          fracinbuf=1.0d0- &
3579              ((zmedi-bordlipbot)/lipbufthick)
3580 !C lipbufthick is thickenes of lipid buffore
3581          sslipi=sscalelip(fracinbuf)
3582          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3583         elseif (zmedi.gt.bufliptop) then
3584          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3585          sslipi=sscalelip(fracinbuf)
3586          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3587         else
3588          sslipi=1.0d0
3589          ssgradlipi=0.0
3590         endif
3591        else
3592          sslipi=0.0d0
3593          ssgradlipi=0.0
3594        endif
3595
3596         num_conti=num_cont_hb(i)
3597         call eelecij(i,i+3,ees,evdw1,eel_loc)
3598         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3599          call eturn4(i,eello_turn4)
3600 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3601         num_cont_hb(i)=num_conti
3602       enddo   ! i
3603 !
3604 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3605 !
3606 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3607       do i=iatel_s,iatel_e
3608         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3609         dxi=dc(1,i)
3610         dyi=dc(2,i)
3611         dzi=dc(3,i)
3612         dx_normi=dc_norm(1,i)
3613         dy_normi=dc_norm(2,i)
3614         dz_normi=dc_norm(3,i)
3615         xmedi=c(1,i)+0.5d0*dxi
3616         ymedi=c(2,i)+0.5d0*dyi
3617         zmedi=c(3,i)+0.5d0*dzi
3618           xmedi=dmod(xmedi,boxxsize)
3619           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3620           ymedi=dmod(ymedi,boxysize)
3621           if (ymedi.lt.0) ymedi=ymedi+boxysize
3622           zmedi=dmod(zmedi,boxzsize)
3623           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3624        if ((zmedi.gt.bordlipbot)  &
3625         .and.(zmedi.lt.bordliptop)) then
3626 !C the energy transfer exist
3627         if (zmedi.lt.buflipbot) then
3628 !C what fraction I am in
3629          fracinbuf=1.0d0- &
3630              ((zmedi-bordlipbot)/lipbufthick)
3631 !C lipbufthick is thickenes of lipid buffore
3632          sslipi=sscalelip(fracinbuf)
3633          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3634         elseif (zmedi.gt.bufliptop) then
3635          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3636          sslipi=sscalelip(fracinbuf)
3637          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3638         else
3639          sslipi=1.0d0
3640          ssgradlipi=0.0
3641         endif
3642        else
3643          sslipi=0.0d0
3644          ssgradlipi=0.0
3645        endif
3646
3647 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3648         num_conti=num_cont_hb(i)
3649         do j=ielstart(i),ielend(i)
3650 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3651           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3652           call eelecij(i,j,ees,evdw1,eel_loc)
3653         enddo ! j
3654         num_cont_hb(i)=num_conti
3655       enddo   ! i
3656 !      write (iout,*) "Number of loop steps in EELEC:",ind
3657 !d      do i=1,nres
3658 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3659 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3660 !d      enddo
3661 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3662 !cc      eel_loc=eel_loc+eello_turn3
3663 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3664       return
3665       end subroutine eelec
3666 !-----------------------------------------------------------------------------
3667       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3668
3669       use comm_locel
3670 !      implicit real*8 (a-h,o-z)
3671 !      include 'DIMENSIONS'
3672 #ifdef MPI
3673       include "mpif.h"
3674 #endif
3675 !      include 'COMMON.CONTROL'
3676 !      include 'COMMON.IOUNITS'
3677 !      include 'COMMON.GEO'
3678 !      include 'COMMON.VAR'
3679 !      include 'COMMON.LOCAL'
3680 !      include 'COMMON.CHAIN'
3681 !      include 'COMMON.DERIV'
3682 !      include 'COMMON.INTERACT'
3683 !      include 'COMMON.CONTACTS'
3684 !      include 'COMMON.TORSION'
3685 !      include 'COMMON.VECTORS'
3686 !      include 'COMMON.FFIELD'
3687 !      include 'COMMON.TIME1'
3688       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3689       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3690       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3691 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3692       real(kind=8),dimension(4) :: muij
3693       real(kind=8) :: geel_loc_ij,geel_loc_ji
3694       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3695                     dist_temp, dist_init,rlocshield,fracinbuf
3696       integer xshift,yshift,zshift,ilist,iresshield
3697 !el      integer :: num_conti,j1,j2
3698 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3699 !el        dz_normi,xmedi,ymedi,zmedi
3700
3701 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3702 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3703 !el          num_conti,j1,j2
3704
3705 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3706 #ifdef MOMENT
3707       real(kind=8) :: scal_el=1.0d0
3708 #else
3709       real(kind=8) :: scal_el=0.5d0
3710 #endif
3711 ! 12/13/98
3712 ! 13-go grudnia roku pamietnego...
3713       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3714                                              0.0d0,1.0d0,0.0d0,&
3715                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3716 !      integer :: maxconts=nres/4
3717 !el local variables
3718       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3719       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3720       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3721       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3722                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3723                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3724                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3725                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3726                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3727                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3728                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3729 !      maxconts=nres/4
3730 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3731 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3732
3733 !          time00=MPI_Wtime()
3734 !d      write (iout,*) "eelecij",i,j
3735 !          ind=ind+1
3736           iteli=itel(i)
3737           itelj=itel(j)
3738           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3739           aaa=app(iteli,itelj)
3740           bbb=bpp(iteli,itelj)
3741           ael6i=ael6(iteli,itelj)
3742           ael3i=ael3(iteli,itelj)
3743           dxj=dc(1,j)
3744           dyj=dc(2,j)
3745           dzj=dc(3,j)
3746           dx_normj=dc_norm(1,j)
3747           dy_normj=dc_norm(2,j)
3748           dz_normj=dc_norm(3,j)
3749 !          xj=c(1,j)+0.5D0*dxj-xmedi
3750 !          yj=c(2,j)+0.5D0*dyj-ymedi
3751 !          zj=c(3,j)+0.5D0*dzj-zmedi
3752           xj=c(1,j)+0.5D0*dxj
3753           yj=c(2,j)+0.5D0*dyj
3754           zj=c(3,j)+0.5D0*dzj
3755           xj=mod(xj,boxxsize)
3756           if (xj.lt.0) xj=xj+boxxsize
3757           yj=mod(yj,boxysize)
3758           if (yj.lt.0) yj=yj+boxysize
3759           zj=mod(zj,boxzsize)
3760           if (zj.lt.0) zj=zj+boxzsize
3761        if ((zj.gt.bordlipbot)  &
3762        .and.(zj.lt.bordliptop)) then
3763 !C the energy transfer exist
3764         if (zj.lt.buflipbot) then
3765 !C what fraction I am in
3766          fracinbuf=1.0d0-     &
3767              ((zj-bordlipbot)/lipbufthick)
3768 !C lipbufthick is thickenes of lipid buffore
3769          sslipj=sscalelip(fracinbuf)
3770          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3771         elseif (zj.gt.bufliptop) then
3772          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3773          sslipj=sscalelip(fracinbuf)
3774          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3775         else
3776          sslipj=1.0d0
3777          ssgradlipj=0.0
3778         endif
3779        else
3780          sslipj=0.0d0
3781          ssgradlipj=0.0
3782        endif
3783
3784       isubchap=0
3785       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3786       xj_safe=xj
3787       yj_safe=yj
3788       zj_safe=zj
3789       do xshift=-1,1
3790       do yshift=-1,1
3791       do zshift=-1,1
3792           xj=xj_safe+xshift*boxxsize
3793           yj=yj_safe+yshift*boxysize
3794           zj=zj_safe+zshift*boxzsize
3795           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3796           if(dist_temp.lt.dist_init) then
3797             dist_init=dist_temp
3798             xj_temp=xj
3799             yj_temp=yj
3800             zj_temp=zj
3801             isubchap=1
3802           endif
3803        enddo
3804        enddo
3805        enddo
3806        if (isubchap.eq.1) then
3807 !C          print *,i,j
3808           xj=xj_temp-xmedi
3809           yj=yj_temp-ymedi
3810           zj=zj_temp-zmedi
3811        else
3812           xj=xj_safe-xmedi
3813           yj=yj_safe-ymedi
3814           zj=zj_safe-zmedi
3815        endif
3816
3817           rij=xj*xj+yj*yj+zj*zj
3818           rrmij=1.0D0/rij
3819           rij=dsqrt(rij)
3820 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3821             sss_ele_cut=sscale_ele(rij)
3822             sss_ele_grad=sscagrad_ele(rij)
3823 !             sss_ele_cut=1.0d0
3824 !             sss_ele_grad=0.0d0
3825 !            print *,sss_ele_cut,sss_ele_grad,&
3826 !            (rij),r_cut_ele,rlamb_ele
3827 !            if (sss_ele_cut.le.0.0) go to 128
3828
3829           rmij=1.0D0/rij
3830           r3ij=rrmij*rmij
3831           r6ij=r3ij*r3ij
3832           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3833           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3834           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3835           fac=cosa-3.0D0*cosb*cosg
3836           ev1=aaa*r6ij*r6ij
3837 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3838           if (j.eq.i+2) ev1=scal_el*ev1
3839           ev2=bbb*r6ij
3840           fac3=ael6i*r6ij
3841           fac4=ael3i*r3ij
3842           evdwij=ev1+ev2
3843           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3844           el2=fac4*fac
3845 !          eesij=el1+el2
3846           if (shield_mode.gt.0) then
3847 !C          fac_shield(i)=0.4
3848 !C          fac_shield(j)=0.6
3849           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3850           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3851           eesij=(el1+el2)
3852           ees=ees+eesij*sss_ele_cut
3853 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3854 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3855           else
3856           fac_shield(i)=1.0
3857           fac_shield(j)=1.0
3858           eesij=(el1+el2)
3859           ees=ees+eesij   &
3860             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3861 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3862           endif
3863
3864 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3865           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3866 !          ees=ees+eesij*sss_ele_cut
3867           evdw1=evdw1+evdwij*sss_ele_cut  &
3868            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3869 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3870 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3871 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3872 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3873
3874           if (energy_dec) then
3875 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3876 !                  'evdw1',i,j,evdwij,&
3877 !                  iteli,itelj,aaa,evdw1
3878               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3879               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3880           endif
3881 !
3882 ! Calculate contributions to the Cartesian gradient.
3883 !
3884 #ifdef SPLITELE
3885           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3886               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3887           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3888              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3889           fac1=fac
3890           erij(1)=xj*rmij
3891           erij(2)=yj*rmij
3892           erij(3)=zj*rmij
3893 !
3894 ! Radial derivatives. First process both termini of the fragment (i,j)
3895 !
3896           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3897           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3898           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3899            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3900           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3901             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3902
3903           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3904           (shield_mode.gt.0)) then
3905 !C          print *,i,j
3906           do ilist=1,ishield_list(i)
3907            iresshield=shield_list(ilist,i)
3908            do k=1,3
3909            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3910            *2.0*sss_ele_cut
3911            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3912                    rlocshield &
3913             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3914             *sss_ele_cut
3915             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3916            enddo
3917           enddo
3918           do ilist=1,ishield_list(j)
3919            iresshield=shield_list(ilist,j)
3920            do k=1,3
3921            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3922           *2.0*sss_ele_cut
3923            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3924                    rlocshield &
3925            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3926            *sss_ele_cut
3927            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3928            enddo
3929           enddo
3930           do k=1,3
3931             gshieldc(k,i)=gshieldc(k,i)+ &
3932                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3933            *sss_ele_cut
3934
3935             gshieldc(k,j)=gshieldc(k,j)+ &
3936                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3937            *sss_ele_cut
3938
3939             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3940                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3941            *sss_ele_cut
3942
3943             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3944                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3945            *sss_ele_cut
3946
3947            enddo
3948            endif
3949
3950
3951 !          do k=1,3
3952 !            ghalf=0.5D0*ggg(k)
3953 !            gelc(k,i)=gelc(k,i)+ghalf
3954 !            gelc(k,j)=gelc(k,j)+ghalf
3955 !          enddo
3956 ! 9/28/08 AL Gradient compotents will be summed only at the end
3957           do k=1,3
3958             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3959             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3960           enddo
3961             gelc_long(3,j)=gelc_long(3,j)+  &
3962           ssgradlipj*eesij/2.0d0*lipscale**2&
3963            *sss_ele_cut
3964
3965             gelc_long(3,i)=gelc_long(3,i)+  &
3966           ssgradlipi*eesij/2.0d0*lipscale**2&
3967            *sss_ele_cut
3968
3969
3970 !
3971 ! Loop over residues i+1 thru j-1.
3972 !
3973 !grad          do k=i+1,j-1
3974 !grad            do l=1,3
3975 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3976 !grad            enddo
3977 !grad          enddo
3978           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3979            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3980           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3981            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3982           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3983            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3984
3985 !          do k=1,3
3986 !            ghalf=0.5D0*ggg(k)
3987 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3988 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3989 !          enddo
3990 ! 9/28/08 AL Gradient compotents will be summed only at the end
3991           do k=1,3
3992             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3993             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3994           enddo
3995
3996 !C Lipidic part for scaling weight
3997            gvdwpp(3,j)=gvdwpp(3,j)+ &
3998           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3999            gvdwpp(3,i)=gvdwpp(3,i)+ &
4000           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4001 !! Loop over residues i+1 thru j-1.
4002 !
4003 !grad          do k=i+1,j-1
4004 !grad            do l=1,3
4005 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4006 !grad            enddo
4007 !grad          enddo
4008 #else
4009           facvdw=(ev1+evdwij)*sss_ele_cut &
4010            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4011
4012           facel=(el1+eesij)*sss_ele_cut
4013           fac1=fac
4014           fac=-3*rrmij*(facvdw+facvdw+facel)
4015           erij(1)=xj*rmij
4016           erij(2)=yj*rmij
4017           erij(3)=zj*rmij
4018 !
4019 ! Radial derivatives. First process both termini of the fragment (i,j)
4020 !
4021           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4022           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4023           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4024 !          do k=1,3
4025 !            ghalf=0.5D0*ggg(k)
4026 !            gelc(k,i)=gelc(k,i)+ghalf
4027 !            gelc(k,j)=gelc(k,j)+ghalf
4028 !          enddo
4029 ! 9/28/08 AL Gradient compotents will be summed only at the end
4030           do k=1,3
4031             gelc_long(k,j)=gelc(k,j)+ggg(k)
4032             gelc_long(k,i)=gelc(k,i)-ggg(k)
4033           enddo
4034 !
4035 ! Loop over residues i+1 thru j-1.
4036 !
4037 !grad          do k=i+1,j-1
4038 !grad            do l=1,3
4039 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4040 !grad            enddo
4041 !grad          enddo
4042 ! 9/28/08 AL Gradient compotents will be summed only at the end
4043           ggg(1)=facvdw*xj &
4044            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4045           ggg(2)=facvdw*yj &
4046            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4047           ggg(3)=facvdw*zj &
4048            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4049
4050           do k=1,3
4051             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4052             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4053           enddo
4054            gvdwpp(3,j)=gvdwpp(3,j)+ &
4055           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4056            gvdwpp(3,i)=gvdwpp(3,i)+ &
4057           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4058
4059 #endif
4060 !
4061 ! Angular part
4062 !
4063           ecosa=2.0D0*fac3*fac1+fac4
4064           fac4=-3.0D0*fac4
4065           fac3=-6.0D0*fac3
4066           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4067           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4068           do k=1,3
4069             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4070             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4071           enddo
4072 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4073 !d   &          (dcosg(k),k=1,3)
4074           do k=1,3
4075             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4076              *fac_shield(i)**2*fac_shield(j)**2 &
4077              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4078
4079           enddo
4080 !          do k=1,3
4081 !            ghalf=0.5D0*ggg(k)
4082 !            gelc(k,i)=gelc(k,i)+ghalf
4083 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4084 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4085 !            gelc(k,j)=gelc(k,j)+ghalf
4086 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4087 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4088 !          enddo
4089 !grad          do k=i+1,j-1
4090 !grad            do l=1,3
4091 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4092 !grad            enddo
4093 !grad          enddo
4094           do k=1,3
4095             gelc(k,i)=gelc(k,i) &
4096                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4097                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4098                      *sss_ele_cut &
4099                      *fac_shield(i)**2*fac_shield(j)**2 &
4100                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4101
4102             gelc(k,j)=gelc(k,j) &
4103                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4104                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4105                      *sss_ele_cut  &
4106                      *fac_shield(i)**2*fac_shield(j)**2  &
4107                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4108
4109             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4110             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4111           enddo
4112
4113           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4114               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4115               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4116 !
4117 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4118 !   energy of a peptide unit is assumed in the form of a second-order
4119 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4120 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4121 !   are computed for EVERY pair of non-contiguous peptide groups.
4122 !
4123           if (j.lt.nres-1) then
4124             j1=j+1
4125             j2=j-1
4126           else
4127             j1=j-1
4128             j2=j-2
4129           endif
4130           kkk=0
4131           do k=1,2
4132             do l=1,2
4133               kkk=kkk+1
4134               muij(kkk)=mu(k,i)*mu(l,j)
4135 #ifdef NEWCORR
4136              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4137 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4138              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4139              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4140 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4141              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4142 #endif
4143
4144             enddo
4145           enddo
4146 !d         write (iout,*) 'EELEC: i',i,' j',j
4147 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4148 !d          write(iout,*) 'muij',muij
4149           ury=scalar(uy(1,i),erij)
4150           urz=scalar(uz(1,i),erij)
4151           vry=scalar(uy(1,j),erij)
4152           vrz=scalar(uz(1,j),erij)
4153           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4154           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4155           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4156           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4157           fac=dsqrt(-ael6i)*r3ij
4158           a22=a22*fac
4159           a23=a23*fac
4160           a32=a32*fac
4161           a33=a33*fac
4162 !d          write (iout,'(4i5,4f10.5)')
4163 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4164 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4165 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4166 !d     &      uy(:,j),uz(:,j)
4167 !d          write (iout,'(4f10.5)')
4168 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4169 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4170 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4171 !d           write (iout,'(9f10.5/)')
4172 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4173 ! Derivatives of the elements of A in virtual-bond vectors
4174           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4175           do k=1,3
4176             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4177             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4178             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4179             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4180             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4181             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4182             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4183             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4184             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4185             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4186             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4187             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4188           enddo
4189 ! Compute radial contributions to the gradient
4190           facr=-3.0d0*rrmij
4191           a22der=a22*facr
4192           a23der=a23*facr
4193           a32der=a32*facr
4194           a33der=a33*facr
4195           agg(1,1)=a22der*xj
4196           agg(2,1)=a22der*yj
4197           agg(3,1)=a22der*zj
4198           agg(1,2)=a23der*xj
4199           agg(2,2)=a23der*yj
4200           agg(3,2)=a23der*zj
4201           agg(1,3)=a32der*xj
4202           agg(2,3)=a32der*yj
4203           agg(3,3)=a32der*zj
4204           agg(1,4)=a33der*xj
4205           agg(2,4)=a33der*yj
4206           agg(3,4)=a33der*zj
4207 ! Add the contributions coming from er
4208           fac3=-3.0d0*fac
4209           do k=1,3
4210             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4211             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4212             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4213             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4214           enddo
4215           do k=1,3
4216 ! Derivatives in DC(i)
4217 !grad            ghalf1=0.5d0*agg(k,1)
4218 !grad            ghalf2=0.5d0*agg(k,2)
4219 !grad            ghalf3=0.5d0*agg(k,3)
4220 !grad            ghalf4=0.5d0*agg(k,4)
4221             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4222             -3.0d0*uryg(k,2)*vry)!+ghalf1
4223             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4224             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4225             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4226             -3.0d0*urzg(k,2)*vry)!+ghalf3
4227             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4228             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4229 ! Derivatives in DC(i+1)
4230             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4231             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4232             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4233             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4234             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4235             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4236             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4237             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4238 ! Derivatives in DC(j)
4239             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4240             -3.0d0*vryg(k,2)*ury)!+ghalf1
4241             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4242             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4243             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4244             -3.0d0*vryg(k,2)*urz)!+ghalf3
4245             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4246             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4247 ! Derivatives in DC(j+1) or DC(nres-1)
4248             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4249             -3.0d0*vryg(k,3)*ury)
4250             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4251             -3.0d0*vrzg(k,3)*ury)
4252             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4253             -3.0d0*vryg(k,3)*urz)
4254             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4255             -3.0d0*vrzg(k,3)*urz)
4256 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4257 !grad              do l=1,4
4258 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4259 !grad              enddo
4260 !grad            endif
4261           enddo
4262           acipa(1,1)=a22
4263           acipa(1,2)=a23
4264           acipa(2,1)=a32
4265           acipa(2,2)=a33
4266           a22=-a22
4267           a23=-a23
4268           do l=1,2
4269             do k=1,3
4270               agg(k,l)=-agg(k,l)
4271               aggi(k,l)=-aggi(k,l)
4272               aggi1(k,l)=-aggi1(k,l)
4273               aggj(k,l)=-aggj(k,l)
4274               aggj1(k,l)=-aggj1(k,l)
4275             enddo
4276           enddo
4277           if (j.lt.nres-1) then
4278             a22=-a22
4279             a32=-a32
4280             do l=1,3,2
4281               do k=1,3
4282                 agg(k,l)=-agg(k,l)
4283                 aggi(k,l)=-aggi(k,l)
4284                 aggi1(k,l)=-aggi1(k,l)
4285                 aggj(k,l)=-aggj(k,l)
4286                 aggj1(k,l)=-aggj1(k,l)
4287               enddo
4288             enddo
4289           else
4290             a22=-a22
4291             a23=-a23
4292             a32=-a32
4293             a33=-a33
4294             do l=1,4
4295               do k=1,3
4296                 agg(k,l)=-agg(k,l)
4297                 aggi(k,l)=-aggi(k,l)
4298                 aggi1(k,l)=-aggi1(k,l)
4299                 aggj(k,l)=-aggj(k,l)
4300                 aggj1(k,l)=-aggj1(k,l)
4301               enddo
4302             enddo
4303           endif
4304           ENDIF ! WCORR
4305           IF (wel_loc.gt.0.0d0) THEN
4306 ! Contribution to the local-electrostatic energy coming from the i-j pair
4307           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4308            +a33*muij(4)
4309           if (shield_mode.eq.0) then
4310            fac_shield(i)=1.0
4311            fac_shield(j)=1.0
4312           endif
4313           eel_loc_ij=eel_loc_ij &
4314          *fac_shield(i)*fac_shield(j) &
4315          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4316 !C Now derivative over eel_loc
4317           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4318          (shield_mode.gt.0)) then
4319 !C          print *,i,j
4320
4321           do ilist=1,ishield_list(i)
4322            iresshield=shield_list(ilist,i)
4323            do k=1,3
4324            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4325                                                 /fac_shield(i)&
4326            *sss_ele_cut
4327            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4328                    rlocshield  &
4329           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4330           *sss_ele_cut
4331
4332             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4333            +rlocshield
4334            enddo
4335           enddo
4336           do ilist=1,ishield_list(j)
4337            iresshield=shield_list(ilist,j)
4338            do k=1,3
4339            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4340                                             /fac_shield(j)   &
4341             *sss_ele_cut
4342            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4343                    rlocshield  &
4344       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4345        *sss_ele_cut
4346
4347            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4348                   +rlocshield
4349
4350            enddo
4351           enddo
4352
4353           do k=1,3
4354             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4355                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4356                     *sss_ele_cut
4357             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4358                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4359                     *sss_ele_cut
4360             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4361                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4362                     *sss_ele_cut
4363             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4364                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4365                     *sss_ele_cut
4366
4367            enddo
4368            endif
4369
4370 #ifdef NEWCORR
4371          geel_loc_ij=(a22*gmuij1(1)&
4372           +a23*gmuij1(2)&
4373           +a32*gmuij1(3)&
4374           +a33*gmuij1(4))&
4375          *fac_shield(i)*fac_shield(j)&
4376                     *sss_ele_cut
4377
4378 !c         write(iout,*) "derivative over thatai"
4379 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4380 !c     &   a33*gmuij1(4)
4381          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4382            geel_loc_ij*wel_loc
4383 !c         write(iout,*) "derivative over thatai-1"
4384 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4385 !c     &   a33*gmuij2(4)
4386          geel_loc_ij=&
4387           a22*gmuij2(1)&
4388           +a23*gmuij2(2)&
4389           +a32*gmuij2(3)&
4390           +a33*gmuij2(4)
4391          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4392            geel_loc_ij*wel_loc&
4393          *fac_shield(i)*fac_shield(j)&
4394                     *sss_ele_cut
4395
4396
4397 !c  Derivative over j residue
4398          geel_loc_ji=a22*gmuji1(1)&
4399           +a23*gmuji1(2)&
4400           +a32*gmuji1(3)&
4401           +a33*gmuji1(4)
4402 !c         write(iout,*) "derivative over thataj"
4403 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4404 !c     &   a33*gmuji1(4)
4405
4406         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4407            geel_loc_ji*wel_loc&
4408          *fac_shield(i)*fac_shield(j)&
4409                     *sss_ele_cut
4410
4411
4412          geel_loc_ji=&
4413           +a22*gmuji2(1)&
4414           +a23*gmuji2(2)&
4415           +a32*gmuji2(3)&
4416           +a33*gmuji2(4)
4417 !c         write(iout,*) "derivative over thataj-1"
4418 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4419 !c     &   a33*gmuji2(4)
4420          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4421            geel_loc_ji*wel_loc&
4422          *fac_shield(i)*fac_shield(j)&
4423                     *sss_ele_cut
4424 #endif
4425
4426 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4427 !           eel_loc_ij=0.0
4428 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4429 !                  'eelloc',i,j,eel_loc_ij
4430           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4431                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4432 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4433
4434 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4435 !          if (energy_dec) write (iout,*) "muij",muij
4436 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4437
4438           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4439 ! Partial derivatives in virtual-bond dihedral angles gamma
4440           if (i.gt.1) &
4441           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4442                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4443                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4444                  *sss_ele_cut  &
4445           *fac_shield(i)*fac_shield(j) &
4446           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4447
4448           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4449                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4450                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4451                  *sss_ele_cut &
4452           *fac_shield(i)*fac_shield(j) &
4453           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4454 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4455 !          do l=1,3
4456 !            ggg(1)=(agg(1,1)*muij(1)+ &
4457 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4458 !            *sss_ele_cut &
4459 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4460 !            ggg(2)=(agg(2,1)*muij(1)+ &
4461 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4462 !            *sss_ele_cut &
4463 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4464 !            ggg(3)=(agg(3,1)*muij(1)+ &
4465 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4466 !            *sss_ele_cut &
4467 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4468            xtemp(1)=xj
4469            xtemp(2)=yj
4470            xtemp(3)=zj
4471
4472            do l=1,3
4473             ggg(l)=(agg(l,1)*muij(1)+ &
4474                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4475             *sss_ele_cut &
4476           *fac_shield(i)*fac_shield(j) &
4477           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4478              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4479
4480
4481             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4482             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4483 !grad            ghalf=0.5d0*ggg(l)
4484 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4485 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4486           enddo
4487             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4488           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4489           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4490
4491             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4492           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4493           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4494
4495 !grad          do k=i+1,j2
4496 !grad            do l=1,3
4497 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4498 !grad            enddo
4499 !grad          enddo
4500 ! Remaining derivatives of eello
4501           do l=1,3
4502             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4503                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4504             *sss_ele_cut &
4505           *fac_shield(i)*fac_shield(j) &
4506           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4507
4508 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4509             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4510                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4511             +aggi1(l,4)*muij(4))&
4512             *sss_ele_cut &
4513           *fac_shield(i)*fac_shield(j) &
4514           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4515
4516 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4517             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4518                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4519             *sss_ele_cut &
4520           *fac_shield(i)*fac_shield(j) &
4521           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4522
4523 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4524             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4525                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4526             +aggj1(l,4)*muij(4))&
4527             *sss_ele_cut &
4528           *fac_shield(i)*fac_shield(j) &
4529          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4530
4531 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4532           enddo
4533           ENDIF
4534 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4535 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4536           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4537              .and. num_conti.le.maxconts) then
4538 !            write (iout,*) i,j," entered corr"
4539 !
4540 ! Calculate the contact function. The ith column of the array JCONT will
4541 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4542 ! greater than I). The arrays FACONT and GACONT will contain the values of
4543 ! the contact function and its derivative.
4544 !           r0ij=1.02D0*rpp(iteli,itelj)
4545 !           r0ij=1.11D0*rpp(iteli,itelj)
4546             r0ij=2.20D0*rpp(iteli,itelj)
4547 !           r0ij=1.55D0*rpp(iteli,itelj)
4548             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4549 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4550             if (fcont.gt.0.0D0) then
4551               num_conti=num_conti+1
4552               if (num_conti.gt.maxconts) then
4553 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4554 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4555                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4556                                ' will skip next contacts for this conf.', num_conti
4557               else
4558                 jcont_hb(num_conti,i)=j
4559 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4560 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4561                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4562                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4563 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4564 !  terms.
4565                 d_cont(num_conti,i)=rij
4566 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4567 !     --- Electrostatic-interaction matrix ---
4568                 a_chuj(1,1,num_conti,i)=a22
4569                 a_chuj(1,2,num_conti,i)=a23
4570                 a_chuj(2,1,num_conti,i)=a32
4571                 a_chuj(2,2,num_conti,i)=a33
4572 !     --- Gradient of rij
4573                 do kkk=1,3
4574                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4575                 enddo
4576                 kkll=0
4577                 do k=1,2
4578                   do l=1,2
4579                     kkll=kkll+1
4580                     do m=1,3
4581                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4582                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4583                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4584                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4585                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4586                     enddo
4587                   enddo
4588                 enddo
4589                 ENDIF
4590                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4591 ! Calculate contact energies
4592                 cosa4=4.0D0*cosa
4593                 wij=cosa-3.0D0*cosb*cosg
4594                 cosbg1=cosb+cosg
4595                 cosbg2=cosb-cosg
4596 !               fac3=dsqrt(-ael6i)/r0ij**3
4597                 fac3=dsqrt(-ael6i)*r3ij
4598 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4599                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4600                 if (ees0tmp.gt.0) then
4601                   ees0pij=dsqrt(ees0tmp)
4602                 else
4603                   ees0pij=0
4604                 endif
4605                 if (shield_mode.eq.0) then
4606                 fac_shield(i)=1.0d0
4607                 fac_shield(j)=1.0d0
4608                 else
4609                 ees0plist(num_conti,i)=j
4610                 endif
4611 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4612                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4613                 if (ees0tmp.gt.0) then
4614                   ees0mij=dsqrt(ees0tmp)
4615                 else
4616                   ees0mij=0
4617                 endif
4618 !               ees0mij=0.0D0
4619                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4620                      *sss_ele_cut &
4621                      *fac_shield(i)*fac_shield(j)
4622
4623                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4624                      *sss_ele_cut &
4625                      *fac_shield(i)*fac_shield(j)
4626
4627 ! Diagnostics. Comment out or remove after debugging!
4628 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4629 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4630 !               ees0m(num_conti,i)=0.0D0
4631 ! End diagnostics.
4632 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4633 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4634 ! Angular derivatives of the contact function
4635                 ees0pij1=fac3/ees0pij
4636                 ees0mij1=fac3/ees0mij
4637                 fac3p=-3.0D0*fac3*rrmij
4638                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4639                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4640 !               ees0mij1=0.0D0
4641                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4642                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4643                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4644                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4645                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4646                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4647                 ecosap=ecosa1+ecosa2
4648                 ecosbp=ecosb1+ecosb2
4649                 ecosgp=ecosg1+ecosg2
4650                 ecosam=ecosa1-ecosa2
4651                 ecosbm=ecosb1-ecosb2
4652                 ecosgm=ecosg1-ecosg2
4653 ! Diagnostics
4654 !               ecosap=ecosa1
4655 !               ecosbp=ecosb1
4656 !               ecosgp=ecosg1
4657 !               ecosam=0.0D0
4658 !               ecosbm=0.0D0
4659 !               ecosgm=0.0D0
4660 ! End diagnostics
4661                 facont_hb(num_conti,i)=fcont
4662                 fprimcont=fprimcont/rij
4663 !d              facont_hb(num_conti,i)=1.0D0
4664 ! Following line is for diagnostics.
4665 !d              fprimcont=0.0D0
4666                 do k=1,3
4667                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4668                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4669                 enddo
4670                 do k=1,3
4671                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4672                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4673                 enddo
4674                 gggp(1)=gggp(1)+ees0pijp*xj &
4675                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4676                 gggp(2)=gggp(2)+ees0pijp*yj &
4677                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4678                 gggp(3)=gggp(3)+ees0pijp*zj &
4679                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4680
4681                 gggm(1)=gggm(1)+ees0mijp*xj &
4682                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4683
4684                 gggm(2)=gggm(2)+ees0mijp*yj &
4685                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4686
4687                 gggm(3)=gggm(3)+ees0mijp*zj &
4688                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4689
4690 ! Derivatives due to the contact function
4691                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4692                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4693                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4694                 do k=1,3
4695 !
4696 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4697 !          following the change of gradient-summation algorithm.
4698 !
4699 !grad                  ghalfp=0.5D0*gggp(k)
4700 !grad                  ghalfm=0.5D0*gggm(k)
4701                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4702                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4703                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4704                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4705
4706                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4707                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4708                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4709                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4710
4711                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4712                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4713
4714                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4715                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4716                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4717                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4718
4719                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4720                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4721                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4722                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4723
4724                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4725                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4726
4727                 enddo
4728 ! Diagnostics. Comment out or remove after debugging!
4729 !diag           do k=1,3
4730 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4731 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4732 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4733 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4734 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4735 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4736 !diag           enddo
4737               ENDIF ! wcorr
4738               endif  ! num_conti.le.maxconts
4739             endif  ! fcont.gt.0
4740           endif    ! j.gt.i+1
4741           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4742             do k=1,4
4743               do l=1,3
4744                 ghalf=0.5d0*agg(l,k)
4745                 aggi(l,k)=aggi(l,k)+ghalf
4746                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4747                 aggj(l,k)=aggj(l,k)+ghalf
4748               enddo
4749             enddo
4750             if (j.eq.nres-1 .and. i.lt.j-2) then
4751               do k=1,4
4752                 do l=1,3
4753                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4754                 enddo
4755               enddo
4756             endif
4757           endif
4758  128  continue
4759 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4760       return
4761       end subroutine eelecij
4762 !-----------------------------------------------------------------------------
4763       subroutine eturn3(i,eello_turn3)
4764 ! Third- and fourth-order contributions from turns
4765
4766       use comm_locel
4767 !      implicit real*8 (a-h,o-z)
4768 !      include 'DIMENSIONS'
4769 !      include 'COMMON.IOUNITS'
4770 !      include 'COMMON.GEO'
4771 !      include 'COMMON.VAR'
4772 !      include 'COMMON.LOCAL'
4773 !      include 'COMMON.CHAIN'
4774 !      include 'COMMON.DERIV'
4775 !      include 'COMMON.INTERACT'
4776 !      include 'COMMON.CONTACTS'
4777 !      include 'COMMON.TORSION'
4778 !      include 'COMMON.VECTORS'
4779 !      include 'COMMON.FFIELD'
4780 !      include 'COMMON.CONTROL'
4781       real(kind=8),dimension(3) :: ggg
4782       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4783         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4784        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4785
4786       real(kind=8),dimension(2) :: auxvec,auxvec1
4787 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4788       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4789 !el      integer :: num_conti,j1,j2
4790 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4791 !el        dz_normi,xmedi,ymedi,zmedi
4792
4793 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4794 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4795 !el         num_conti,j1,j2
4796 !el local variables
4797       integer :: i,j,l,k,ilist,iresshield
4798       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4799
4800       j=i+2
4801 !      write (iout,*) "eturn3",i,j,j1,j2
4802           zj=(c(3,j)+c(3,j+1))/2.0d0
4803           zj=mod(zj,boxzsize)
4804           if (zj.lt.0) zj=zj+boxzsize
4805           if ((zj.lt.0)) write (*,*) "CHUJ"
4806        if ((zj.gt.bordlipbot)  &
4807         .and.(zj.lt.bordliptop)) then
4808 !C the energy transfer exist
4809         if (zj.lt.buflipbot) then
4810 !C what fraction I am in
4811          fracinbuf=1.0d0-     &
4812              ((zj-bordlipbot)/lipbufthick)
4813 !C lipbufthick is thickenes of lipid buffore
4814          sslipj=sscalelip(fracinbuf)
4815          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4816         elseif (zj.gt.bufliptop) then
4817          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4818          sslipj=sscalelip(fracinbuf)
4819          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4820         else
4821          sslipj=1.0d0
4822          ssgradlipj=0.0
4823         endif
4824        else
4825          sslipj=0.0d0
4826          ssgradlipj=0.0
4827        endif
4828
4829       a_temp(1,1)=a22
4830       a_temp(1,2)=a23
4831       a_temp(2,1)=a32
4832       a_temp(2,2)=a33
4833 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4834 !
4835 !               Third-order contributions
4836 !
4837 !                 (i+2)o----(i+3)
4838 !                      | |
4839 !                      | |
4840 !                 (i+1)o----i
4841 !
4842 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4843 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4844         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4845         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4846         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4847         call transpose2(auxmat(1,1),auxmat1(1,1))
4848         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4849         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4850         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4851         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4852         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4853
4854         if (shield_mode.eq.0) then
4855         fac_shield(i)=1.0d0
4856         fac_shield(j)=1.0d0
4857         endif
4858
4859         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4860          *fac_shield(i)*fac_shield(j)  &
4861          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4862         eello_t3= &
4863         0.5d0*(pizda(1,1)+pizda(2,2)) &
4864         *fac_shield(i)*fac_shield(j)
4865
4866         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4867                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4868 !C#ifdef NEWCORR
4869 !C Derivatives in theta
4870         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4871        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4872         *fac_shield(i)*fac_shield(j)
4873         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4874        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4875         *fac_shield(i)*fac_shield(j)
4876 !C#endif
4877
4878
4879
4880           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4881        (shield_mode.gt.0)) then
4882 !C          print *,i,j
4883
4884           do ilist=1,ishield_list(i)
4885            iresshield=shield_list(ilist,i)
4886            do k=1,3
4887            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4888            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4889                    rlocshield &
4890            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4891             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4892              +rlocshield
4893            enddo
4894           enddo
4895           do ilist=1,ishield_list(j)
4896            iresshield=shield_list(ilist,j)
4897            do k=1,3
4898            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4899            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4900                    rlocshield &
4901            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4902            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4903                   +rlocshield
4904
4905            enddo
4906           enddo
4907
4908           do k=1,3
4909             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4910                    grad_shield(k,i)*eello_t3/fac_shield(i)
4911             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4912                    grad_shield(k,j)*eello_t3/fac_shield(j)
4913             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4914                    grad_shield(k,i)*eello_t3/fac_shield(i)
4915             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4916                    grad_shield(k,j)*eello_t3/fac_shield(j)
4917            enddo
4918            endif
4919
4920 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4921 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4922 !d     &    ' eello_turn3_num',4*eello_turn3_num
4923 ! Derivatives in gamma(i)
4924         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4925         call transpose2(auxmat2(1,1),auxmat3(1,1))
4926         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4927         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4928           *fac_shield(i)*fac_shield(j)        &
4929           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4930 ! Derivatives in gamma(i+1)
4931         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4932         call transpose2(auxmat2(1,1),auxmat3(1,1))
4933         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4934         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4935           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4936           *fac_shield(i)*fac_shield(j)        &
4937           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4938
4939 ! Cartesian derivatives
4940         do l=1,3
4941 !            ghalf1=0.5d0*agg(l,1)
4942 !            ghalf2=0.5d0*agg(l,2)
4943 !            ghalf3=0.5d0*agg(l,3)
4944 !            ghalf4=0.5d0*agg(l,4)
4945           a_temp(1,1)=aggi(l,1)!+ghalf1
4946           a_temp(1,2)=aggi(l,2)!+ghalf2
4947           a_temp(2,1)=aggi(l,3)!+ghalf3
4948           a_temp(2,2)=aggi(l,4)!+ghalf4
4949           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4950           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4951             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4952           *fac_shield(i)*fac_shield(j)      &
4953           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4954
4955           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4956           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4957           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4958           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4959           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4960           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4961             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4962           *fac_shield(i)*fac_shield(j)        &
4963           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4964
4965           a_temp(1,1)=aggj(l,1)!+ghalf1
4966           a_temp(1,2)=aggj(l,2)!+ghalf2
4967           a_temp(2,1)=aggj(l,3)!+ghalf3
4968           a_temp(2,2)=aggj(l,4)!+ghalf4
4969           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4970           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4971             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4972           *fac_shield(i)*fac_shield(j)      &
4973           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4974
4975           a_temp(1,1)=aggj1(l,1)
4976           a_temp(1,2)=aggj1(l,2)
4977           a_temp(2,1)=aggj1(l,3)
4978           a_temp(2,2)=aggj1(l,4)
4979           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4980           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4981             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4982           *fac_shield(i)*fac_shield(j)        &
4983           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4984         enddo
4985          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4986           ssgradlipi*eello_t3/4.0d0*lipscale
4987          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4988           ssgradlipj*eello_t3/4.0d0*lipscale
4989          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4990           ssgradlipi*eello_t3/4.0d0*lipscale
4991          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4992           ssgradlipj*eello_t3/4.0d0*lipscale
4993
4994       return
4995       end subroutine eturn3
4996 !-----------------------------------------------------------------------------
4997       subroutine eturn4(i,eello_turn4)
4998 ! Third- and fourth-order contributions from turns
4999
5000       use comm_locel
5001 !      implicit real*8 (a-h,o-z)
5002 !      include 'DIMENSIONS'
5003 !      include 'COMMON.IOUNITS'
5004 !      include 'COMMON.GEO'
5005 !      include 'COMMON.VAR'
5006 !      include 'COMMON.LOCAL'
5007 !      include 'COMMON.CHAIN'
5008 !      include 'COMMON.DERIV'
5009 !      include 'COMMON.INTERACT'
5010 !      include 'COMMON.CONTACTS'
5011 !      include 'COMMON.TORSION'
5012 !      include 'COMMON.VECTORS'
5013 !      include 'COMMON.FFIELD'
5014 !      include 'COMMON.CONTROL'
5015       real(kind=8),dimension(3) :: ggg
5016       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5017         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5018         gte1t,gte2t,gte3t,&
5019         gte1a,gtae3,gtae3e2, ae3gte2,&
5020         gtEpizda1,gtEpizda2,gtEpizda3
5021
5022       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5023        auxgEvec3,auxgvec
5024
5025 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5026       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5027 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5028 !el        dz_normi,xmedi,ymedi,zmedi
5029 !el      integer :: num_conti,j1,j2
5030 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5031 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5032 !el          num_conti,j1,j2
5033 !el local variables
5034       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5035       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5036          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5037
5038       j=i+3
5039 !      if (j.ne.20) return
5040 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5041 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5042 !
5043 !               Fourth-order contributions
5044 !
5045 !                 (i+3)o----(i+4)
5046 !                     /  |
5047 !               (i+2)o   |
5048 !                     \  |
5049 !                 (i+1)o----i
5050 !
5051 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5052 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5053 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5054           zj=(c(3,j)+c(3,j+1))/2.0d0
5055           zj=mod(zj,boxzsize)
5056           if (zj.lt.0) zj=zj+boxzsize
5057        if ((zj.gt.bordlipbot)  &
5058         .and.(zj.lt.bordliptop)) then
5059 !C the energy transfer exist
5060         if (zj.lt.buflipbot) then
5061 !C what fraction I am in
5062          fracinbuf=1.0d0-     &
5063              ((zj-bordlipbot)/lipbufthick)
5064 !C lipbufthick is thickenes of lipid buffore
5065          sslipj=sscalelip(fracinbuf)
5066          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5067         elseif (zj.gt.bufliptop) then
5068          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5069          sslipj=sscalelip(fracinbuf)
5070          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5071         else
5072          sslipj=1.0d0
5073          ssgradlipj=0.0
5074         endif
5075        else
5076          sslipj=0.0d0
5077          ssgradlipj=0.0
5078        endif
5079
5080         a_temp(1,1)=a22
5081         a_temp(1,2)=a23
5082         a_temp(2,1)=a32
5083         a_temp(2,2)=a33
5084         iti1=i+1
5085         iti2=i+2
5086         iti3=i+3
5087 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5088         call transpose2(EUg(1,1,i+1),e1t(1,1))
5089         call transpose2(Eug(1,1,i+2),e2t(1,1))
5090         call transpose2(Eug(1,1,i+3),e3t(1,1))
5091 !C Ematrix derivative in theta
5092         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5093         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5094         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5095
5096         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5097         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5098         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5099         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5100 !c       auxalary matrix of E i+1
5101         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5102         s1=scalar2(b1(1,iti2),auxvec(1))
5103 !c derivative of theta i+2 with constant i+3
5104         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5105 !c derivative of theta i+2 with constant i+2
5106         gs32=scalar2(b1(1,i+2),auxgvec(1))
5107 !c derivative of E matix in theta of i+1
5108         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5109
5110         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5111         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5112         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5113 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5114         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5115 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5116         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5117         s2=scalar2(b1(1,i+1),auxvec(1))
5118 !c derivative of theta i+1 with constant i+3
5119         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5120 !c derivative of theta i+2 with constant i+1
5121         gs21=scalar2(b1(1,i+1),auxgvec(1))
5122 !c derivative of theta i+3 with constant i+1
5123         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5124
5125         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5126         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5127 !c ae3gte2 is derivative over i+2
5128         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5129
5130         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5131         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5132 !c i+2
5133         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5134 !c i+3
5135         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5136
5137         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5138         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5139         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5140         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5141         if (shield_mode.eq.0) then
5142         fac_shield(i)=1.0
5143         fac_shield(j)=1.0
5144         endif
5145
5146         eello_turn4=eello_turn4-(s1+s2+s3) &
5147         *fac_shield(i)*fac_shield(j)       &
5148         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5149         eello_t4=-(s1+s2+s3)  &
5150           *fac_shield(i)*fac_shield(j)
5151 !C Now derivative over shield:
5152           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5153          (shield_mode.gt.0)) then
5154 !C          print *,i,j
5155
5156           do ilist=1,ishield_list(i)
5157            iresshield=shield_list(ilist,i)
5158            do k=1,3
5159            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5160 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5161            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5162                    rlocshield &
5163             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5164             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5165            +rlocshield
5166            enddo
5167           enddo
5168           do ilist=1,ishield_list(j)
5169            iresshield=shield_list(ilist,j)
5170            do k=1,3
5171 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5172            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5173            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5174                    rlocshield  &
5175            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5176            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5177                   +rlocshield
5178 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5179
5180            enddo
5181           enddo
5182           do k=1,3
5183             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5184                    grad_shield(k,i)*eello_t4/fac_shield(i)
5185             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5186                    grad_shield(k,j)*eello_t4/fac_shield(j)
5187             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5188                    grad_shield(k,i)*eello_t4/fac_shield(i)
5189             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5190                    grad_shield(k,j)*eello_t4/fac_shield(j)
5191 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5192            enddo
5193            endif
5194 #ifdef NEWCORR
5195         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5196                        -(gs13+gsE13+gsEE1)*wturn4&
5197        *fac_shield(i)*fac_shield(j)
5198         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5199                          -(gs23+gs21+gsEE2)*wturn4&
5200        *fac_shield(i)*fac_shield(j)
5201
5202         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5203                          -(gs32+gsE31+gsEE3)*wturn4&
5204        *fac_shield(i)*fac_shield(j)
5205
5206 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5207 !c     &   gs2
5208 #endif
5209         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5210            'eturn4',i,j,-(s1+s2+s3)
5211 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5212 !d     &    ' eello_turn4_num',8*eello_turn4_num
5213 ! Derivatives in gamma(i)
5214         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5215         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5216         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5217         s1=scalar2(b1(1,i+1),auxvec(1))
5218         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5219         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5220         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5221        *fac_shield(i)*fac_shield(j)  &
5222        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5223
5224 ! Derivatives in gamma(i+1)
5225         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5226         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5227         s2=scalar2(b1(1,iti1),auxvec(1))
5228         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5229         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5230         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5231         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5232        *fac_shield(i)*fac_shield(j)  &
5233        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5234
5235 ! Derivatives in gamma(i+2)
5236         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5237         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5238         s1=scalar2(b1(1,iti2),auxvec(1))
5239         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5240         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5241         s2=scalar2(b1(1,iti1),auxvec(1))
5242         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5243         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5244         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5245         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5246        *fac_shield(i)*fac_shield(j)  &
5247        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5248
5249 ! Cartesian derivatives
5250 ! Derivatives of this turn contributions in DC(i+2)
5251         if (j.lt.nres-1) then
5252           do l=1,3
5253             a_temp(1,1)=agg(l,1)
5254             a_temp(1,2)=agg(l,2)
5255             a_temp(2,1)=agg(l,3)
5256             a_temp(2,2)=agg(l,4)
5257             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5258             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5259             s1=scalar2(b1(1,iti2),auxvec(1))
5260             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5261             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5262             s2=scalar2(b1(1,iti1),auxvec(1))
5263             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5264             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5265             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5266             ggg(l)=-(s1+s2+s3)
5267             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5268        *fac_shield(i)*fac_shield(j)  &
5269        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5270
5271           enddo
5272         endif
5273 ! Remaining derivatives of this turn contribution
5274         do l=1,3
5275           a_temp(1,1)=aggi(l,1)
5276           a_temp(1,2)=aggi(l,2)
5277           a_temp(2,1)=aggi(l,3)
5278           a_temp(2,2)=aggi(l,4)
5279           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5280           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5281           s1=scalar2(b1(1,iti2),auxvec(1))
5282           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5283           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5284           s2=scalar2(b1(1,iti1),auxvec(1))
5285           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5286           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5287           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5288           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5289          *fac_shield(i)*fac_shield(j)  &
5290          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5291
5292
5293           a_temp(1,1)=aggi1(l,1)
5294           a_temp(1,2)=aggi1(l,2)
5295           a_temp(2,1)=aggi1(l,3)
5296           a_temp(2,2)=aggi1(l,4)
5297           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5298           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5299           s1=scalar2(b1(1,iti2),auxvec(1))
5300           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5301           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5302           s2=scalar2(b1(1,iti1),auxvec(1))
5303           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5304           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5305           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5306           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5307          *fac_shield(i)*fac_shield(j)  &
5308          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5309
5310
5311           a_temp(1,1)=aggj(l,1)
5312           a_temp(1,2)=aggj(l,2)
5313           a_temp(2,1)=aggj(l,3)
5314           a_temp(2,2)=aggj(l,4)
5315           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5316           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5317           s1=scalar2(b1(1,iti2),auxvec(1))
5318           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5319           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5320           s2=scalar2(b1(1,iti1),auxvec(1))
5321           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5322           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5323           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5324 !        if (j.lt.nres-1) then
5325           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5326          *fac_shield(i)*fac_shield(j)  &
5327          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5328 !        endif
5329
5330           a_temp(1,1)=aggj1(l,1)
5331           a_temp(1,2)=aggj1(l,2)
5332           a_temp(2,1)=aggj1(l,3)
5333           a_temp(2,2)=aggj1(l,4)
5334           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5335           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5336           s1=scalar2(b1(1,iti2),auxvec(1))
5337           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5338           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5339           s2=scalar2(b1(1,iti1),auxvec(1))
5340           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5341           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5342           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5343 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5344 !        if (j.lt.nres-1) then
5345 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5346           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5347          *fac_shield(i)*fac_shield(j)  &
5348          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5349 !            if (shield_mode.gt.0) then
5350 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5351 !            else
5352 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5353 !            endif
5354 !         endif
5355         enddo
5356          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5357           ssgradlipi*eello_t4/4.0d0*lipscale
5358          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5359           ssgradlipj*eello_t4/4.0d0*lipscale
5360          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5361           ssgradlipi*eello_t4/4.0d0*lipscale
5362          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5363           ssgradlipj*eello_t4/4.0d0*lipscale
5364
5365       return
5366       end subroutine eturn4
5367 !-----------------------------------------------------------------------------
5368       subroutine unormderiv(u,ugrad,unorm,ungrad)
5369 ! This subroutine computes the derivatives of a normalized vector u, given
5370 ! the derivatives computed without normalization conditions, ugrad. Returns
5371 ! ungrad.
5372 !      implicit none
5373       real(kind=8),dimension(3) :: u,vec
5374       real(kind=8),dimension(3,3) ::ugrad,ungrad
5375       real(kind=8) :: unorm      !,scalar
5376       integer :: i,j
5377 !      write (2,*) 'ugrad',ugrad
5378 !      write (2,*) 'u',u
5379       do i=1,3
5380         vec(i)=scalar(ugrad(1,i),u(1))
5381       enddo
5382 !      write (2,*) 'vec',vec
5383       do i=1,3
5384         do j=1,3
5385           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5386         enddo
5387       enddo
5388 !      write (2,*) 'ungrad',ungrad
5389       return
5390       end subroutine unormderiv
5391 !-----------------------------------------------------------------------------
5392       subroutine escp_soft_sphere(evdw2,evdw2_14)
5393 !
5394 ! This subroutine calculates the excluded-volume interaction energy between
5395 ! peptide-group centers and side chains and its gradient in virtual-bond and
5396 ! side-chain vectors.
5397 !
5398 !      implicit real*8 (a-h,o-z)
5399 !      include 'DIMENSIONS'
5400 !      include 'COMMON.GEO'
5401 !      include 'COMMON.VAR'
5402 !      include 'COMMON.LOCAL'
5403 !      include 'COMMON.CHAIN'
5404 !      include 'COMMON.DERIV'
5405 !      include 'COMMON.INTERACT'
5406 !      include 'COMMON.FFIELD'
5407 !      include 'COMMON.IOUNITS'
5408 !      include 'COMMON.CONTROL'
5409       real(kind=8),dimension(3) :: ggg
5410 !el local variables
5411       integer :: i,iint,j,k,iteli,itypj
5412       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5413                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5414
5415       evdw2=0.0D0
5416       evdw2_14=0.0d0
5417       r0_scp=4.5d0
5418 !d    print '(a)','Enter ESCP'
5419 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5420       do i=iatscp_s,iatscp_e
5421         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5422         iteli=itel(i)
5423         xi=0.5D0*(c(1,i)+c(1,i+1))
5424         yi=0.5D0*(c(2,i)+c(2,i+1))
5425         zi=0.5D0*(c(3,i)+c(3,i+1))
5426
5427         do iint=1,nscp_gr(i)
5428
5429         do j=iscpstart(i,iint),iscpend(i,iint)
5430           if (itype(j,1).eq.ntyp1) cycle
5431           itypj=iabs(itype(j,1))
5432 ! Uncomment following three lines for SC-p interactions
5433 !         xj=c(1,nres+j)-xi
5434 !         yj=c(2,nres+j)-yi
5435 !         zj=c(3,nres+j)-zi
5436 ! Uncomment following three lines for Ca-p interactions
5437           xj=c(1,j)-xi
5438           yj=c(2,j)-yi
5439           zj=c(3,j)-zi
5440           rij=xj*xj+yj*yj+zj*zj
5441           r0ij=r0_scp
5442           r0ijsq=r0ij*r0ij
5443           if (rij.lt.r0ijsq) then
5444             evdwij=0.25d0*(rij-r0ijsq)**2
5445             fac=rij-r0ijsq
5446           else
5447             evdwij=0.0d0
5448             fac=0.0d0
5449           endif
5450           evdw2=evdw2+evdwij
5451 !
5452 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5453 !
5454           ggg(1)=xj*fac
5455           ggg(2)=yj*fac
5456           ggg(3)=zj*fac
5457 !grad          if (j.lt.i) then
5458 !d          write (iout,*) 'j<i'
5459 ! Uncomment following three lines for SC-p interactions
5460 !           do k=1,3
5461 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5462 !           enddo
5463 !grad          else
5464 !d          write (iout,*) 'j>i'
5465 !grad            do k=1,3
5466 !grad              ggg(k)=-ggg(k)
5467 ! Uncomment following line for SC-p interactions
5468 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5469 !grad            enddo
5470 !grad          endif
5471 !grad          do k=1,3
5472 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5473 !grad          enddo
5474 !grad          kstart=min0(i+1,j)
5475 !grad          kend=max0(i-1,j-1)
5476 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5477 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5478 !grad          do k=kstart,kend
5479 !grad            do l=1,3
5480 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5481 !grad            enddo
5482 !grad          enddo
5483           do k=1,3
5484             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5485             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5486           enddo
5487         enddo
5488
5489         enddo ! iint
5490       enddo ! i
5491       return
5492       end subroutine escp_soft_sphere
5493 !-----------------------------------------------------------------------------
5494       subroutine escp(evdw2,evdw2_14)
5495 !
5496 ! This subroutine calculates the excluded-volume interaction energy between
5497 ! peptide-group centers and side chains and its gradient in virtual-bond and
5498 ! side-chain vectors.
5499 !
5500 !      implicit real*8 (a-h,o-z)
5501 !      include 'DIMENSIONS'
5502 !      include 'COMMON.GEO'
5503 !      include 'COMMON.VAR'
5504 !      include 'COMMON.LOCAL'
5505 !      include 'COMMON.CHAIN'
5506 !      include 'COMMON.DERIV'
5507 !      include 'COMMON.INTERACT'
5508 !      include 'COMMON.FFIELD'
5509 !      include 'COMMON.IOUNITS'
5510 !      include 'COMMON.CONTROL'
5511       real(kind=8),dimension(3) :: ggg
5512 !el local variables
5513       integer :: i,iint,j,k,iteli,itypj,subchap
5514       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5515                    e1,e2,evdwij,rij
5516       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5517                     dist_temp, dist_init
5518       integer xshift,yshift,zshift
5519
5520       evdw2=0.0D0
5521       evdw2_14=0.0d0
5522 !d    print '(a)','Enter ESCP'
5523 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5524       do i=iatscp_s,iatscp_e
5525         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5526         iteli=itel(i)
5527         xi=0.5D0*(c(1,i)+c(1,i+1))
5528         yi=0.5D0*(c(2,i)+c(2,i+1))
5529         zi=0.5D0*(c(3,i)+c(3,i+1))
5530           xi=mod(xi,boxxsize)
5531           if (xi.lt.0) xi=xi+boxxsize
5532           yi=mod(yi,boxysize)
5533           if (yi.lt.0) yi=yi+boxysize
5534           zi=mod(zi,boxzsize)
5535           if (zi.lt.0) zi=zi+boxzsize
5536
5537         do iint=1,nscp_gr(i)
5538
5539         do j=iscpstart(i,iint),iscpend(i,iint)
5540           itypj=iabs(itype(j,1))
5541           if (itypj.eq.ntyp1) cycle
5542 ! Uncomment following three lines for SC-p interactions
5543 !         xj=c(1,nres+j)-xi
5544 !         yj=c(2,nres+j)-yi
5545 !         zj=c(3,nres+j)-zi
5546 ! Uncomment following three lines for Ca-p interactions
5547 !          xj=c(1,j)-xi
5548 !          yj=c(2,j)-yi
5549 !          zj=c(3,j)-zi
5550           xj=c(1,j)
5551           yj=c(2,j)
5552           zj=c(3,j)
5553           xj=mod(xj,boxxsize)
5554           if (xj.lt.0) xj=xj+boxxsize
5555           yj=mod(yj,boxysize)
5556           if (yj.lt.0) yj=yj+boxysize
5557           zj=mod(zj,boxzsize)
5558           if (zj.lt.0) zj=zj+boxzsize
5559       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5560       xj_safe=xj
5561       yj_safe=yj
5562       zj_safe=zj
5563       subchap=0
5564       do xshift=-1,1
5565       do yshift=-1,1
5566       do zshift=-1,1
5567           xj=xj_safe+xshift*boxxsize
5568           yj=yj_safe+yshift*boxysize
5569           zj=zj_safe+zshift*boxzsize
5570           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5571           if(dist_temp.lt.dist_init) then
5572             dist_init=dist_temp
5573             xj_temp=xj
5574             yj_temp=yj
5575             zj_temp=zj
5576             subchap=1
5577           endif
5578        enddo
5579        enddo
5580        enddo
5581        if (subchap.eq.1) then
5582           xj=xj_temp-xi
5583           yj=yj_temp-yi
5584           zj=zj_temp-zi
5585        else
5586           xj=xj_safe-xi
5587           yj=yj_safe-yi
5588           zj=zj_safe-zi
5589        endif
5590
5591           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5592           rij=dsqrt(1.0d0/rrij)
5593             sss_ele_cut=sscale_ele(rij)
5594             sss_ele_grad=sscagrad_ele(rij)
5595 !            print *,sss_ele_cut,sss_ele_grad,&
5596 !            (rij),r_cut_ele,rlamb_ele
5597             if (sss_ele_cut.le.0.0) cycle
5598           fac=rrij**expon2
5599           e1=fac*fac*aad(itypj,iteli)
5600           e2=fac*bad(itypj,iteli)
5601           if (iabs(j-i) .le. 2) then
5602             e1=scal14*e1
5603             e2=scal14*e2
5604             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5605           endif
5606           evdwij=e1+e2
5607           evdw2=evdw2+evdwij*sss_ele_cut
5608 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5609 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5610           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5611              'evdw2',i,j,evdwij
5612 !
5613 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5614 !
5615           fac=-(evdwij+e1)*rrij*sss_ele_cut
5616           fac=fac+evdwij*sss_ele_grad/rij/expon
5617           ggg(1)=xj*fac
5618           ggg(2)=yj*fac
5619           ggg(3)=zj*fac
5620 !grad          if (j.lt.i) then
5621 !d          write (iout,*) 'j<i'
5622 ! Uncomment following three lines for SC-p interactions
5623 !           do k=1,3
5624 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5625 !           enddo
5626 !grad          else
5627 !d          write (iout,*) 'j>i'
5628 !grad            do k=1,3
5629 !grad              ggg(k)=-ggg(k)
5630 ! Uncomment following line for SC-p interactions
5631 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5632 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5633 !grad            enddo
5634 !grad          endif
5635 !grad          do k=1,3
5636 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5637 !grad          enddo
5638 !grad          kstart=min0(i+1,j)
5639 !grad          kend=max0(i-1,j-1)
5640 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5641 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5642 !grad          do k=kstart,kend
5643 !grad            do l=1,3
5644 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5645 !grad            enddo
5646 !grad          enddo
5647           do k=1,3
5648             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5649             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5650           enddo
5651         enddo
5652
5653         enddo ! iint
5654       enddo ! i
5655       do i=1,nct
5656         do j=1,3
5657           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5658           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5659           gradx_scp(j,i)=expon*gradx_scp(j,i)
5660         enddo
5661       enddo
5662 !******************************************************************************
5663 !
5664 !                              N O T E !!!
5665 !
5666 ! To save time the factor EXPON has been extracted from ALL components
5667 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5668 ! use!
5669 !
5670 !******************************************************************************
5671       return
5672       end subroutine escp
5673 !-----------------------------------------------------------------------------
5674       subroutine edis(ehpb)
5675 !
5676 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5677 !
5678 !      implicit real*8 (a-h,o-z)
5679 !      include 'DIMENSIONS'
5680 !      include 'COMMON.SBRIDGE'
5681 !      include 'COMMON.CHAIN'
5682 !      include 'COMMON.DERIV'
5683 !      include 'COMMON.VAR'
5684 !      include 'COMMON.INTERACT'
5685 !      include 'COMMON.IOUNITS'
5686       real(kind=8),dimension(3) :: ggg
5687 !el local variables
5688       integer :: i,j,ii,jj,iii,jjj,k
5689       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5690
5691       ehpb=0.0D0
5692 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5693 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5694       if (link_end.eq.0) return
5695       do i=link_start,link_end
5696 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5697 ! CA-CA distance used in regularization of structure.
5698         ii=ihpb(i)
5699         jj=jhpb(i)
5700 ! iii and jjj point to the residues for which the distance is assigned.
5701         if (ii.gt.nres) then
5702           iii=ii-nres
5703           jjj=jj-nres
5704         else
5705           iii=ii
5706           jjj=jj
5707         endif
5708 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5709 !     &    dhpb(i),dhpb1(i),forcon(i)
5710 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5711 !    distance and angle dependent SS bond potential.
5712 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5713 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5714         if (.not.dyn_ss .and. i.le.nss) then
5715 ! 15/02/13 CC dynamic SSbond - additional check
5716          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5717         iabs(itype(jjj,1)).eq.1) then
5718           call ssbond_ene(iii,jjj,eij)
5719           ehpb=ehpb+2*eij
5720 !d          write (iout,*) "eij",eij
5721          endif
5722         else if (ii.gt.nres .and. jj.gt.nres) then
5723 !c Restraints from contact prediction
5724           dd=dist(ii,jj)
5725           if (constr_dist.eq.11) then
5726             ehpb=ehpb+fordepth(i)**4.0d0 &
5727                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5728             fac=fordepth(i)**4.0d0 &
5729                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5730           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5731             ehpb,fordepth(i),dd
5732            else
5733           if (dhpb1(i).gt.0.0d0) then
5734             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5735             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5736 !c            write (iout,*) "beta nmr",
5737 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5738           else
5739             dd=dist(ii,jj)
5740             rdis=dd-dhpb(i)
5741 !C Get the force constant corresponding to this distance.
5742             waga=forcon(i)
5743 !C Calculate the contribution to energy.
5744             ehpb=ehpb+waga*rdis*rdis
5745 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5746 !C
5747 !C Evaluate gradient.
5748 !C
5749             fac=waga*rdis/dd
5750           endif
5751           endif
5752           do j=1,3
5753             ggg(j)=fac*(c(j,jj)-c(j,ii))
5754           enddo
5755           do j=1,3
5756             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5757             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5758           enddo
5759           do k=1,3
5760             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5761             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5762           enddo
5763         else
5764           dd=dist(ii,jj)
5765           if (constr_dist.eq.11) then
5766             ehpb=ehpb+fordepth(i)**4.0d0 &
5767                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5768             fac=fordepth(i)**4.0d0 &
5769                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5770           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5771          ehpb,fordepth(i),dd
5772            else
5773           if (dhpb1(i).gt.0.0d0) then
5774             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5775             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5776 !c            write (iout,*) "alph nmr",
5777 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5778           else
5779             rdis=dd-dhpb(i)
5780 !C Get the force constant corresponding to this distance.
5781             waga=forcon(i)
5782 !C Calculate the contribution to energy.
5783             ehpb=ehpb+waga*rdis*rdis
5784 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5785 !C
5786 !C Evaluate gradient.
5787 !C
5788             fac=waga*rdis/dd
5789           endif
5790           endif
5791
5792             do j=1,3
5793               ggg(j)=fac*(c(j,jj)-c(j,ii))
5794             enddo
5795 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5796 !C If this is a SC-SC distance, we need to calculate the contributions to the
5797 !C Cartesian gradient in the SC vectors (ghpbx).
5798           if (iii.lt.ii) then
5799           do j=1,3
5800             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5801             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5802           enddo
5803           endif
5804 !cgrad        do j=iii,jjj-1
5805 !cgrad          do k=1,3
5806 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5807 !cgrad          enddo
5808 !cgrad        enddo
5809           do k=1,3
5810             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5811             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5812           enddo
5813         endif
5814       enddo
5815       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5816
5817       return
5818       end subroutine edis
5819 !-----------------------------------------------------------------------------
5820       subroutine ssbond_ene(i,j,eij)
5821 !
5822 ! Calculate the distance and angle dependent SS-bond potential energy
5823 ! using a free-energy function derived based on RHF/6-31G** ab initio
5824 ! calculations of diethyl disulfide.
5825 !
5826 ! A. Liwo and U. Kozlowska, 11/24/03
5827 !
5828 !      implicit real*8 (a-h,o-z)
5829 !      include 'DIMENSIONS'
5830 !      include 'COMMON.SBRIDGE'
5831 !      include 'COMMON.CHAIN'
5832 !      include 'COMMON.DERIV'
5833 !      include 'COMMON.LOCAL'
5834 !      include 'COMMON.INTERACT'
5835 !      include 'COMMON.VAR'
5836 !      include 'COMMON.IOUNITS'
5837       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5838 !el local variables
5839       integer :: i,j,itypi,itypj,k
5840       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5841                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5842                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5843                    cosphi,ggk
5844
5845       itypi=iabs(itype(i,1))
5846       xi=c(1,nres+i)
5847       yi=c(2,nres+i)
5848       zi=c(3,nres+i)
5849       dxi=dc_norm(1,nres+i)
5850       dyi=dc_norm(2,nres+i)
5851       dzi=dc_norm(3,nres+i)
5852 !      dsci_inv=dsc_inv(itypi)
5853       dsci_inv=vbld_inv(nres+i)
5854       itypj=iabs(itype(j,1))
5855 !      dscj_inv=dsc_inv(itypj)
5856       dscj_inv=vbld_inv(nres+j)
5857       xj=c(1,nres+j)-xi
5858       yj=c(2,nres+j)-yi
5859       zj=c(3,nres+j)-zi
5860       dxj=dc_norm(1,nres+j)
5861       dyj=dc_norm(2,nres+j)
5862       dzj=dc_norm(3,nres+j)
5863       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5864       rij=dsqrt(rrij)
5865       erij(1)=xj*rij
5866       erij(2)=yj*rij
5867       erij(3)=zj*rij
5868       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5869       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5870       om12=dxi*dxj+dyi*dyj+dzi*dzj
5871       do k=1,3
5872         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5873         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5874       enddo
5875       rij=1.0d0/rij
5876       deltad=rij-d0cm
5877       deltat1=1.0d0-om1
5878       deltat2=1.0d0+om2
5879       deltat12=om2-om1+2.0d0
5880       cosphi=om12-om1*om2
5881       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5882         +akct*deltad*deltat12 &
5883         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5884 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5885 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5886 !     &  " deltat12",deltat12," eij",eij
5887       ed=2*akcm*deltad+akct*deltat12
5888       pom1=akct*deltad
5889       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5890       eom1=-2*akth*deltat1-pom1-om2*pom2
5891       eom2= 2*akth*deltat2+pom1-om1*pom2
5892       eom12=pom2
5893       do k=1,3
5894         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5895         ghpbx(k,i)=ghpbx(k,i)-ggk &
5896                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5897                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5898         ghpbx(k,j)=ghpbx(k,j)+ggk &
5899                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5900                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5901         ghpbc(k,i)=ghpbc(k,i)-ggk
5902         ghpbc(k,j)=ghpbc(k,j)+ggk
5903       enddo
5904 !
5905 ! Calculate the components of the gradient in DC and X
5906 !
5907 !grad      do k=i,j-1
5908 !grad        do l=1,3
5909 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5910 !grad        enddo
5911 !grad      enddo
5912       return
5913       end subroutine ssbond_ene
5914 !-----------------------------------------------------------------------------
5915       subroutine ebond(estr)
5916 !
5917 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5918 !
5919 !      implicit real*8 (a-h,o-z)
5920 !      include 'DIMENSIONS'
5921 !      include 'COMMON.LOCAL'
5922 !      include 'COMMON.GEO'
5923 !      include 'COMMON.INTERACT'
5924 !      include 'COMMON.DERIV'
5925 !      include 'COMMON.VAR'
5926 !      include 'COMMON.CHAIN'
5927 !      include 'COMMON.IOUNITS'
5928 !      include 'COMMON.NAMES'
5929 !      include 'COMMON.FFIELD'
5930 !      include 'COMMON.CONTROL'
5931 !      include 'COMMON.SETUP'
5932       real(kind=8),dimension(3) :: u,ud
5933 !el local variables
5934       integer :: i,j,iti,nbi,k
5935       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5936                    uprod1,uprod2
5937
5938       estr=0.0d0
5939       estr1=0.0d0
5940 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5941 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5942
5943       do i=ibondp_start,ibondp_end
5944         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5945         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5946 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5947 !C          do j=1,3
5948 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5949 !C            *dc(j,i-1)/vbld(i)
5950 !C          enddo
5951 !C          if (energy_dec) write(iout,*) &
5952 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5953         diff = vbld(i)-vbldpDUM
5954         else
5955         diff = vbld(i)-vbldp0
5956         endif
5957         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5958            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5959         estr=estr+diff*diff
5960         do j=1,3
5961           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5962         enddo
5963 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5964 !        endif
5965       enddo
5966       estr=0.5d0*AKP*estr+estr1
5967 !      print *,"estr_bb",estr,AKP
5968 !
5969 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5970 !
5971       do i=ibond_start,ibond_end
5972         iti=iabs(itype(i,1))
5973         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5974         if (iti.ne.10 .and. iti.ne.ntyp1) then
5975           nbi=nbondterm(iti)
5976           if (nbi.eq.1) then
5977             diff=vbld(i+nres)-vbldsc0(1,iti)
5978             if (energy_dec) write (iout,*) &
5979             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5980             AKSC(1,iti),AKSC(1,iti)*diff*diff
5981             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5982 !            print *,"estr_sc",estr
5983             do j=1,3
5984               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5985             enddo
5986           else
5987             do j=1,nbi
5988               diff=vbld(i+nres)-vbldsc0(j,iti)
5989               ud(j)=aksc(j,iti)*diff
5990               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5991             enddo
5992             uprod=u(1)
5993             do j=2,nbi
5994               uprod=uprod*u(j)
5995             enddo
5996             usum=0.0d0
5997             usumsqder=0.0d0
5998             do j=1,nbi
5999               uprod1=1.0d0
6000               uprod2=1.0d0
6001               do k=1,nbi
6002                 if (k.ne.j) then
6003                   uprod1=uprod1*u(k)
6004                   uprod2=uprod2*u(k)*u(k)
6005                 endif
6006               enddo
6007               usum=usum+uprod1
6008               usumsqder=usumsqder+ud(j)*uprod2
6009             enddo
6010             estr=estr+uprod/usum
6011 !            print *,"estr_sc",estr,i
6012
6013              if (energy_dec) write (iout,*) &
6014             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6015             AKSC(1,iti),uprod/usum
6016             do j=1,3
6017              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6018             enddo
6019           endif
6020         endif
6021       enddo
6022       return
6023       end subroutine ebond
6024 #ifdef CRYST_THETA
6025 !-----------------------------------------------------------------------------
6026       subroutine ebend(etheta)
6027 !
6028 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6029 ! angles gamma and its derivatives in consecutive thetas and gammas.
6030 !
6031       use comm_calcthet
6032 !      implicit real*8 (a-h,o-z)
6033 !      include 'DIMENSIONS'
6034 !      include 'COMMON.LOCAL'
6035 !      include 'COMMON.GEO'
6036 !      include 'COMMON.INTERACT'
6037 !      include 'COMMON.DERIV'
6038 !      include 'COMMON.VAR'
6039 !      include 'COMMON.CHAIN'
6040 !      include 'COMMON.IOUNITS'
6041 !      include 'COMMON.NAMES'
6042 !      include 'COMMON.FFIELD'
6043 !      include 'COMMON.CONTROL'
6044 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6045 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6046 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6047 !el      integer :: it
6048 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6049 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6050 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6051 !el local variables
6052       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6053        ichir21,ichir22
6054       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6055        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6056        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6057       real(kind=8),dimension(2) :: y,z
6058
6059       delta=0.02d0*pi
6060 !      time11=dexp(-2*time)
6061 !      time12=1.0d0
6062       etheta=0.0D0
6063 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6064       do i=ithet_start,ithet_end
6065         if (itype(i-1,1).eq.ntyp1) cycle
6066 ! Zero the energy function and its derivative at 0 or pi.
6067         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6068         it=itype(i-1,1)
6069         ichir1=isign(1,itype(i-2,1))
6070         ichir2=isign(1,itype(i,1))
6071          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6072          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6073          if (itype(i-1,1).eq.10) then
6074           itype1=isign(10,itype(i-2,1))
6075           ichir11=isign(1,itype(i-2,1))
6076           ichir12=isign(1,itype(i-2,1))
6077           itype2=isign(10,itype(i,1))
6078           ichir21=isign(1,itype(i,1))
6079           ichir22=isign(1,itype(i,1))
6080          endif
6081
6082         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6083 #ifdef OSF
6084           phii=phi(i)
6085           if (phii.ne.phii) phii=150.0
6086 #else
6087           phii=phi(i)
6088 #endif
6089           y(1)=dcos(phii)
6090           y(2)=dsin(phii)
6091         else
6092           y(1)=0.0D0
6093           y(2)=0.0D0
6094         endif
6095         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6096 #ifdef OSF
6097           phii1=phi(i+1)
6098           if (phii1.ne.phii1) phii1=150.0
6099           phii1=pinorm(phii1)
6100           z(1)=cos(phii1)
6101 #else
6102           phii1=phi(i+1)
6103           z(1)=dcos(phii1)
6104 #endif
6105           z(2)=dsin(phii1)
6106         else
6107           z(1)=0.0D0
6108           z(2)=0.0D0
6109         endif
6110 ! Calculate the "mean" value of theta from the part of the distribution
6111 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6112 ! In following comments this theta will be referred to as t_c.
6113         thet_pred_mean=0.0d0
6114         do k=1,2
6115             athetk=athet(k,it,ichir1,ichir2)
6116             bthetk=bthet(k,it,ichir1,ichir2)
6117           if (it.eq.10) then
6118              athetk=athet(k,itype1,ichir11,ichir12)
6119              bthetk=bthet(k,itype2,ichir21,ichir22)
6120           endif
6121          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6122         enddo
6123         dthett=thet_pred_mean*ssd
6124         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6125 ! Derivatives of the "mean" values in gamma1 and gamma2.
6126         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6127                +athet(2,it,ichir1,ichir2)*y(1))*ss
6128         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6129                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6130          if (it.eq.10) then
6131         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6132              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6133         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6134                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6135          endif
6136         if (theta(i).gt.pi-delta) then
6137           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6138                E_tc0)
6139           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6140           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6141           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6142               E_theta)
6143           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6144               E_tc)
6145         else if (theta(i).lt.delta) then
6146           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6147           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6148           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6149               E_theta)
6150           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6151           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6152               E_tc)
6153         else
6154           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6155               E_theta,E_tc)
6156         endif
6157         etheta=etheta+ethetai
6158         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6159             'ebend',i,ethetai
6160         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6161         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6162         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6163       enddo
6164 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6165
6166 ! Ufff.... We've done all this!!!
6167       return
6168       end subroutine ebend
6169 !-----------------------------------------------------------------------------
6170       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6171
6172       use comm_calcthet
6173 !      implicit real*8 (a-h,o-z)
6174 !      include 'DIMENSIONS'
6175 !      include 'COMMON.LOCAL'
6176 !      include 'COMMON.IOUNITS'
6177 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6178 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6179 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6180       integer :: i,j,k
6181       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6182 !el      integer :: it
6183 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6184 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6185 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6186 !el local variables
6187       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6188        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6189
6190 ! Calculate the contributions to both Gaussian lobes.
6191 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6192 ! The "polynomial part" of the "standard deviation" of this part of
6193 ! the distribution.
6194         sig=polthet(3,it)
6195         do j=2,0,-1
6196           sig=sig*thet_pred_mean+polthet(j,it)
6197         enddo
6198 ! Derivative of the "interior part" of the "standard deviation of the"
6199 ! gamma-dependent Gaussian lobe in t_c.
6200         sigtc=3*polthet(3,it)
6201         do j=2,1,-1
6202           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6203         enddo
6204         sigtc=sig*sigtc
6205 ! Set the parameters of both Gaussian lobes of the distribution.
6206 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6207         fac=sig*sig+sigc0(it)
6208         sigcsq=fac+fac
6209         sigc=1.0D0/sigcsq
6210 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6211         sigsqtc=-4.0D0*sigcsq*sigtc
6212 !       print *,i,sig,sigtc,sigsqtc
6213 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6214         sigtc=-sigtc/(fac*fac)
6215 ! Following variable is sigma(t_c)**(-2)
6216         sigcsq=sigcsq*sigcsq
6217         sig0i=sig0(it)
6218         sig0inv=1.0D0/sig0i**2
6219         delthec=thetai-thet_pred_mean
6220         delthe0=thetai-theta0i
6221         term1=-0.5D0*sigcsq*delthec*delthec
6222         term2=-0.5D0*sig0inv*delthe0*delthe0
6223 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6224 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6225 ! to the energy (this being the log of the distribution) at the end of energy
6226 ! term evaluation for this virtual-bond angle.
6227         if (term1.gt.term2) then
6228           termm=term1
6229           term2=dexp(term2-termm)
6230           term1=1.0d0
6231         else
6232           termm=term2
6233           term1=dexp(term1-termm)
6234           term2=1.0d0
6235         endif
6236 ! The ratio between the gamma-independent and gamma-dependent lobes of
6237 ! the distribution is a Gaussian function of thet_pred_mean too.
6238         diffak=gthet(2,it)-thet_pred_mean
6239         ratak=diffak/gthet(3,it)**2
6240         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6241 ! Let's differentiate it in thet_pred_mean NOW.
6242         aktc=ak*ratak
6243 ! Now put together the distribution terms to make complete distribution.
6244         termexp=term1+ak*term2
6245         termpre=sigc+ak*sig0i
6246 ! Contribution of the bending energy from this theta is just the -log of
6247 ! the sum of the contributions from the two lobes and the pre-exponential
6248 ! factor. Simple enough, isn't it?
6249         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6250 ! NOW the derivatives!!!
6251 ! 6/6/97 Take into account the deformation.
6252         E_theta=(delthec*sigcsq*term1 &
6253              +ak*delthe0*sig0inv*term2)/termexp
6254         E_tc=((sigtc+aktc*sig0i)/termpre &
6255             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6256              aktc*term2)/termexp)
6257       return
6258       end subroutine theteng
6259 #else
6260 !-----------------------------------------------------------------------------
6261       subroutine ebend(etheta)
6262 !
6263 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6264 ! angles gamma and its derivatives in consecutive thetas and gammas.
6265 ! ab initio-derived potentials from
6266 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6267 !
6268 !      implicit real*8 (a-h,o-z)
6269 !      include 'DIMENSIONS'
6270 !      include 'COMMON.LOCAL'
6271 !      include 'COMMON.GEO'
6272 !      include 'COMMON.INTERACT'
6273 !      include 'COMMON.DERIV'
6274 !      include 'COMMON.VAR'
6275 !      include 'COMMON.CHAIN'
6276 !      include 'COMMON.IOUNITS'
6277 !      include 'COMMON.NAMES'
6278 !      include 'COMMON.FFIELD'
6279 !      include 'COMMON.CONTROL'
6280       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6281       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6282       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6283       logical :: lprn=.false., lprn1=.false.
6284 !el local variables
6285       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6286       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6287       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6288 ! local variables for constrains
6289       real(kind=8) :: difi,thetiii
6290        integer itheta
6291 !      write(iout,*) "in ebend",ithet_start,ithet_end
6292       call flush(iout)
6293       etheta=0.0D0
6294       do i=ithet_start,ithet_end
6295         if (itype(i-1,1).eq.ntyp1) cycle
6296         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6297         if (iabs(itype(i+1,1)).eq.20) iblock=2
6298         if (iabs(itype(i+1,1)).ne.20) iblock=1
6299         dethetai=0.0d0
6300         dephii=0.0d0
6301         dephii1=0.0d0
6302         theti2=0.5d0*theta(i)
6303         ityp2=ithetyp((itype(i-1,1)))
6304         do k=1,nntheterm
6305           coskt(k)=dcos(k*theti2)
6306           sinkt(k)=dsin(k*theti2)
6307         enddo
6308         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6309 #ifdef OSF
6310           phii=phi(i)
6311           if (phii.ne.phii) phii=150.0
6312 #else
6313           phii=phi(i)
6314 #endif
6315           ityp1=ithetyp((itype(i-2,1)))
6316 ! propagation of chirality for glycine type
6317           do k=1,nsingle
6318             cosph1(k)=dcos(k*phii)
6319             sinph1(k)=dsin(k*phii)
6320           enddo
6321         else
6322           phii=0.0d0
6323           ityp1=ithetyp(itype(i-2,1))
6324           do k=1,nsingle
6325             cosph1(k)=0.0d0
6326             sinph1(k)=0.0d0
6327           enddo
6328         endif
6329         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6330 #ifdef OSF
6331           phii1=phi(i+1)
6332           if (phii1.ne.phii1) phii1=150.0
6333           phii1=pinorm(phii1)
6334 #else
6335           phii1=phi(i+1)
6336 #endif
6337           ityp3=ithetyp((itype(i,1)))
6338           do k=1,nsingle
6339             cosph2(k)=dcos(k*phii1)
6340             sinph2(k)=dsin(k*phii1)
6341           enddo
6342         else
6343           phii1=0.0d0
6344           ityp3=ithetyp(itype(i,1))
6345           do k=1,nsingle
6346             cosph2(k)=0.0d0
6347             sinph2(k)=0.0d0
6348           enddo
6349         endif
6350         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6351         do k=1,ndouble
6352           do l=1,k-1
6353             ccl=cosph1(l)*cosph2(k-l)
6354             ssl=sinph1(l)*sinph2(k-l)
6355             scl=sinph1(l)*cosph2(k-l)
6356             csl=cosph1(l)*sinph2(k-l)
6357             cosph1ph2(l,k)=ccl-ssl
6358             cosph1ph2(k,l)=ccl+ssl
6359             sinph1ph2(l,k)=scl+csl
6360             sinph1ph2(k,l)=scl-csl
6361           enddo
6362         enddo
6363         if (lprn) then
6364         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6365           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6366         write (iout,*) "coskt and sinkt"
6367         do k=1,nntheterm
6368           write (iout,*) k,coskt(k),sinkt(k)
6369         enddo
6370         endif
6371         do k=1,ntheterm
6372           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6373           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6374             *coskt(k)
6375           if (lprn) &
6376           write (iout,*) "k",k,&
6377            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6378            " ethetai",ethetai
6379         enddo
6380         if (lprn) then
6381         write (iout,*) "cosph and sinph"
6382         do k=1,nsingle
6383           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6384         enddo
6385         write (iout,*) "cosph1ph2 and sinph2ph2"
6386         do k=2,ndouble
6387           do l=1,k-1
6388             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6389                sinph1ph2(l,k),sinph1ph2(k,l)
6390           enddo
6391         enddo
6392         write(iout,*) "ethetai",ethetai
6393         endif
6394         do m=1,ntheterm2
6395           do k=1,nsingle
6396             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6397                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6398                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6399                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6400             ethetai=ethetai+sinkt(m)*aux
6401             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6402             dephii=dephii+k*sinkt(m)* &
6403                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6404                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6405             dephii1=dephii1+k*sinkt(m)* &
6406                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6407                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6408             if (lprn) &
6409             write (iout,*) "m",m," k",k," bbthet", &
6410                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6411                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6412                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6413                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6414           enddo
6415         enddo
6416         if (lprn) &
6417         write(iout,*) "ethetai",ethetai
6418         do m=1,ntheterm3
6419           do k=2,ndouble
6420             do l=1,k-1
6421               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6422                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6423                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6424                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6425               ethetai=ethetai+sinkt(m)*aux
6426               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6427               dephii=dephii+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               dephii1=dephii1+(k-l)*sinkt(m)* &
6433                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6434                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6435                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6436                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6437               if (lprn) then
6438               write (iout,*) "m",m," k",k," l",l," ffthet",&
6439                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6440                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6441                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6442                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6443                   " ethetai",ethetai
6444               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6445                   cosph1ph2(k,l)*sinkt(m),&
6446                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6447               endif
6448             enddo
6449           enddo
6450         enddo
6451 10      continue
6452 !        lprn1=.true.
6453         if (lprn1) &
6454           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6455          i,theta(i)*rad2deg,phii*rad2deg,&
6456          phii1*rad2deg,ethetai
6457 !        lprn1=.false.
6458         etheta=etheta+ethetai
6459         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6460                                     'ebend',i,ethetai
6461         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6462         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6463         gloc(nphi+i-2,icg)=wang*dethetai
6464       enddo
6465 !-----------thete constrains
6466 !      if (tor_mode.ne.2) then
6467
6468       return
6469       end subroutine ebend
6470 #endif
6471 #ifdef CRYST_SC
6472 !-----------------------------------------------------------------------------
6473       subroutine esc(escloc)
6474 ! Calculate the local energy of a side chain and its derivatives in the
6475 ! corresponding virtual-bond valence angles THETA and the spherical angles
6476 ! ALPHA and OMEGA.
6477 !
6478       use comm_sccalc
6479 !      implicit real*8 (a-h,o-z)
6480 !      include 'DIMENSIONS'
6481 !      include 'COMMON.GEO'
6482 !      include 'COMMON.LOCAL'
6483 !      include 'COMMON.VAR'
6484 !      include 'COMMON.INTERACT'
6485 !      include 'COMMON.DERIV'
6486 !      include 'COMMON.CHAIN'
6487 !      include 'COMMON.IOUNITS'
6488 !      include 'COMMON.NAMES'
6489 !      include 'COMMON.FFIELD'
6490 !      include 'COMMON.CONTROL'
6491       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6492          ddersc0,ddummy,xtemp,temp
6493 !el      real(kind=8) :: time11,time12,time112,theti
6494       real(kind=8) :: escloc,delta
6495 !el      integer :: it,nlobit
6496 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6497 !el local variables
6498       integer :: i,k
6499       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6500        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6501       delta=0.02d0*pi
6502       escloc=0.0D0
6503 !     write (iout,'(a)') 'ESC'
6504       do i=loc_start,loc_end
6505         it=itype(i,1)
6506         if (it.eq.ntyp1) cycle
6507         if (it.eq.10) goto 1
6508         nlobit=nlob(iabs(it))
6509 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6510 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6511         theti=theta(i+1)-pipol
6512         x(1)=dtan(theti)
6513         x(2)=alph(i)
6514         x(3)=omeg(i)
6515
6516         if (x(2).gt.pi-delta) then
6517           xtemp(1)=x(1)
6518           xtemp(2)=pi-delta
6519           xtemp(3)=x(3)
6520           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6521           xtemp(2)=pi
6522           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6523           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6524               escloci,dersc(2))
6525           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6526               ddersc0(1),dersc(1))
6527           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6528               ddersc0(3),dersc(3))
6529           xtemp(2)=pi-delta
6530           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6531           xtemp(2)=pi
6532           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6533           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6534                   dersc0(2),esclocbi,dersc02)
6535           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6536                   dersc12,dersc01)
6537           call splinthet(x(2),0.5d0*delta,ss,ssd)
6538           dersc0(1)=dersc01
6539           dersc0(2)=dersc02
6540           dersc0(3)=0.0d0
6541           do k=1,3
6542             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6543           enddo
6544           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6545 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6546 !    &             esclocbi,ss,ssd
6547           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6548 !         escloci=esclocbi
6549 !         write (iout,*) escloci
6550         else if (x(2).lt.delta) then
6551           xtemp(1)=x(1)
6552           xtemp(2)=delta
6553           xtemp(3)=x(3)
6554           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6555           xtemp(2)=0.0d0
6556           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6557           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6558               escloci,dersc(2))
6559           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6560               ddersc0(1),dersc(1))
6561           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6562               ddersc0(3),dersc(3))
6563           xtemp(2)=delta
6564           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6565           xtemp(2)=0.0d0
6566           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6567           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6568                   dersc0(2),esclocbi,dersc02)
6569           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6570                   dersc12,dersc01)
6571           dersc0(1)=dersc01
6572           dersc0(2)=dersc02
6573           dersc0(3)=0.0d0
6574           call splinthet(x(2),0.5d0*delta,ss,ssd)
6575           do k=1,3
6576             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6577           enddo
6578           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6579 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6580 !    &             esclocbi,ss,ssd
6581           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6582 !         write (iout,*) escloci
6583         else
6584           call enesc(x,escloci,dersc,ddummy,.false.)
6585         endif
6586
6587         escloc=escloc+escloci
6588         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6589            'escloc',i,escloci
6590 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6591
6592         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6593          wscloc*dersc(1)
6594         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6595         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6596     1   continue
6597       enddo
6598       return
6599       end subroutine esc
6600 !-----------------------------------------------------------------------------
6601       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6602
6603       use comm_sccalc
6604 !      implicit real*8 (a-h,o-z)
6605 !      include 'DIMENSIONS'
6606 !      include 'COMMON.GEO'
6607 !      include 'COMMON.LOCAL'
6608 !      include 'COMMON.IOUNITS'
6609 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6610       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6611       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6612       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6613       real(kind=8) :: escloci
6614       logical :: mixed
6615 !el local variables
6616       integer :: j,iii,l,k !el,it,nlobit
6617       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6618 !el       time11,time12,time112
6619 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6620         escloc_i=0.0D0
6621         do j=1,3
6622           dersc(j)=0.0D0
6623           if (mixed) ddersc(j)=0.0d0
6624         enddo
6625         x3=x(3)
6626
6627 ! Because of periodicity of the dependence of the SC energy in omega we have
6628 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6629 ! To avoid underflows, first compute & store the exponents.
6630
6631         do iii=-1,1
6632
6633           x(3)=x3+iii*dwapi
6634
6635           do j=1,nlobit
6636             do k=1,3
6637               z(k)=x(k)-censc(k,j,it)
6638             enddo
6639             do k=1,3
6640               Axk=0.0D0
6641               do l=1,3
6642                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6643               enddo
6644               Ax(k,j,iii)=Axk
6645             enddo
6646             expfac=0.0D0
6647             do k=1,3
6648               expfac=expfac+Ax(k,j,iii)*z(k)
6649             enddo
6650             contr(j,iii)=expfac
6651           enddo ! j
6652
6653         enddo ! iii
6654
6655         x(3)=x3
6656 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6657 ! subsequent NaNs and INFs in energy calculation.
6658 ! Find the largest exponent
6659         emin=contr(1,-1)
6660         do iii=-1,1
6661           do j=1,nlobit
6662             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6663           enddo
6664         enddo
6665         emin=0.5D0*emin
6666 !d      print *,'it=',it,' emin=',emin
6667
6668 ! Compute the contribution to SC energy and derivatives
6669         do iii=-1,1
6670
6671           do j=1,nlobit
6672 #ifdef OSF
6673             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6674             if(adexp.ne.adexp) adexp=1.0
6675             expfac=dexp(adexp)
6676 #else
6677             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6678 #endif
6679 !d          print *,'j=',j,' expfac=',expfac
6680             escloc_i=escloc_i+expfac
6681             do k=1,3
6682               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6683             enddo
6684             if (mixed) then
6685               do k=1,3,2
6686                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6687                   +gaussc(k,2,j,it))*expfac
6688               enddo
6689             endif
6690           enddo
6691
6692         enddo ! iii
6693
6694         dersc(1)=dersc(1)/cos(theti)**2
6695         ddersc(1)=ddersc(1)/cos(theti)**2
6696         ddersc(3)=ddersc(3)
6697
6698         escloci=-(dlog(escloc_i)-emin)
6699         do j=1,3
6700           dersc(j)=dersc(j)/escloc_i
6701         enddo
6702         if (mixed) then
6703           do j=1,3,2
6704             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6705           enddo
6706         endif
6707       return
6708       end subroutine enesc
6709 !-----------------------------------------------------------------------------
6710       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6711
6712       use comm_sccalc
6713 !      implicit real*8 (a-h,o-z)
6714 !      include 'DIMENSIONS'
6715 !      include 'COMMON.GEO'
6716 !      include 'COMMON.LOCAL'
6717 !      include 'COMMON.IOUNITS'
6718 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6719       real(kind=8),dimension(3) :: x,z,dersc
6720       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6721       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6722       real(kind=8) :: escloci,dersc12,emin
6723       logical :: mixed
6724 !el local varables
6725       integer :: j,k,l !el,it,nlobit
6726       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6727
6728       escloc_i=0.0D0
6729
6730       do j=1,3
6731         dersc(j)=0.0D0
6732       enddo
6733
6734       do j=1,nlobit
6735         do k=1,2
6736           z(k)=x(k)-censc(k,j,it)
6737         enddo
6738         z(3)=dwapi
6739         do k=1,3
6740           Axk=0.0D0
6741           do l=1,3
6742             Axk=Axk+gaussc(l,k,j,it)*z(l)
6743           enddo
6744           Ax(k,j)=Axk
6745         enddo
6746         expfac=0.0D0
6747         do k=1,3
6748           expfac=expfac+Ax(k,j)*z(k)
6749         enddo
6750         contr(j)=expfac
6751       enddo ! j
6752
6753 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6754 ! subsequent NaNs and INFs in energy calculation.
6755 ! Find the largest exponent
6756       emin=contr(1)
6757       do j=1,nlobit
6758         if (emin.gt.contr(j)) emin=contr(j)
6759       enddo
6760       emin=0.5D0*emin
6761
6762 ! Compute the contribution to SC energy and derivatives
6763
6764       dersc12=0.0d0
6765       do j=1,nlobit
6766         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6767         escloc_i=escloc_i+expfac
6768         do k=1,2
6769           dersc(k)=dersc(k)+Ax(k,j)*expfac
6770         enddo
6771         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6772                   +gaussc(1,2,j,it))*expfac
6773         dersc(3)=0.0d0
6774       enddo
6775
6776       dersc(1)=dersc(1)/cos(theti)**2
6777       dersc12=dersc12/cos(theti)**2
6778       escloci=-(dlog(escloc_i)-emin)
6779       do j=1,2
6780         dersc(j)=dersc(j)/escloc_i
6781       enddo
6782       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6783       return
6784       end subroutine enesc_bound
6785 #else
6786 !-----------------------------------------------------------------------------
6787       subroutine esc(escloc)
6788 ! Calculate the local energy of a side chain and its derivatives in the
6789 ! corresponding virtual-bond valence angles THETA and the spherical angles
6790 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6791 ! added by Urszula Kozlowska. 07/11/2007
6792 !
6793       use comm_sccalc
6794 !      implicit real*8 (a-h,o-z)
6795 !      include 'DIMENSIONS'
6796 !      include 'COMMON.GEO'
6797 !      include 'COMMON.LOCAL'
6798 !      include 'COMMON.VAR'
6799 !      include 'COMMON.SCROT'
6800 !      include 'COMMON.INTERACT'
6801 !      include 'COMMON.DERIV'
6802 !      include 'COMMON.CHAIN'
6803 !      include 'COMMON.IOUNITS'
6804 !      include 'COMMON.NAMES'
6805 !      include 'COMMON.FFIELD'
6806 !      include 'COMMON.CONTROL'
6807 !      include 'COMMON.VECTORS'
6808       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6809       real(kind=8),dimension(65) :: x
6810       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6811          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6812       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6813       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6814          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6815 !el local variables
6816       integer :: i,j,k !el,it,nlobit
6817       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6818 !el      real(kind=8) :: time11,time12,time112,theti
6819 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6820       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6821                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6822                    sumene1x,sumene2x,sumene3x,sumene4x,&
6823                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6824                    cosfac2xx,sinfac2yy
6825 #ifdef DEBUG
6826       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6827                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6828                    de_dt_num
6829 #endif
6830 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6831
6832       delta=0.02d0*pi
6833       escloc=0.0D0
6834       do i=loc_start,loc_end
6835         if (itype(i,1).eq.ntyp1) cycle
6836         costtab(i+1) =dcos(theta(i+1))
6837         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6838         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6839         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6840         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6841         cosfac=dsqrt(cosfac2)
6842         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6843         sinfac=dsqrt(sinfac2)
6844         it=iabs(itype(i,1))
6845         if (it.eq.10) goto 1
6846 !
6847 !  Compute the axes of tghe local cartesian coordinates system; store in
6848 !   x_prime, y_prime and z_prime
6849 !
6850         do j=1,3
6851           x_prime(j) = 0.00
6852           y_prime(j) = 0.00
6853           z_prime(j) = 0.00
6854         enddo
6855 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6856 !     &   dc_norm(3,i+nres)
6857         do j = 1,3
6858           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6859           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6860         enddo
6861         do j = 1,3
6862           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6863         enddo
6864 !       write (2,*) "i",i
6865 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6866 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6867 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6868 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6869 !      & " xy",scalar(x_prime(1),y_prime(1)),
6870 !      & " xz",scalar(x_prime(1),z_prime(1)),
6871 !      & " yy",scalar(y_prime(1),y_prime(1)),
6872 !      & " yz",scalar(y_prime(1),z_prime(1)),
6873 !      & " zz",scalar(z_prime(1),z_prime(1))
6874 !
6875 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6876 ! to local coordinate system. Store in xx, yy, zz.
6877 !
6878         xx=0.0d0
6879         yy=0.0d0
6880         zz=0.0d0
6881         do j = 1,3
6882           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6883           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6884           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6885         enddo
6886
6887         xxtab(i)=xx
6888         yytab(i)=yy
6889         zztab(i)=zz
6890 !
6891 ! Compute the energy of the ith side cbain
6892 !
6893 !        write (2,*) "xx",xx," yy",yy," zz",zz
6894         it=iabs(itype(i,1))
6895         do j = 1,65
6896           x(j) = sc_parmin(j,it)
6897         enddo
6898 #ifdef CHECK_COORD
6899 !c diagnostics - remove later
6900         xx1 = dcos(alph(2))
6901         yy1 = dsin(alph(2))*dcos(omeg(2))
6902         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6903         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6904           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6905           xx1,yy1,zz1
6906 !,"  --- ", xx_w,yy_w,zz_w
6907 ! end diagnostics
6908 #endif
6909         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6910          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6911          + x(10)*yy*zz
6912         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6913          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6914          + x(20)*yy*zz
6915         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6916          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6917          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6918          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6919          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6920          +x(40)*xx*yy*zz
6921         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6922          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6923          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6924          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6925          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6926          +x(60)*xx*yy*zz
6927         dsc_i   = 0.743d0+x(61)
6928         dp2_i   = 1.9d0+x(62)
6929         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6930                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6931         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6932                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6933         s1=(1+x(63))/(0.1d0 + dscp1)
6934         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6935         s2=(1+x(65))/(0.1d0 + dscp2)
6936         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6937         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6938       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6939 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6940 !     &   sumene4,
6941 !     &   dscp1,dscp2,sumene
6942 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6943         escloc = escloc + sumene
6944 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6945 !     & ,zz,xx,yy
6946 !#define DEBUG
6947 #ifdef DEBUG
6948 !
6949 ! This section to check the numerical derivatives of the energy of ith side
6950 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6951 ! #define DEBUG in the code to turn it on.
6952 !
6953         write (2,*) "sumene               =",sumene
6954         aincr=1.0d-7
6955         xxsave=xx
6956         xx=xx+aincr
6957         write (2,*) xx,yy,zz
6958         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6959         de_dxx_num=(sumenep-sumene)/aincr
6960         xx=xxsave
6961         write (2,*) "xx+ sumene from enesc=",sumenep
6962         yysave=yy
6963         yy=yy+aincr
6964         write (2,*) xx,yy,zz
6965         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6966         de_dyy_num=(sumenep-sumene)/aincr
6967         yy=yysave
6968         write (2,*) "yy+ sumene from enesc=",sumenep
6969         zzsave=zz
6970         zz=zz+aincr
6971         write (2,*) xx,yy,zz
6972         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6973         de_dzz_num=(sumenep-sumene)/aincr
6974         zz=zzsave
6975         write (2,*) "zz+ sumene from enesc=",sumenep
6976         costsave=cost2tab(i+1)
6977         sintsave=sint2tab(i+1)
6978         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6979         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6980         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6981         de_dt_num=(sumenep-sumene)/aincr
6982         write (2,*) " t+ sumene from enesc=",sumenep
6983         cost2tab(i+1)=costsave
6984         sint2tab(i+1)=sintsave
6985 ! End of diagnostics section.
6986 #endif
6987 !
6988 ! Compute the gradient of esc
6989 !
6990 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6991         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6992         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6993         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6994         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6995         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6996         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6997         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6998         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6999         pom1=(sumene3*sint2tab(i+1)+sumene1) &
7000            *(pom_s1/dscp1+pom_s16*dscp1**4)
7001         pom2=(sumene4*cost2tab(i+1)+sumene2) &
7002            *(pom_s2/dscp2+pom_s26*dscp2**4)
7003         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7004         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7005         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7006         +x(40)*yy*zz
7007         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7008         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7009         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7010         +x(60)*yy*zz
7011         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7012               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7013               +(pom1+pom2)*pom_dx
7014 #ifdef DEBUG
7015         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7016 #endif
7017 !
7018         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7019         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7020         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7021         +x(40)*xx*zz
7022         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7023         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7024         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7025         +x(59)*zz**2 +x(60)*xx*zz
7026         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7027               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7028               +(pom1-pom2)*pom_dy
7029 #ifdef DEBUG
7030         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7031 #endif
7032 !
7033         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7034         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7035         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7036         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7037         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7038         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7039         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7040         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7041 #ifdef DEBUG
7042         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7043 #endif
7044 !
7045         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7046         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7047         +pom1*pom_dt1+pom2*pom_dt2
7048 #ifdef DEBUG
7049         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7050 #endif
7051 !
7052 !
7053        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7054        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7055        cosfac2xx=cosfac2*xx
7056        sinfac2yy=sinfac2*yy
7057        do k = 1,3
7058          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7059             vbld_inv(i+1)
7060          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7061             vbld_inv(i)
7062          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7063          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7064 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7065 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7066 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7067 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7068          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7069          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7070          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7071          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7072          dZZ_Ci1(k)=0.0d0
7073          dZZ_Ci(k)=0.0d0
7074          do j=1,3
7075            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7076            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7077            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7078            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7079          enddo
7080
7081          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7082          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7083          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7084          (z_prime(k)-zz*dC_norm(k,i+nres))
7085 !
7086          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7087          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7088        enddo
7089
7090        do k=1,3
7091          dXX_Ctab(k,i)=dXX_Ci(k)
7092          dXX_C1tab(k,i)=dXX_Ci1(k)
7093          dYY_Ctab(k,i)=dYY_Ci(k)
7094          dYY_C1tab(k,i)=dYY_Ci1(k)
7095          dZZ_Ctab(k,i)=dZZ_Ci(k)
7096          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7097          dXX_XYZtab(k,i)=dXX_XYZ(k)
7098          dYY_XYZtab(k,i)=dYY_XYZ(k)
7099          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7100        enddo
7101
7102        do k = 1,3
7103 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7104 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7105 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7106 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7107 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7108 !     &    dt_dci(k)
7109 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7110 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7111          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7112           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7113          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7114           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7115          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7116           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7117        enddo
7118 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7119 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7120
7121 ! to check gradient call subroutine check_grad
7122
7123     1 continue
7124       enddo
7125       return
7126       end subroutine esc
7127 !-----------------------------------------------------------------------------
7128       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7129 !      implicit none
7130       real(kind=8),dimension(65) :: x
7131       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7132         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7133
7134       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7135         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7136         + x(10)*yy*zz
7137       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7138         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7139         + x(20)*yy*zz
7140       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7141         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7142         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7143         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7144         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7145         +x(40)*xx*yy*zz
7146       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7147         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7148         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7149         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7150         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7151         +x(60)*xx*yy*zz
7152       dsc_i   = 0.743d0+x(61)
7153       dp2_i   = 1.9d0+x(62)
7154       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7155                 *(xx*cost2+yy*sint2))
7156       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7157                 *(xx*cost2-yy*sint2))
7158       s1=(1+x(63))/(0.1d0 + dscp1)
7159       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7160       s2=(1+x(65))/(0.1d0 + dscp2)
7161       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7162       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7163        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7164       enesc=sumene
7165       return
7166       end function enesc
7167 #endif
7168 !-----------------------------------------------------------------------------
7169       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7170 !
7171 ! This procedure calculates two-body contact function g(rij) and its derivative:
7172 !
7173 !           eps0ij                                     !       x < -1
7174 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7175 !            0                                         !       x > 1
7176 !
7177 ! where x=(rij-r0ij)/delta
7178 !
7179 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7180 !
7181 !      implicit none
7182       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7183       real(kind=8) :: x,x2,x4,delta
7184 !     delta=0.02D0*r0ij
7185 !      delta=0.2D0*r0ij
7186       x=(rij-r0ij)/delta
7187       if (x.lt.-1.0D0) then
7188         fcont=eps0ij
7189         fprimcont=0.0D0
7190       else if (x.le.1.0D0) then
7191         x2=x*x
7192         x4=x2*x2
7193         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7194         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7195       else
7196         fcont=0.0D0
7197         fprimcont=0.0D0
7198       endif
7199       return
7200       end subroutine gcont
7201 !-----------------------------------------------------------------------------
7202       subroutine splinthet(theti,delta,ss,ssder)
7203 !      implicit real*8 (a-h,o-z)
7204 !      include 'DIMENSIONS'
7205 !      include 'COMMON.VAR'
7206 !      include 'COMMON.GEO'
7207       real(kind=8) :: theti,delta,ss,ssder
7208       real(kind=8) :: thetup,thetlow
7209       thetup=pi-delta
7210       thetlow=delta
7211       if (theti.gt.pipol) then
7212         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7213       else
7214         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7215         ssder=-ssder
7216       endif
7217       return
7218       end subroutine splinthet
7219 !-----------------------------------------------------------------------------
7220       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7221 !      implicit none
7222       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7223       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7224       a1=fprim0*delta/(f1-f0)
7225       a2=3.0d0-2.0d0*a1
7226       a3=a1-2.0d0
7227       ksi=(x-x0)/delta
7228       ksi2=ksi*ksi
7229       ksi3=ksi2*ksi
7230       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7231       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7232       return
7233       end subroutine spline1
7234 !-----------------------------------------------------------------------------
7235       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7236 !      implicit none
7237       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7238       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7239       ksi=(x-x0)/delta
7240       ksi2=ksi*ksi
7241       ksi3=ksi2*ksi
7242       a1=fprim0x*delta
7243       a2=3*(f1x-f0x)-2*fprim0x*delta
7244       a3=fprim0x*delta-2*(f1x-f0x)
7245       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7246       return
7247       end subroutine spline2
7248 !-----------------------------------------------------------------------------
7249 #ifdef CRYST_TOR
7250 !-----------------------------------------------------------------------------
7251       subroutine etor(etors,edihcnstr)
7252 !      implicit real*8 (a-h,o-z)
7253 !      include 'DIMENSIONS'
7254 !      include 'COMMON.VAR'
7255 !      include 'COMMON.GEO'
7256 !      include 'COMMON.LOCAL'
7257 !      include 'COMMON.TORSION'
7258 !      include 'COMMON.INTERACT'
7259 !      include 'COMMON.DERIV'
7260 !      include 'COMMON.CHAIN'
7261 !      include 'COMMON.NAMES'
7262 !      include 'COMMON.IOUNITS'
7263 !      include 'COMMON.FFIELD'
7264 !      include 'COMMON.TORCNSTR'
7265 !      include 'COMMON.CONTROL'
7266       real(kind=8) :: etors,edihcnstr
7267       logical :: lprn
7268 !el local variables
7269       integer :: i,j,
7270       real(kind=8) :: phii,fac,etors_ii
7271
7272 ! Set lprn=.true. for debugging
7273       lprn=.false.
7274 !      lprn=.true.
7275       etors=0.0D0
7276       do i=iphi_start,iphi_end
7277       etors_ii=0.0D0
7278         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7279             .or. itype(i,1).eq.ntyp1) cycle
7280         itori=itortyp(itype(i-2,1))
7281         itori1=itortyp(itype(i-1,1))
7282         phii=phi(i)
7283         gloci=0.0D0
7284 ! Proline-Proline pair is a special case...
7285         if (itori.eq.3 .and. itori1.eq.3) then
7286           if (phii.gt.-dwapi3) then
7287             cosphi=dcos(3*phii)
7288             fac=1.0D0/(1.0D0-cosphi)
7289             etorsi=v1(1,3,3)*fac
7290             etorsi=etorsi+etorsi
7291             etors=etors+etorsi-v1(1,3,3)
7292             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7293             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7294           endif
7295           do j=1,3
7296             v1ij=v1(j+1,itori,itori1)
7297             v2ij=v2(j+1,itori,itori1)
7298             cosphi=dcos(j*phii)
7299             sinphi=dsin(j*phii)
7300             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7301             if (energy_dec) etors_ii=etors_ii+ &
7302                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7303             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7304           enddo
7305         else
7306           do j=1,nterm_old
7307             v1ij=v1(j,itori,itori1)
7308             v2ij=v2(j,itori,itori1)
7309             cosphi=dcos(j*phii)
7310             sinphi=dsin(j*phii)
7311             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7312             if (energy_dec) etors_ii=etors_ii+ &
7313                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7314             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7315           enddo
7316         endif
7317         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7318              'etor',i,etors_ii
7319         if (lprn) &
7320         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7321         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7322         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7323         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7324 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7325       enddo
7326 ! 6/20/98 - dihedral angle constraints
7327       edihcnstr=0.0d0
7328       do i=1,ndih_constr
7329         itori=idih_constr(i)
7330         phii=phi(itori)
7331         difi=phii-phi0(i)
7332         if (difi.gt.drange(i)) then
7333           difi=difi-drange(i)
7334           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7335           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7336         else if (difi.lt.-drange(i)) then
7337           difi=difi+drange(i)
7338           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7339           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7340         endif
7341 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7342 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7343       enddo
7344 !      write (iout,*) 'edihcnstr',edihcnstr
7345       return
7346       end subroutine etor
7347 !-----------------------------------------------------------------------------
7348       subroutine etor_d(etors_d)
7349       real(kind=8) :: etors_d
7350       etors_d=0.0d0
7351       return
7352       end subroutine etor_d
7353 #else
7354 !-----------------------------------------------------------------------------
7355       subroutine etor(etors)
7356 !      implicit real*8 (a-h,o-z)
7357 !      include 'DIMENSIONS'
7358 !      include 'COMMON.VAR'
7359 !      include 'COMMON.GEO'
7360 !      include 'COMMON.LOCAL'
7361 !      include 'COMMON.TORSION'
7362 !      include 'COMMON.INTERACT'
7363 !      include 'COMMON.DERIV'
7364 !      include 'COMMON.CHAIN'
7365 !      include 'COMMON.NAMES'
7366 !      include 'COMMON.IOUNITS'
7367 !      include 'COMMON.FFIELD'
7368 !      include 'COMMON.TORCNSTR'
7369 !      include 'COMMON.CONTROL'
7370       real(kind=8) :: etors,edihcnstr
7371       logical :: lprn
7372 !el local variables
7373       integer :: i,j,iblock,itori,itori1
7374       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7375                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7376 ! Set lprn=.true. for debugging
7377       lprn=.false.
7378 !     lprn=.true.
7379       etors=0.0D0
7380       do i=iphi_start,iphi_end
7381         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7382              .or. itype(i-3,1).eq.ntyp1 &
7383              .or. itype(i,1).eq.ntyp1) cycle
7384         etors_ii=0.0D0
7385          if (iabs(itype(i,1)).eq.20) then
7386          iblock=2
7387          else
7388          iblock=1
7389          endif
7390         itori=itortyp(itype(i-2,1))
7391         itori1=itortyp(itype(i-1,1))
7392         phii=phi(i)
7393         gloci=0.0D0
7394 ! Regular cosine and sine terms
7395         do j=1,nterm(itori,itori1,iblock)
7396           v1ij=v1(j,itori,itori1,iblock)
7397           v2ij=v2(j,itori,itori1,iblock)
7398           cosphi=dcos(j*phii)
7399           sinphi=dsin(j*phii)
7400           etors=etors+v1ij*cosphi+v2ij*sinphi
7401           if (energy_dec) etors_ii=etors_ii+ &
7402                      v1ij*cosphi+v2ij*sinphi
7403           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7404         enddo
7405 ! Lorentz terms
7406 !                         v1
7407 !  E = SUM ----------------------------------- - v1
7408 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7409 !
7410         cosphi=dcos(0.5d0*phii)
7411         sinphi=dsin(0.5d0*phii)
7412         do j=1,nlor(itori,itori1,iblock)
7413           vl1ij=vlor1(j,itori,itori1)
7414           vl2ij=vlor2(j,itori,itori1)
7415           vl3ij=vlor3(j,itori,itori1)
7416           pom=vl2ij*cosphi+vl3ij*sinphi
7417           pom1=1.0d0/(pom*pom+1.0d0)
7418           etors=etors+vl1ij*pom1
7419           if (energy_dec) etors_ii=etors_ii+ &
7420                      vl1ij*pom1
7421           pom=-pom*pom1*pom1
7422           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7423         enddo
7424 ! Subtract the constant term
7425         etors=etors-v0(itori,itori1,iblock)
7426           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7427                'etor',i,etors_ii-v0(itori,itori1,iblock)
7428         if (lprn) &
7429         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7430         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7431         (v1(j,itori,itori1,iblock),j=1,6),&
7432         (v2(j,itori,itori1,iblock),j=1,6)
7433         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7434 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7435       enddo
7436 ! 6/20/98 - dihedral angle constraints
7437       return
7438       end subroutine etor
7439 !C The rigorous attempt to derive energy function
7440 !-------------------------------------------------------------------------------------------
7441       subroutine etor_kcc(etors)
7442       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7443       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7444        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7445        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7446        gradvalst2,etori
7447       logical lprn
7448       integer :: i,j,itori,itori1,nval,k,l
7449
7450       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7451       etors=0.0D0
7452       do i=iphi_start,iphi_end
7453 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7454 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7455 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7456 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7457         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7458            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7459         itori=itortyp(itype(i-2,1))
7460         itori1=itortyp(itype(i-1,1))
7461         phii=phi(i)
7462         glocig=0.0D0
7463         glocit1=0.0d0
7464         glocit2=0.0d0
7465 !C to avoid multiple devision by 2
7466 !c        theti22=0.5d0*theta(i)
7467 !C theta 12 is the theta_1 /2
7468 !C theta 22 is theta_2 /2
7469 !c        theti12=0.5d0*theta(i-1)
7470 !C and appropriate sinus function
7471         sinthet1=dsin(theta(i-1))
7472         sinthet2=dsin(theta(i))
7473         costhet1=dcos(theta(i-1))
7474         costhet2=dcos(theta(i))
7475 !C to speed up lets store its mutliplication
7476         sint1t2=sinthet2*sinthet1
7477         sint1t2n=1.0d0
7478 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7479 !C +d_n*sin(n*gamma)) *
7480 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7481 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7482         nval=nterm_kcc_Tb(itori,itori1)
7483         c1(0)=0.0d0
7484         c2(0)=0.0d0
7485         c1(1)=1.0d0
7486         c2(1)=1.0d0
7487         do j=2,nval
7488           c1(j)=c1(j-1)*costhet1
7489           c2(j)=c2(j-1)*costhet2
7490         enddo
7491         etori=0.0d0
7492
7493        do j=1,nterm_kcc(itori,itori1)
7494           cosphi=dcos(j*phii)
7495           sinphi=dsin(j*phii)
7496           sint1t2n1=sint1t2n
7497           sint1t2n=sint1t2n*sint1t2
7498           sumvalc=0.0d0
7499           gradvalct1=0.0d0
7500           gradvalct2=0.0d0
7501           do k=1,nval
7502             do l=1,nval
7503               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7504               gradvalct1=gradvalct1+ &
7505                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7506               gradvalct2=gradvalct2+ &
7507                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7508             enddo
7509           enddo
7510           gradvalct1=-gradvalct1*sinthet1
7511           gradvalct2=-gradvalct2*sinthet2
7512           sumvals=0.0d0
7513           gradvalst1=0.0d0
7514           gradvalst2=0.0d0
7515           do k=1,nval
7516             do l=1,nval
7517               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7518               gradvalst1=gradvalst1+ &
7519                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7520               gradvalst2=gradvalst2+ &
7521                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7522             enddo
7523           enddo
7524           gradvalst1=-gradvalst1*sinthet1
7525           gradvalst2=-gradvalst2*sinthet2
7526           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7527           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7528 !C glocig is the gradient local i site in gamma
7529           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7530 !C now gradient over theta_1
7531          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7532         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7533          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7534         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7535         enddo ! j
7536         etors=etors+etori
7537         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7538 !C derivative over theta1
7539         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7540 !C now derivative over theta2
7541         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7542         if (lprn) then
7543          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7544             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7545           write (iout,*) "c1",(c1(k),k=0,nval), &
7546          " c2",(c2(k),k=0,nval)
7547         endif
7548       enddo
7549       return
7550        end  subroutine etor_kcc
7551 !------------------------------------------------------------------------------
7552
7553         subroutine etor_constr(edihcnstr)
7554       real(kind=8) :: etors,edihcnstr
7555       logical :: lprn
7556 !el local variables
7557       integer :: i,j,iblock,itori,itori1
7558       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7559                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7560                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7561
7562       if (raw_psipred) then
7563         do i=idihconstr_start,idihconstr_end
7564           itori=idih_constr(i)
7565           phii=phi(itori)
7566           gaudih_i=vpsipred(1,i)
7567           gauder_i=0.0d0
7568           do j=1,2
7569             s = sdihed(j,i)
7570             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7571             dexpcos_i=dexp(-cos_i*cos_i)
7572             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7573           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7574                  *cos_i*dexpcos_i/s**2
7575           enddo
7576           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7577           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7578           if (energy_dec) &
7579           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7580           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7581           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7582           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7583           -wdihc*dlog(gaudih_i)
7584         enddo
7585       else
7586
7587       do i=idihconstr_start,idihconstr_end
7588         itori=idih_constr(i)
7589         phii=phi(itori)
7590         difi=pinorm(phii-phi0(i))
7591         if (difi.gt.drange(i)) then
7592           difi=difi-drange(i)
7593           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7594           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7595         else if (difi.lt.-drange(i)) then
7596           difi=difi+drange(i)
7597           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7598           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7599         else
7600           difi=0.0
7601         endif
7602       enddo
7603
7604       endif
7605
7606       return
7607
7608       end subroutine etor_constr
7609 !-----------------------------------------------------------------------------
7610       subroutine etor_d(etors_d)
7611 ! 6/23/01 Compute double torsional energy
7612 !      implicit real*8 (a-h,o-z)
7613 !      include 'DIMENSIONS'
7614 !      include 'COMMON.VAR'
7615 !      include 'COMMON.GEO'
7616 !      include 'COMMON.LOCAL'
7617 !      include 'COMMON.TORSION'
7618 !      include 'COMMON.INTERACT'
7619 !      include 'COMMON.DERIV'
7620 !      include 'COMMON.CHAIN'
7621 !      include 'COMMON.NAMES'
7622 !      include 'COMMON.IOUNITS'
7623 !      include 'COMMON.FFIELD'
7624 !      include 'COMMON.TORCNSTR'
7625       real(kind=8) :: etors_d,etors_d_ii
7626       logical :: lprn
7627 !el local variables
7628       integer :: i,j,k,l,itori,itori1,itori2,iblock
7629       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7630                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7631                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7632                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7633 ! Set lprn=.true. for debugging
7634       lprn=.false.
7635 !     lprn=.true.
7636       etors_d=0.0D0
7637 !      write(iout,*) "a tu??"
7638       do i=iphid_start,iphid_end
7639         etors_d_ii=0.0D0
7640         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7641             .or. itype(i-3,1).eq.ntyp1 &
7642             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7643         itori=itortyp(itype(i-2,1))
7644         itori1=itortyp(itype(i-1,1))
7645         itori2=itortyp(itype(i,1))
7646         phii=phi(i)
7647         phii1=phi(i+1)
7648         gloci1=0.0D0
7649         gloci2=0.0D0
7650         iblock=1
7651         if (iabs(itype(i+1,1)).eq.20) iblock=2
7652
7653 ! Regular cosine and sine terms
7654         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7655           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7656           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7657           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7658           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7659           cosphi1=dcos(j*phii)
7660           sinphi1=dsin(j*phii)
7661           cosphi2=dcos(j*phii1)
7662           sinphi2=dsin(j*phii1)
7663           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7664            v2cij*cosphi2+v2sij*sinphi2
7665           if (energy_dec) etors_d_ii=etors_d_ii+ &
7666            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7667           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7668           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7669         enddo
7670         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7671           do l=1,k-1
7672             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7673             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7674             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7675             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7676             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7677             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7678             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7679             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7680             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7681               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7682             if (energy_dec) etors_d_ii=etors_d_ii+ &
7683               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7684               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7685             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7686               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7687             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7688               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7689           enddo
7690         enddo
7691         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7692                             'etor_d',i,etors_d_ii
7693         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7694         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7695       enddo
7696       return
7697       end subroutine etor_d
7698 #endif
7699
7700       subroutine ebend_kcc(etheta)
7701       logical lprn
7702       double precision thybt1(maxang_kcc),etheta
7703       integer :: i,iti,j,ihelp
7704       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7705 !C Set lprn=.true. for debugging
7706       lprn=energy_dec
7707 !c     lprn=.true.
7708 !C      print *,"wchodze kcc"
7709       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7710       etheta=0.0D0
7711       do i=ithet_start,ithet_end
7712 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7713         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7714        .or.itype(i,1).eq.ntyp1) cycle
7715         iti=iabs(itortyp(itype(i-1,1)))
7716         sinthet=dsin(theta(i))
7717         costhet=dcos(theta(i))
7718         do j=1,nbend_kcc_Tb(iti)
7719           thybt1(j)=v1bend_chyb(j,iti)
7720         enddo
7721         sumth1thyb=v1bend_chyb(0,iti)+ &
7722          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7723         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7724          sumth1thyb
7725         ihelp=nbend_kcc_Tb(iti)-1
7726         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7727         etheta=etheta+sumth1thyb
7728 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7729         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7730       enddo
7731       return
7732       end subroutine ebend_kcc
7733 !c------------
7734 !c-------------------------------------------------------------------------------------
7735       subroutine etheta_constr(ethetacnstr)
7736       real (kind=8) :: ethetacnstr,thetiii,difi
7737       integer :: i,itheta
7738       ethetacnstr=0.0d0
7739 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7740       do i=ithetaconstr_start,ithetaconstr_end
7741         itheta=itheta_constr(i)
7742         thetiii=theta(itheta)
7743         difi=pinorm(thetiii-theta_constr0(i))
7744         if (difi.gt.theta_drange(i)) then
7745           difi=difi-theta_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 if (difi.lt.-drange(i)) then
7750           difi=difi+drange(i)
7751           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7752           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7753           +for_thet_constr(i)*difi**3
7754         else
7755           difi=0.0
7756         endif
7757        if (energy_dec) then
7758         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7759          i,itheta,rad2deg*thetiii,&
7760          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7761          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7762          gloc(itheta+nphi-2,icg)
7763         endif
7764       enddo
7765       return
7766       end subroutine etheta_constr
7767
7768 !-----------------------------------------------------------------------------
7769       subroutine eback_sc_corr(esccor)
7770 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7771 !        conformational states; temporarily implemented as differences
7772 !        between UNRES torsional potentials (dependent on three types of
7773 !        residues) and the torsional potentials dependent on all 20 types
7774 !        of residues computed from AM1  energy surfaces of terminally-blocked
7775 !        amino-acid residues.
7776 !      implicit real*8 (a-h,o-z)
7777 !      include 'DIMENSIONS'
7778 !      include 'COMMON.VAR'
7779 !      include 'COMMON.GEO'
7780 !      include 'COMMON.LOCAL'
7781 !      include 'COMMON.TORSION'
7782 !      include 'COMMON.SCCOR'
7783 !      include 'COMMON.INTERACT'
7784 !      include 'COMMON.DERIV'
7785 !      include 'COMMON.CHAIN'
7786 !      include 'COMMON.NAMES'
7787 !      include 'COMMON.IOUNITS'
7788 !      include 'COMMON.FFIELD'
7789 !      include 'COMMON.CONTROL'
7790       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7791                    cosphi,sinphi
7792       logical :: lprn
7793       integer :: i,interty,j,isccori,isccori1,intertyp
7794 ! Set lprn=.true. for debugging
7795       lprn=.false.
7796 !      lprn=.true.
7797 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7798       esccor=0.0D0
7799       do i=itau_start,itau_end
7800         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7801         esccor_ii=0.0D0
7802         isccori=isccortyp(itype(i-2,1))
7803         isccori1=isccortyp(itype(i-1,1))
7804
7805 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7806         phii=phi(i)
7807         do intertyp=1,3 !intertyp
7808          esccor_ii=0.0D0
7809 !c Added 09 May 2012 (Adasko)
7810 !c  Intertyp means interaction type of backbone mainchain correlation:
7811 !   1 = SC...Ca...Ca...Ca
7812 !   2 = Ca...Ca...Ca...SC
7813 !   3 = SC...Ca...Ca...SCi
7814         gloci=0.0D0
7815         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7816             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7817             (itype(i-1,1).eq.ntyp1))) &
7818           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7819            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7820            .or.(itype(i,1).eq.ntyp1))) &
7821           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7822             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7823             (itype(i-3,1).eq.ntyp1)))) cycle
7824         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7825         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7826        cycle
7827        do j=1,nterm_sccor(isccori,isccori1)
7828           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7829           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7830           cosphi=dcos(j*tauangle(intertyp,i))
7831           sinphi=dsin(j*tauangle(intertyp,i))
7832           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7833           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7834           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7835         enddo
7836         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7837                                 'esccor',i,intertyp,esccor_ii
7838 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7839         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7840         if (lprn) &
7841         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7842         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7843         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7844         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7845         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7846        enddo !intertyp
7847       enddo
7848
7849       return
7850       end subroutine eback_sc_corr
7851 !-----------------------------------------------------------------------------
7852       subroutine multibody(ecorr)
7853 ! This subroutine calculates multi-body contributions to energy following
7854 ! the idea of Skolnick et al. If side chains I and J make a contact and
7855 ! at the same time side chains I+1 and J+1 make a contact, an extra
7856 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7857 !      implicit real*8 (a-h,o-z)
7858 !      include 'DIMENSIONS'
7859 !      include 'COMMON.IOUNITS'
7860 !      include 'COMMON.DERIV'
7861 !      include 'COMMON.INTERACT'
7862 !      include 'COMMON.CONTACTS'
7863       real(kind=8),dimension(3) :: gx,gx1
7864       logical :: lprn
7865       real(kind=8) :: ecorr
7866       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7867 ! Set lprn=.true. for debugging
7868       lprn=.false.
7869
7870       if (lprn) then
7871         write (iout,'(a)') 'Contact function values:'
7872         do i=nnt,nct-2
7873           write (iout,'(i2,20(1x,i2,f10.5))') &
7874               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7875         enddo
7876       endif
7877       ecorr=0.0D0
7878
7879 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7880 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7881       do i=nnt,nct
7882         do j=1,3
7883           gradcorr(j,i)=0.0D0
7884           gradxorr(j,i)=0.0D0
7885         enddo
7886       enddo
7887       do i=nnt,nct-2
7888
7889         DO ISHIFT = 3,4
7890
7891         i1=i+ishift
7892         num_conti=num_cont(i)
7893         num_conti1=num_cont(i1)
7894         do jj=1,num_conti
7895           j=jcont(jj,i)
7896           do kk=1,num_conti1
7897             j1=jcont(kk,i1)
7898             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7899 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7900 !d   &                   ' ishift=',ishift
7901 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7902 ! The system gains extra energy.
7903               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7904             endif   ! j1==j+-ishift
7905           enddo     ! kk
7906         enddo       ! jj
7907
7908         ENDDO ! ISHIFT
7909
7910       enddo         ! i
7911       return
7912       end subroutine multibody
7913 !-----------------------------------------------------------------------------
7914       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7915 !      implicit real*8 (a-h,o-z)
7916 !      include 'DIMENSIONS'
7917 !      include 'COMMON.IOUNITS'
7918 !      include 'COMMON.DERIV'
7919 !      include 'COMMON.INTERACT'
7920 !      include 'COMMON.CONTACTS'
7921       real(kind=8),dimension(3) :: gx,gx1
7922       logical :: lprn
7923       integer :: i,j,k,l,jj,kk,m,ll
7924       real(kind=8) :: eij,ekl
7925       lprn=.false.
7926       eij=facont(jj,i)
7927       ekl=facont(kk,k)
7928 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7929 ! Calculate the multi-body contribution to energy.
7930 ! Calculate multi-body contributions to the gradient.
7931 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7932 !d   & k,l,(gacont(m,kk,k),m=1,3)
7933       do m=1,3
7934         gx(m) =ekl*gacont(m,jj,i)
7935         gx1(m)=eij*gacont(m,kk,k)
7936         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7937         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7938         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7939         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7940       enddo
7941       do m=i,j-1
7942         do ll=1,3
7943           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7944         enddo
7945       enddo
7946       do m=k,l-1
7947         do ll=1,3
7948           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7949         enddo
7950       enddo
7951       esccorr=-eij*ekl
7952       return
7953       end function esccorr
7954 !-----------------------------------------------------------------------------
7955       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7956 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7957 !      implicit real*8 (a-h,o-z)
7958 !      include 'DIMENSIONS'
7959 !      include 'COMMON.IOUNITS'
7960 #ifdef MPI
7961       include "mpif.h"
7962 !      integer :: maxconts !max_cont=maxconts  =nres/4
7963       integer,parameter :: max_dim=26
7964       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7965       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7966 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7967 !el      common /przechowalnia/ zapas
7968       integer :: status(MPI_STATUS_SIZE)
7969       integer,dimension((nres/4)*2) :: req !maxconts*2
7970       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7971 #endif
7972 !      include 'COMMON.SETUP'
7973 !      include 'COMMON.FFIELD'
7974 !      include 'COMMON.DERIV'
7975 !      include 'COMMON.INTERACT'
7976 !      include 'COMMON.CONTACTS'
7977 !      include 'COMMON.CONTROL'
7978 !      include 'COMMON.LOCAL'
7979       real(kind=8),dimension(3) :: gx,gx1
7980       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7981       logical :: lprn,ldone
7982 !el local variables
7983       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7984               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7985
7986 ! Set lprn=.true. for debugging
7987       lprn=.false.
7988 #ifdef MPI
7989 !      maxconts=nres/4
7990       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7991       n_corr=0
7992       n_corr1=0
7993       if (nfgtasks.le.1) goto 30
7994       if (lprn) then
7995         write (iout,'(a)') 'Contact function values before RECEIVE:'
7996         do i=nnt,nct-2
7997           write (iout,'(2i3,50(1x,i2,f5.2))') &
7998           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7999           j=1,num_cont_hb(i))
8000         enddo
8001       endif
8002       call flush(iout)
8003       do i=1,ntask_cont_from
8004         ncont_recv(i)=0
8005       enddo
8006       do i=1,ntask_cont_to
8007         ncont_sent(i)=0
8008       enddo
8009 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8010 !     & ntask_cont_to
8011 ! Make the list of contacts to send to send to other procesors
8012 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8013 !      call flush(iout)
8014       do i=iturn3_start,iturn3_end
8015 !        write (iout,*) "make contact list turn3",i," num_cont",
8016 !     &    num_cont_hb(i)
8017         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8018       enddo
8019       do i=iturn4_start,iturn4_end
8020 !        write (iout,*) "make contact list turn4",i," num_cont",
8021 !     &   num_cont_hb(i)
8022         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8023       enddo
8024       do ii=1,nat_sent
8025         i=iat_sent(ii)
8026 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8027 !     &    num_cont_hb(i)
8028         do j=1,num_cont_hb(i)
8029         do k=1,4
8030           jjc=jcont_hb(j,i)
8031           iproc=iint_sent_local(k,jjc,ii)
8032 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8033           if (iproc.gt.0) then
8034             ncont_sent(iproc)=ncont_sent(iproc)+1
8035             nn=ncont_sent(iproc)
8036             zapas(1,nn,iproc)=i
8037             zapas(2,nn,iproc)=jjc
8038             zapas(3,nn,iproc)=facont_hb(j,i)
8039             zapas(4,nn,iproc)=ees0p(j,i)
8040             zapas(5,nn,iproc)=ees0m(j,i)
8041             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8042             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8043             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8044             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8045             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8046             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8047             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8048             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8049             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8050             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8051             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8052             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8053             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8054             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8055             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8056             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8057             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8058             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8059             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8060             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8061             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8062           endif
8063         enddo
8064         enddo
8065       enddo
8066       if (lprn) then
8067       write (iout,*) &
8068         "Numbers of contacts to be sent to other processors",&
8069         (ncont_sent(i),i=1,ntask_cont_to)
8070       write (iout,*) "Contacts sent"
8071       do ii=1,ntask_cont_to
8072         nn=ncont_sent(ii)
8073         iproc=itask_cont_to(ii)
8074         write (iout,*) nn," contacts to processor",iproc,&
8075          " of CONT_TO_COMM group"
8076         do i=1,nn
8077           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8078         enddo
8079       enddo
8080       call flush(iout)
8081       endif
8082       CorrelType=477
8083       CorrelID=fg_rank+1
8084       CorrelType1=478
8085       CorrelID1=nfgtasks+fg_rank+1
8086       ireq=0
8087 ! Receive the numbers of needed contacts from other processors
8088       do ii=1,ntask_cont_from
8089         iproc=itask_cont_from(ii)
8090         ireq=ireq+1
8091         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8092           FG_COMM,req(ireq),IERR)
8093       enddo
8094 !      write (iout,*) "IRECV ended"
8095 !      call flush(iout)
8096 ! Send the number of contacts needed by other processors
8097       do ii=1,ntask_cont_to
8098         iproc=itask_cont_to(ii)
8099         ireq=ireq+1
8100         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8101           FG_COMM,req(ireq),IERR)
8102       enddo
8103 !      write (iout,*) "ISEND ended"
8104 !      write (iout,*) "number of requests (nn)",ireq
8105       call flush(iout)
8106       if (ireq.gt.0) &
8107         call MPI_Waitall(ireq,req,status_array,ierr)
8108 !      write (iout,*)
8109 !     &  "Numbers of contacts to be received from other processors",
8110 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8111 !      call flush(iout)
8112 ! Receive contacts
8113       ireq=0
8114       do ii=1,ntask_cont_from
8115         iproc=itask_cont_from(ii)
8116         nn=ncont_recv(ii)
8117 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8118 !     &   " of CONT_TO_COMM group"
8119         call flush(iout)
8120         if (nn.gt.0) then
8121           ireq=ireq+1
8122           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8123           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8124 !          write (iout,*) "ireq,req",ireq,req(ireq)
8125         endif
8126       enddo
8127 ! Send the contacts to processors that need them
8128       do ii=1,ntask_cont_to
8129         iproc=itask_cont_to(ii)
8130         nn=ncont_sent(ii)
8131 !        write (iout,*) nn," contacts to processor",iproc,
8132 !     &   " of CONT_TO_COMM group"
8133         if (nn.gt.0) then
8134           ireq=ireq+1
8135           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8136             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8137 !          write (iout,*) "ireq,req",ireq,req(ireq)
8138 !          do i=1,nn
8139 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8140 !          enddo
8141         endif
8142       enddo
8143 !      write (iout,*) "number of requests (contacts)",ireq
8144 !      write (iout,*) "req",(req(i),i=1,4)
8145 !      call flush(iout)
8146       if (ireq.gt.0) &
8147        call MPI_Waitall(ireq,req,status_array,ierr)
8148       do iii=1,ntask_cont_from
8149         iproc=itask_cont_from(iii)
8150         nn=ncont_recv(iii)
8151         if (lprn) then
8152         write (iout,*) "Received",nn," contacts from processor",iproc,&
8153          " of CONT_FROM_COMM group"
8154         call flush(iout)
8155         do i=1,nn
8156           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8157         enddo
8158         call flush(iout)
8159         endif
8160         do i=1,nn
8161           ii=zapas_recv(1,i,iii)
8162 ! Flag the received contacts to prevent double-counting
8163           jj=-zapas_recv(2,i,iii)
8164 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8165 !          call flush(iout)
8166           nnn=num_cont_hb(ii)+1
8167           num_cont_hb(ii)=nnn
8168           jcont_hb(nnn,ii)=jj
8169           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8170           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8171           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8172           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8173           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8174           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8175           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8176           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8177           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8178           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8179           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8180           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8181           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8182           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8183           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8184           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8185           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8186           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8187           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8188           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8189           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8190           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8191           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8192           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8193         enddo
8194       enddo
8195       call flush(iout)
8196       if (lprn) then
8197         write (iout,'(a)') 'Contact function values after receive:'
8198         do i=nnt,nct-2
8199           write (iout,'(2i3,50(1x,i3,f5.2))') &
8200           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8201           j=1,num_cont_hb(i))
8202         enddo
8203         call flush(iout)
8204       endif
8205    30 continue
8206 #endif
8207       if (lprn) then
8208         write (iout,'(a)') 'Contact function values:'
8209         do i=nnt,nct-2
8210           write (iout,'(2i3,50(1x,i3,f5.2))') &
8211           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8212           j=1,num_cont_hb(i))
8213         enddo
8214       endif
8215       ecorr=0.0D0
8216
8217 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8218 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8219 ! Remove the loop below after debugging !!!
8220       do i=nnt,nct
8221         do j=1,3
8222           gradcorr(j,i)=0.0D0
8223           gradxorr(j,i)=0.0D0
8224         enddo
8225       enddo
8226 ! Calculate the local-electrostatic correlation terms
8227       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8228         i1=i+1
8229         num_conti=num_cont_hb(i)
8230         num_conti1=num_cont_hb(i+1)
8231         do jj=1,num_conti
8232           j=jcont_hb(jj,i)
8233           jp=iabs(j)
8234           do kk=1,num_conti1
8235             j1=jcont_hb(kk,i1)
8236             jp1=iabs(j1)
8237 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8238 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8239             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8240                 .or. j.lt.0 .and. j1.gt.0) .and. &
8241                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8242 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8243 ! The system gains extra energy.
8244               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8245               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8246                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8247               n_corr=n_corr+1
8248             else if (j1.eq.j) then
8249 ! Contacts I-J and I-(J+1) occur simultaneously.
8250 ! The system loses extra energy.
8251 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8252             endif
8253           enddo ! kk
8254           do kk=1,num_conti
8255             j1=jcont_hb(kk,i)
8256 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8257 !    &         ' jj=',jj,' kk=',kk
8258             if (j1.eq.j+1) then
8259 ! Contacts I-J and (I+1)-J occur simultaneously.
8260 ! The system loses extra energy.
8261 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8262             endif ! j1==j+1
8263           enddo ! kk
8264         enddo ! jj
8265       enddo ! i
8266       return
8267       end subroutine multibody_hb
8268 !-----------------------------------------------------------------------------
8269       subroutine add_hb_contact(ii,jj,itask)
8270 !      implicit real*8 (a-h,o-z)
8271 !      include "DIMENSIONS"
8272 !      include "COMMON.IOUNITS"
8273 !      include "COMMON.CONTACTS"
8274 !      integer,parameter :: maxconts=nres/4
8275       integer,parameter :: max_dim=26
8276       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8277 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8278 !      common /przechowalnia/ zapas
8279       integer :: i,j,ii,jj,iproc,nn,jjc
8280       integer,dimension(4) :: itask
8281 !      write (iout,*) "itask",itask
8282       do i=1,2
8283         iproc=itask(i)
8284         if (iproc.gt.0) then
8285           do j=1,num_cont_hb(ii)
8286             jjc=jcont_hb(j,ii)
8287 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8288             if (jjc.eq.jj) then
8289               ncont_sent(iproc)=ncont_sent(iproc)+1
8290               nn=ncont_sent(iproc)
8291               zapas(1,nn,iproc)=ii
8292               zapas(2,nn,iproc)=jjc
8293               zapas(3,nn,iproc)=facont_hb(j,ii)
8294               zapas(4,nn,iproc)=ees0p(j,ii)
8295               zapas(5,nn,iproc)=ees0m(j,ii)
8296               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8297               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8298               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8299               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8300               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8301               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8302               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8303               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8304               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8305               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8306               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8307               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8308               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8309               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8310               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8311               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8312               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8313               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8314               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8315               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8316               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8317               exit
8318             endif
8319           enddo
8320         endif
8321       enddo
8322       return
8323       end subroutine add_hb_contact
8324 !-----------------------------------------------------------------------------
8325       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8326 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8327 !      implicit real*8 (a-h,o-z)
8328 !      include 'DIMENSIONS'
8329 !      include 'COMMON.IOUNITS'
8330       integer,parameter :: max_dim=70
8331 #ifdef MPI
8332       include "mpif.h"
8333 !      integer :: maxconts !max_cont=maxconts=nres/4
8334       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8335       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8336 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8337 !      common /przechowalnia/ zapas
8338       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8339         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8340         ierr,iii,nnn
8341 #endif
8342 !      include 'COMMON.SETUP'
8343 !      include 'COMMON.FFIELD'
8344 !      include 'COMMON.DERIV'
8345 !      include 'COMMON.LOCAL'
8346 !      include 'COMMON.INTERACT'
8347 !      include 'COMMON.CONTACTS'
8348 !      include 'COMMON.CHAIN'
8349 !      include 'COMMON.CONTROL'
8350       real(kind=8),dimension(3) :: gx,gx1
8351       integer,dimension(nres) :: num_cont_hb_old
8352       logical :: lprn,ldone
8353 !EL      double precision eello4,eello5,eelo6,eello_turn6
8354 !EL      external eello4,eello5,eello6,eello_turn6
8355 !el local variables
8356       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8357               j1,jp1,i1,num_conti1
8358       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8359       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8360
8361 ! Set lprn=.true. for debugging
8362       lprn=.false.
8363       eturn6=0.0d0
8364 #ifdef MPI
8365 !      maxconts=nres/4
8366       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8367       do i=1,nres
8368         num_cont_hb_old(i)=num_cont_hb(i)
8369       enddo
8370       n_corr=0
8371       n_corr1=0
8372       if (nfgtasks.le.1) goto 30
8373       if (lprn) then
8374         write (iout,'(a)') 'Contact function values before RECEIVE:'
8375         do i=nnt,nct-2
8376           write (iout,'(2i3,50(1x,i2,f5.2))') &
8377           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8378           j=1,num_cont_hb(i))
8379         enddo
8380       endif
8381       call flush(iout)
8382       do i=1,ntask_cont_from
8383         ncont_recv(i)=0
8384       enddo
8385       do i=1,ntask_cont_to
8386         ncont_sent(i)=0
8387       enddo
8388 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8389 !     & ntask_cont_to
8390 ! Make the list of contacts to send to send to other procesors
8391       do i=iturn3_start,iturn3_end
8392 !        write (iout,*) "make contact list turn3",i," num_cont",
8393 !     &    num_cont_hb(i)
8394         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8395       enddo
8396       do i=iturn4_start,iturn4_end
8397 !        write (iout,*) "make contact list turn4",i," num_cont",
8398 !     &   num_cont_hb(i)
8399         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8400       enddo
8401       do ii=1,nat_sent
8402         i=iat_sent(ii)
8403 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8404 !     &    num_cont_hb(i)
8405         do j=1,num_cont_hb(i)
8406         do k=1,4
8407           jjc=jcont_hb(j,i)
8408           iproc=iint_sent_local(k,jjc,ii)
8409 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8410           if (iproc.ne.0) then
8411             ncont_sent(iproc)=ncont_sent(iproc)+1
8412             nn=ncont_sent(iproc)
8413             zapas(1,nn,iproc)=i
8414             zapas(2,nn,iproc)=jjc
8415             zapas(3,nn,iproc)=d_cont(j,i)
8416             ind=3
8417             do kk=1,3
8418               ind=ind+1
8419               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8420             enddo
8421             do kk=1,2
8422               do ll=1,2
8423                 ind=ind+1
8424                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8425               enddo
8426             enddo
8427             do jj=1,5
8428               do kk=1,3
8429                 do ll=1,2
8430                   do mm=1,2
8431                     ind=ind+1
8432                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8433                   enddo
8434                 enddo
8435               enddo
8436             enddo
8437           endif
8438         enddo
8439         enddo
8440       enddo
8441       if (lprn) then
8442       write (iout,*) &
8443         "Numbers of contacts to be sent to other processors",&
8444         (ncont_sent(i),i=1,ntask_cont_to)
8445       write (iout,*) "Contacts sent"
8446       do ii=1,ntask_cont_to
8447         nn=ncont_sent(ii)
8448         iproc=itask_cont_to(ii)
8449         write (iout,*) nn," contacts to processor",iproc,&
8450          " of CONT_TO_COMM group"
8451         do i=1,nn
8452           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8453         enddo
8454       enddo
8455       call flush(iout)
8456       endif
8457       CorrelType=477
8458       CorrelID=fg_rank+1
8459       CorrelType1=478
8460       CorrelID1=nfgtasks+fg_rank+1
8461       ireq=0
8462 ! Receive the numbers of needed contacts from other processors
8463       do ii=1,ntask_cont_from
8464         iproc=itask_cont_from(ii)
8465         ireq=ireq+1
8466         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8467           FG_COMM,req(ireq),IERR)
8468       enddo
8469 !      write (iout,*) "IRECV ended"
8470 !      call flush(iout)
8471 ! Send the number of contacts needed by other processors
8472       do ii=1,ntask_cont_to
8473         iproc=itask_cont_to(ii)
8474         ireq=ireq+1
8475         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8476           FG_COMM,req(ireq),IERR)
8477       enddo
8478 !      write (iout,*) "ISEND ended"
8479 !      write (iout,*) "number of requests (nn)",ireq
8480       call flush(iout)
8481       if (ireq.gt.0) &
8482         call MPI_Waitall(ireq,req,status_array,ierr)
8483 !      write (iout,*)
8484 !     &  "Numbers of contacts to be received from other processors",
8485 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8486 !      call flush(iout)
8487 ! Receive contacts
8488       ireq=0
8489       do ii=1,ntask_cont_from
8490         iproc=itask_cont_from(ii)
8491         nn=ncont_recv(ii)
8492 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8493 !     &   " of CONT_TO_COMM group"
8494         call flush(iout)
8495         if (nn.gt.0) then
8496           ireq=ireq+1
8497           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8498           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8499 !          write (iout,*) "ireq,req",ireq,req(ireq)
8500         endif
8501       enddo
8502 ! Send the contacts to processors that need them
8503       do ii=1,ntask_cont_to
8504         iproc=itask_cont_to(ii)
8505         nn=ncont_sent(ii)
8506 !        write (iout,*) nn," contacts to processor",iproc,
8507 !     &   " of CONT_TO_COMM group"
8508         if (nn.gt.0) then
8509           ireq=ireq+1
8510           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8511             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8512 !          write (iout,*) "ireq,req",ireq,req(ireq)
8513 !          do i=1,nn
8514 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8515 !          enddo
8516         endif
8517       enddo
8518 !      write (iout,*) "number of requests (contacts)",ireq
8519 !      write (iout,*) "req",(req(i),i=1,4)
8520 !      call flush(iout)
8521       if (ireq.gt.0) &
8522        call MPI_Waitall(ireq,req,status_array,ierr)
8523       do iii=1,ntask_cont_from
8524         iproc=itask_cont_from(iii)
8525         nn=ncont_recv(iii)
8526         if (lprn) then
8527         write (iout,*) "Received",nn," contacts from processor",iproc,&
8528          " of CONT_FROM_COMM group"
8529         call flush(iout)
8530         do i=1,nn
8531           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8532         enddo
8533         call flush(iout)
8534         endif
8535         do i=1,nn
8536           ii=zapas_recv(1,i,iii)
8537 ! Flag the received contacts to prevent double-counting
8538           jj=-zapas_recv(2,i,iii)
8539 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8540 !          call flush(iout)
8541           nnn=num_cont_hb(ii)+1
8542           num_cont_hb(ii)=nnn
8543           jcont_hb(nnn,ii)=jj
8544           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8545           ind=3
8546           do kk=1,3
8547             ind=ind+1
8548             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8549           enddo
8550           do kk=1,2
8551             do ll=1,2
8552               ind=ind+1
8553               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8554             enddo
8555           enddo
8556           do jj=1,5
8557             do kk=1,3
8558               do ll=1,2
8559                 do mm=1,2
8560                   ind=ind+1
8561                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8562                 enddo
8563               enddo
8564             enddo
8565           enddo
8566         enddo
8567       enddo
8568       call flush(iout)
8569       if (lprn) then
8570         write (iout,'(a)') 'Contact function values after receive:'
8571         do i=nnt,nct-2
8572           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8573           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8574           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8575         enddo
8576         call flush(iout)
8577       endif
8578    30 continue
8579 #endif
8580       if (lprn) then
8581         write (iout,'(a)') 'Contact function values:'
8582         do i=nnt,nct-2
8583           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8584           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8585           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8586         enddo
8587       endif
8588       ecorr=0.0D0
8589       ecorr5=0.0d0
8590       ecorr6=0.0d0
8591
8592 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8593 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8594 ! Remove the loop below after debugging !!!
8595       do i=nnt,nct
8596         do j=1,3
8597           gradcorr(j,i)=0.0D0
8598           gradxorr(j,i)=0.0D0
8599         enddo
8600       enddo
8601 ! Calculate the dipole-dipole interaction energies
8602       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8603       do i=iatel_s,iatel_e+1
8604         num_conti=num_cont_hb(i)
8605         do jj=1,num_conti
8606           j=jcont_hb(jj,i)
8607 #ifdef MOMENT
8608           call dipole(i,j,jj)
8609 #endif
8610         enddo
8611       enddo
8612       endif
8613 ! Calculate the local-electrostatic correlation terms
8614 !                write (iout,*) "gradcorr5 in eello5 before loop"
8615 !                do iii=1,nres
8616 !                  write (iout,'(i5,3f10.5)')
8617 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8618 !                enddo
8619       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8620 !        write (iout,*) "corr loop i",i
8621         i1=i+1
8622         num_conti=num_cont_hb(i)
8623         num_conti1=num_cont_hb(i+1)
8624         do jj=1,num_conti
8625           j=jcont_hb(jj,i)
8626           jp=iabs(j)
8627           do kk=1,num_conti1
8628             j1=jcont_hb(kk,i1)
8629             jp1=iabs(j1)
8630 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8631 !     &         ' jj=',jj,' kk=',kk
8632 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8633             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8634                 .or. j.lt.0 .and. j1.gt.0) .and. &
8635                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8636 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8637 ! The system gains extra energy.
8638               n_corr=n_corr+1
8639               sqd1=dsqrt(d_cont(jj,i))
8640               sqd2=dsqrt(d_cont(kk,i1))
8641               sred_geom = sqd1*sqd2
8642               IF (sred_geom.lt.cutoff_corr) THEN
8643                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8644                   ekont,fprimcont)
8645 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8646 !d     &         ' jj=',jj,' kk=',kk
8647                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8648                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8649                 do l=1,3
8650                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8651                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8652                 enddo
8653                 n_corr1=n_corr1+1
8654 !d               write (iout,*) 'sred_geom=',sred_geom,
8655 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8656 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8657 !d               write (iout,*) "g_contij",g_contij
8658 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8659 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8660                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8661                 if (wcorr4.gt.0.0d0) &
8662                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8663                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8664                        write (iout,'(a6,4i5,0pf7.3)') &
8665                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8666 !                write (iout,*) "gradcorr5 before eello5"
8667 !                do iii=1,nres
8668 !                  write (iout,'(i5,3f10.5)')
8669 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8670 !                enddo
8671                 if (wcorr5.gt.0.0d0) &
8672                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8673 !                write (iout,*) "gradcorr5 after eello5"
8674 !                do iii=1,nres
8675 !                  write (iout,'(i5,3f10.5)')
8676 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8677 !                enddo
8678                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8679                        write (iout,'(a6,4i5,0pf7.3)') &
8680                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8681 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8682 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8683                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8684                      .or. wturn6.eq.0.0d0))then
8685 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8686                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8687                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8688                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8689 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8690 !d     &            'ecorr6=',ecorr6
8691 !d                write (iout,'(4e15.5)') sred_geom,
8692 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8693 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8694 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8695                 else if (wturn6.gt.0.0d0 &
8696                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8697 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8698                   eturn6=eturn6+eello_turn6(i,jj,kk)
8699                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8700                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8701 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8702                 endif
8703               ENDIF
8704 1111          continue
8705             endif
8706           enddo ! kk
8707         enddo ! jj
8708       enddo ! i
8709       do i=1,nres
8710         num_cont_hb(i)=num_cont_hb_old(i)
8711       enddo
8712 !                write (iout,*) "gradcorr5 in eello5"
8713 !                do iii=1,nres
8714 !                  write (iout,'(i5,3f10.5)')
8715 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8716 !                enddo
8717       return
8718       end subroutine multibody_eello
8719 !-----------------------------------------------------------------------------
8720       subroutine add_hb_contact_eello(ii,jj,itask)
8721 !      implicit real*8 (a-h,o-z)
8722 !      include "DIMENSIONS"
8723 !      include "COMMON.IOUNITS"
8724 !      include "COMMON.CONTACTS"
8725 !      integer,parameter :: maxconts=nres/4
8726       integer,parameter :: max_dim=70
8727       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8728 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8729 !      common /przechowalnia/ zapas
8730
8731       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8732       integer,dimension(4) ::itask
8733 !      write (iout,*) "itask",itask
8734       do i=1,2
8735         iproc=itask(i)
8736         if (iproc.gt.0) then
8737           do j=1,num_cont_hb(ii)
8738             jjc=jcont_hb(j,ii)
8739 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8740             if (jjc.eq.jj) then
8741               ncont_sent(iproc)=ncont_sent(iproc)+1
8742               nn=ncont_sent(iproc)
8743               zapas(1,nn,iproc)=ii
8744               zapas(2,nn,iproc)=jjc
8745               zapas(3,nn,iproc)=d_cont(j,ii)
8746               ind=3
8747               do kk=1,3
8748                 ind=ind+1
8749                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8750               enddo
8751               do kk=1,2
8752                 do ll=1,2
8753                   ind=ind+1
8754                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8755                 enddo
8756               enddo
8757               do jj=1,5
8758                 do kk=1,3
8759                   do ll=1,2
8760                     do mm=1,2
8761                       ind=ind+1
8762                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8763                     enddo
8764                   enddo
8765                 enddo
8766               enddo
8767               exit
8768             endif
8769           enddo
8770         endif
8771       enddo
8772       return
8773       end subroutine add_hb_contact_eello
8774 !-----------------------------------------------------------------------------
8775       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8776 !      implicit real*8 (a-h,o-z)
8777 !      include 'DIMENSIONS'
8778 !      include 'COMMON.IOUNITS'
8779 !      include 'COMMON.DERIV'
8780 !      include 'COMMON.INTERACT'
8781 !      include 'COMMON.CONTACTS'
8782       real(kind=8),dimension(3) :: gx,gx1
8783       logical :: lprn
8784 !el local variables
8785       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8786       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8787                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8788                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8789                    rlocshield
8790
8791       lprn=.false.
8792       eij=facont_hb(jj,i)
8793       ekl=facont_hb(kk,k)
8794       ees0pij=ees0p(jj,i)
8795       ees0pkl=ees0p(kk,k)
8796       ees0mij=ees0m(jj,i)
8797       ees0mkl=ees0m(kk,k)
8798       ekont=eij*ekl
8799       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8800 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8801 ! Following 4 lines for diagnostics.
8802 !d    ees0pkl=0.0D0
8803 !d    ees0pij=1.0D0
8804 !d    ees0mkl=0.0D0
8805 !d    ees0mij=1.0D0
8806 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8807 !     & 'Contacts ',i,j,
8808 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8809 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8810 !     & 'gradcorr_long'
8811 ! Calculate the multi-body contribution to energy.
8812 !      ecorr=ecorr+ekont*ees
8813 ! Calculate multi-body contributions to the gradient.
8814       coeffpees0pij=coeffp*ees0pij
8815       coeffmees0mij=coeffm*ees0mij
8816       coeffpees0pkl=coeffp*ees0pkl
8817       coeffmees0mkl=coeffm*ees0mkl
8818       do ll=1,3
8819 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8820         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8821         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8822         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8823         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8824         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8825         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8826 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8827         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8828         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8829         coeffmees0mij*gacontm_hb1(ll,kk,k))
8830         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8831         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8832         coeffmees0mij*gacontm_hb2(ll,kk,k))
8833         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8834            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8835            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8836         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8837         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8838         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8839            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8840            coeffmees0mij*gacontm_hb3(ll,kk,k))
8841         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8842         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8843 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8844       enddo
8845 !      write (iout,*)
8846 !grad      do m=i+1,j-1
8847 !grad        do ll=1,3
8848 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8849 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8850 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8851 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8852 !grad        enddo
8853 !grad      enddo
8854 !grad      do m=k+1,l-1
8855 !grad        do ll=1,3
8856 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8857 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8858 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8859 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8860 !grad        enddo
8861 !grad      enddo
8862 !      write (iout,*) "ehbcorr",ekont*ees
8863       ehbcorr=ekont*ees
8864       if (shield_mode.gt.0) then
8865        j=ees0plist(jj,i)
8866        l=ees0plist(kk,k)
8867 !C        print *,i,j,fac_shield(i),fac_shield(j),
8868 !C     &fac_shield(k),fac_shield(l)
8869         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8870            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8871           do ilist=1,ishield_list(i)
8872            iresshield=shield_list(ilist,i)
8873            do m=1,3
8874            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8875            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8876                    rlocshield  &
8877             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8878             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8879             +rlocshield
8880            enddo
8881           enddo
8882           do ilist=1,ishield_list(j)
8883            iresshield=shield_list(ilist,j)
8884            do m=1,3
8885            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8886            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8887                    rlocshield &
8888             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8889            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8890             +rlocshield
8891            enddo
8892           enddo
8893
8894           do ilist=1,ishield_list(k)
8895            iresshield=shield_list(ilist,k)
8896            do m=1,3
8897            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8898            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8899                    rlocshield &
8900             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8901            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8902             +rlocshield
8903            enddo
8904           enddo
8905           do ilist=1,ishield_list(l)
8906            iresshield=shield_list(ilist,l)
8907            do m=1,3
8908            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8909            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8910                    rlocshield &
8911             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8912            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8913             +rlocshield
8914            enddo
8915           enddo
8916           do m=1,3
8917             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8918                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8919             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8920                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8921             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8922                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8923             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8924                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8925
8926             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8927                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8928             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8929                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8930             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8931                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8932             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8933                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8934
8935            enddo
8936       endif
8937       endif
8938       return
8939       end function ehbcorr
8940 #ifdef MOMENT
8941 !-----------------------------------------------------------------------------
8942       subroutine dipole(i,j,jj)
8943 !      implicit real*8 (a-h,o-z)
8944 !      include 'DIMENSIONS'
8945 !      include 'COMMON.IOUNITS'
8946 !      include 'COMMON.CHAIN'
8947 !      include 'COMMON.FFIELD'
8948 !      include 'COMMON.DERIV'
8949 !      include 'COMMON.INTERACT'
8950 !      include 'COMMON.CONTACTS'
8951 !      include 'COMMON.TORSION'
8952 !      include 'COMMON.VAR'
8953 !      include 'COMMON.GEO'
8954       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8955       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8956       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8957
8958       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8959       allocate(dipderx(3,5,4,maxconts,nres))
8960 !
8961
8962       iti1 = itortyp(itype(i+1,1))
8963       if (j.lt.nres-1) then
8964         itj1 = itype2loc(itype(j+1,1))
8965       else
8966         itj1=nloctyp
8967       endif
8968       do iii=1,2
8969         dipi(iii,1)=Ub2(iii,i)
8970         dipderi(iii)=Ub2der(iii,i)
8971         dipi(iii,2)=b1(iii,iti1)
8972         dipj(iii,1)=Ub2(iii,j)
8973         dipderj(iii)=Ub2der(iii,j)
8974         dipj(iii,2)=b1(iii,itj1)
8975       enddo
8976       kkk=0
8977       do iii=1,2
8978         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8979         do jjj=1,2
8980           kkk=kkk+1
8981           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8982         enddo
8983       enddo
8984       do kkk=1,5
8985         do lll=1,3
8986           mmm=0
8987           do iii=1,2
8988             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8989               auxvec(1))
8990             do jjj=1,2
8991               mmm=mmm+1
8992               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8993             enddo
8994           enddo
8995         enddo
8996       enddo
8997       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8998       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8999       do iii=1,2
9000         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9001       enddo
9002       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9003       do iii=1,2
9004         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9005       enddo
9006       return
9007       end subroutine dipole
9008 #endif
9009 !-----------------------------------------------------------------------------
9010       subroutine calc_eello(i,j,k,l,jj,kk)
9011 !
9012 ! This subroutine computes matrices and vectors needed to calculate
9013 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9014 !
9015       use comm_kut
9016 !      implicit real*8 (a-h,o-z)
9017 !      include 'DIMENSIONS'
9018 !      include 'COMMON.IOUNITS'
9019 !      include 'COMMON.CHAIN'
9020 !      include 'COMMON.DERIV'
9021 !      include 'COMMON.INTERACT'
9022 !      include 'COMMON.CONTACTS'
9023 !      include 'COMMON.TORSION'
9024 !      include 'COMMON.VAR'
9025 !      include 'COMMON.GEO'
9026 !      include 'COMMON.FFIELD'
9027       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9028       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9029       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9030               itj1
9031 !el      logical :: lprn
9032 !el      common /kutas/ lprn
9033 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9034 !d     & ' jj=',jj,' kk=',kk
9035 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9036 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9037 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9038       do iii=1,2
9039         do jjj=1,2
9040           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9041           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9042         enddo
9043       enddo
9044       call transpose2(aa1(1,1),aa1t(1,1))
9045       call transpose2(aa2(1,1),aa2t(1,1))
9046       do kkk=1,5
9047         do lll=1,3
9048           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9049             aa1tder(1,1,lll,kkk))
9050           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9051             aa2tder(1,1,lll,kkk))
9052         enddo
9053       enddo
9054       if (l.eq.j+1) then
9055 ! parallel orientation of the two CA-CA-CA frames.
9056         if (i.gt.1) then
9057           iti=itortyp(itype(i,1))
9058         else
9059           iti=ntortyp+1
9060         endif
9061         itk1=itortyp(itype(k+1,1))
9062         itj=itortyp(itype(j,1))
9063         if (l.lt.nres-1) then
9064           itl1=itortyp(itype(l+1,1))
9065         else
9066           itl1=ntortyp+1
9067         endif
9068 ! A1 kernel(j+1) A2T
9069 !d        do iii=1,2
9070 !d          write (iout,'(3f10.5,5x,3f10.5)')
9071 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9072 !d        enddo
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.,EUg(1,1,l),EUgder(1,1,l),&
9075          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9076 ! Following matrices are needed only for 6-th order cumulants
9077         IF (wcorr6.gt.0.0d0) THEN
9078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9079          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9080          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),&
9083          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9084          ADtEAderx(1,1,1,1,1,1))
9085         lprn=.false.
9086         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9087          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9088          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9089          ADtEA1derx(1,1,1,1,1,1))
9090         ENDIF
9091 ! End 6-th order cumulants
9092 !d        lprn=.false.
9093 !d        if (lprn) then
9094 !d        write (2,*) 'In calc_eello6'
9095 !d        do iii=1,2
9096 !d          write (2,*) 'iii=',iii
9097 !d          do kkk=1,5
9098 !d            write (2,*) 'kkk=',kkk
9099 !d            do jjj=1,2
9100 !d              write (2,'(3(2f10.5),5x)')
9101 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9102 !d            enddo
9103 !d          enddo
9104 !d        enddo
9105 !d        endif
9106         call transpose2(EUgder(1,1,k),auxmat(1,1))
9107         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9108         call transpose2(EUg(1,1,k),auxmat(1,1))
9109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9110         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9111         do iii=1,2
9112           do kkk=1,5
9113             do lll=1,3
9114               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9115                 EAEAderx(1,1,lll,kkk,iii,1))
9116             enddo
9117           enddo
9118         enddo
9119 ! A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),&
9122          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9123 ! Following matrices are needed only for 6-th order cumulants
9124         IF (wcorr6.gt.0.0d0) THEN
9125         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9126          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9127          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9128         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9129          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9130          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9131          ADtEAderx(1,1,1,1,1,2))
9132         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9133          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9134          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9135          ADtEA1derx(1,1,1,1,1,2))
9136         ENDIF
9137 ! End 6-th order cumulants
9138         call transpose2(EUgder(1,1,l),auxmat(1,1))
9139         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9140         call transpose2(EUg(1,1,l),auxmat(1,1))
9141         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9142         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9143         do iii=1,2
9144           do kkk=1,5
9145             do lll=1,3
9146               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9147                 EAEAderx(1,1,lll,kkk,iii,2))
9148             enddo
9149           enddo
9150         enddo
9151 ! AEAb1 and AEAb2
9152 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9153 ! They are needed only when the fifth- or the sixth-order cumulants are
9154 ! indluded.
9155         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9156         call transpose2(AEA(1,1,1),auxmat(1,1))
9157         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9158         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9159         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9160         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9161         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9163         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9164         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9165         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9166         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9167         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9168         call transpose2(AEA(1,1,2),auxmat(1,1))
9169         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9170         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9171         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9172         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9173         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9174         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9175         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9176         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9177         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9178         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9179         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9180 ! Calculate the Cartesian derivatives of the vectors.
9181         do iii=1,2
9182           do kkk=1,5
9183             do lll=1,3
9184               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9185               call matvec2(auxmat(1,1),b1(1,iti),&
9186                 AEAb1derx(1,lll,kkk,iii,1,1))
9187               call matvec2(auxmat(1,1),Ub2(1,i),&
9188                 AEAb2derx(1,lll,kkk,iii,1,1))
9189               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9190                 AEAb1derx(1,lll,kkk,iii,2,1))
9191               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9192                 AEAb2derx(1,lll,kkk,iii,2,1))
9193               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9194               call matvec2(auxmat(1,1),b1(1,itj),&
9195                 AEAb1derx(1,lll,kkk,iii,1,2))
9196               call matvec2(auxmat(1,1),Ub2(1,j),&
9197                 AEAb2derx(1,lll,kkk,iii,1,2))
9198               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9199                 AEAb1derx(1,lll,kkk,iii,2,2))
9200               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9201                 AEAb2derx(1,lll,kkk,iii,2,2))
9202             enddo
9203           enddo
9204         enddo
9205         ENDIF
9206 ! End vectors
9207       else
9208 ! Antiparallel orientation of the two CA-CA-CA frames.
9209         if (i.gt.1) then
9210           iti=itortyp(itype(i,1))
9211         else
9212           iti=ntortyp+1
9213         endif
9214         itk1=itortyp(itype(k+1,1))
9215         itl=itortyp(itype(l,1))
9216         itj=itortyp(itype(j,1))
9217         if (j.lt.nres-1) then
9218           itj1=itortyp(itype(j+1,1))
9219         else
9220           itj1=ntortyp+1
9221         endif
9222 ! A2 kernel(j-1)T A1T
9223         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9224          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9225          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9226 ! Following matrices are needed only for 6-th order cumulants
9227         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9228            j.eq.i+4 .and. l.eq.i+3)) THEN
9229         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9230          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9231          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9232         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9233          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9234          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9235          ADtEAderx(1,1,1,1,1,1))
9236         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9237          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9238          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9239          ADtEA1derx(1,1,1,1,1,1))
9240         ENDIF
9241 ! End 6-th order cumulants
9242         call transpose2(EUgder(1,1,k),auxmat(1,1))
9243         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9244         call transpose2(EUg(1,1,k),auxmat(1,1))
9245         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9246         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9247         do iii=1,2
9248           do kkk=1,5
9249             do lll=1,3
9250               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9251                 EAEAderx(1,1,lll,kkk,iii,1))
9252             enddo
9253           enddo
9254         enddo
9255 ! A2T kernel(i+1)T A1
9256         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9257          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9258          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9259 ! Following matrices are needed only for 6-th order cumulants
9260         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9261            j.eq.i+4 .and. l.eq.i+3)) THEN
9262         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9263          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9264          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9265         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9266          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9267          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9268          ADtEAderx(1,1,1,1,1,2))
9269         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9270          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9271          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9272          ADtEA1derx(1,1,1,1,1,2))
9273         ENDIF
9274 ! End 6-th order cumulants
9275         call transpose2(EUgder(1,1,j),auxmat(1,1))
9276         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9277         call transpose2(EUg(1,1,j),auxmat(1,1))
9278         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9279         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9280         do iii=1,2
9281           do kkk=1,5
9282             do lll=1,3
9283               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9284                 EAEAderx(1,1,lll,kkk,iii,2))
9285             enddo
9286           enddo
9287         enddo
9288 ! AEAb1 and AEAb2
9289 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9290 ! They are needed only when the fifth- or the sixth-order cumulants are
9291 ! indluded.
9292         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9293           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9294         call transpose2(AEA(1,1,1),auxmat(1,1))
9295         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9296         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9297         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9298         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9299         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9300         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9301         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9302         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9303         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9304         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9305         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9306         call transpose2(AEA(1,1,2),auxmat(1,1))
9307         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9308         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9309         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9310         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9311         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9312         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9313         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9314         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9315         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9316         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9317         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9318 ! Calculate the Cartesian derivatives of the vectors.
9319         do iii=1,2
9320           do kkk=1,5
9321             do lll=1,3
9322               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9323               call matvec2(auxmat(1,1),b1(1,iti),&
9324                 AEAb1derx(1,lll,kkk,iii,1,1))
9325               call matvec2(auxmat(1,1),Ub2(1,i),&
9326                 AEAb2derx(1,lll,kkk,iii,1,1))
9327               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9328                 AEAb1derx(1,lll,kkk,iii,2,1))
9329               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9330                 AEAb2derx(1,lll,kkk,iii,2,1))
9331               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9332               call matvec2(auxmat(1,1),b1(1,itl),&
9333                 AEAb1derx(1,lll,kkk,iii,1,2))
9334               call matvec2(auxmat(1,1),Ub2(1,l),&
9335                 AEAb2derx(1,lll,kkk,iii,1,2))
9336               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9337                 AEAb1derx(1,lll,kkk,iii,2,2))
9338               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9339                 AEAb2derx(1,lll,kkk,iii,2,2))
9340             enddo
9341           enddo
9342         enddo
9343         ENDIF
9344 ! End vectors
9345       endif
9346       return
9347       end subroutine calc_eello
9348 !-----------------------------------------------------------------------------
9349       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9350       use comm_kut
9351       implicit none
9352       integer :: nderg
9353       logical :: transp
9354       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9355       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9356       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9357       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9358       integer :: iii,kkk,lll
9359       integer :: jjj,mmm
9360 !el      logical :: lprn
9361 !el      common /kutas/ lprn
9362       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9363       do iii=1,nderg
9364         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9365           AKAderg(1,1,iii))
9366       enddo
9367 !d      if (lprn) write (2,*) 'In kernel'
9368       do kkk=1,5
9369 !d        if (lprn) write (2,*) 'kkk=',kkk
9370         do lll=1,3
9371           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9372             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9373 !d          if (lprn) then
9374 !d            write (2,*) 'lll=',lll
9375 !d            write (2,*) 'iii=1'
9376 !d            do jjj=1,2
9377 !d              write (2,'(3(2f10.5),5x)')
9378 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9379 !d            enddo
9380 !d          endif
9381           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9382             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9383 !d          if (lprn) then
9384 !d            write (2,*) 'lll=',lll
9385 !d            write (2,*) 'iii=2'
9386 !d            do jjj=1,2
9387 !d              write (2,'(3(2f10.5),5x)')
9388 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9389 !d            enddo
9390 !d          endif
9391         enddo
9392       enddo
9393       return
9394       end subroutine kernel
9395 !-----------------------------------------------------------------------------
9396       real(kind=8) function eello4(i,j,k,l,jj,kk)
9397 !      implicit real*8 (a-h,o-z)
9398 !      include 'DIMENSIONS'
9399 !      include 'COMMON.IOUNITS'
9400 !      include 'COMMON.CHAIN'
9401 !      include 'COMMON.DERIV'
9402 !      include 'COMMON.INTERACT'
9403 !      include 'COMMON.CONTACTS'
9404 !      include 'COMMON.TORSION'
9405 !      include 'COMMON.VAR'
9406 !      include 'COMMON.GEO'
9407       real(kind=8),dimension(2,2) :: pizda
9408       real(kind=8),dimension(3) :: ggg1,ggg2
9409       real(kind=8) ::  eel4,glongij,glongkl
9410       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9411 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9412 !d        eello4=0.0d0
9413 !d        return
9414 !d      endif
9415 !d      print *,'eello4:',i,j,k,l,jj,kk
9416 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9417 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9418 !old      eij=facont_hb(jj,i)
9419 !old      ekl=facont_hb(kk,k)
9420 !old      ekont=eij*ekl
9421       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9422 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9423       gcorr_loc(k-1)=gcorr_loc(k-1) &
9424          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9425       if (l.eq.j+1) then
9426         gcorr_loc(l-1)=gcorr_loc(l-1) &
9427            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9428       else
9429         gcorr_loc(j-1)=gcorr_loc(j-1) &
9430            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9431       endif
9432       do iii=1,2
9433         do kkk=1,5
9434           do lll=1,3
9435             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9436                               -EAEAderx(2,2,lll,kkk,iii,1)
9437 !d            derx(lll,kkk,iii)=0.0d0
9438           enddo
9439         enddo
9440       enddo
9441 !d      gcorr_loc(l-1)=0.0d0
9442 !d      gcorr_loc(j-1)=0.0d0
9443 !d      gcorr_loc(k-1)=0.0d0
9444 !d      eel4=1.0d0
9445 !d      write (iout,*)'Contacts have occurred for peptide groups',
9446 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9447 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9448       if (j.lt.nres-1) then
9449         j1=j+1
9450         j2=j-1
9451       else
9452         j1=j-1
9453         j2=j-2
9454       endif
9455       if (l.lt.nres-1) then
9456         l1=l+1
9457         l2=l-1
9458       else
9459         l1=l-1
9460         l2=l-2
9461       endif
9462       do ll=1,3
9463 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9464 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9465         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9466         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9467 !grad        ghalf=0.5d0*ggg1(ll)
9468         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9469         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9470         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9471         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9472         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9473         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9474 !grad        ghalf=0.5d0*ggg2(ll)
9475         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9476         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9477         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9478         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9479         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9480         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9481       enddo
9482 !grad      do m=i+1,j-1
9483 !grad        do ll=1,3
9484 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9485 !grad        enddo
9486 !grad      enddo
9487 !grad      do m=k+1,l-1
9488 !grad        do ll=1,3
9489 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9490 !grad        enddo
9491 !grad      enddo
9492 !grad      do m=i+2,j2
9493 !grad        do ll=1,3
9494 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9495 !grad        enddo
9496 !grad      enddo
9497 !grad      do m=k+2,l2
9498 !grad        do ll=1,3
9499 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9500 !grad        enddo
9501 !grad      enddo
9502 !d      do iii=1,nres-3
9503 !d        write (2,*) iii,gcorr_loc(iii)
9504 !d      enddo
9505       eello4=ekont*eel4
9506 !d      write (2,*) 'ekont',ekont
9507 !d      write (iout,*) 'eello4',ekont*eel4
9508       return
9509       end function eello4
9510 !-----------------------------------------------------------------------------
9511       real(kind=8) function eello5(i,j,k,l,jj,kk)
9512 !      implicit real*8 (a-h,o-z)
9513 !      include 'DIMENSIONS'
9514 !      include 'COMMON.IOUNITS'
9515 !      include 'COMMON.CHAIN'
9516 !      include 'COMMON.DERIV'
9517 !      include 'COMMON.INTERACT'
9518 !      include 'COMMON.CONTACTS'
9519 !      include 'COMMON.TORSION'
9520 !      include 'COMMON.VAR'
9521 !      include 'COMMON.GEO'
9522       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9523       real(kind=8),dimension(2) :: vv
9524       real(kind=8),dimension(3) :: ggg1,ggg2
9525       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9526       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9527       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9528 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9529 !                                                                              C
9530 !                            Parallel chains                                   C
9531 !                                                                              C
9532 !          o             o                   o             o                   C
9533 !         /l\           / \             \   / \           / \   /              C
9534 !        /   \         /   \             \ /   \         /   \ /               C
9535 !       j| o |l1       | o |                o| o |         | o |o                C
9536 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9537 !      \i/   \         /   \ /             /   \         /   \                 C
9538 !       o    k1             o                                                  C
9539 !         (I)          (II)                (III)          (IV)                 C
9540 !                                                                              C
9541 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9542 !                                                                              C
9543 !                            Antiparallel chains                               C
9544 !                                                                              C
9545 !          o             o                   o             o                   C
9546 !         /j\           / \             \   / \           / \   /              C
9547 !        /   \         /   \             \ /   \         /   \ /               C
9548 !      j1| o |l        | o |                o| o |         | o |o                C
9549 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9550 !      \i/   \         /   \ /             /   \         /   \                 C
9551 !       o     k1            o                                                  C
9552 !         (I)          (II)                (III)          (IV)                 C
9553 !                                                                              C
9554 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9555 !                                                                              C
9556 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9557 !                                                                              C
9558 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9559 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9560 !d        eello5=0.0d0
9561 !d        return
9562 !d      endif
9563 !d      write (iout,*)
9564 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9565 !d     &   ' and',k,l
9566       itk=itortyp(itype(k,1))
9567       itl=itortyp(itype(l,1))
9568       itj=itortyp(itype(j,1))
9569       eello5_1=0.0d0
9570       eello5_2=0.0d0
9571       eello5_3=0.0d0
9572       eello5_4=0.0d0
9573 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9574 !d     &   eel5_3_num,eel5_4_num)
9575       do iii=1,2
9576         do kkk=1,5
9577           do lll=1,3
9578             derx(lll,kkk,iii)=0.0d0
9579           enddo
9580         enddo
9581       enddo
9582 !d      eij=facont_hb(jj,i)
9583 !d      ekl=facont_hb(kk,k)
9584 !d      ekont=eij*ekl
9585 !d      write (iout,*)'Contacts have occurred for peptide groups',
9586 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9587 !d      goto 1111
9588 ! Contribution from the graph I.
9589 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9590 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9591       call transpose2(EUg(1,1,k),auxmat(1,1))
9592       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9593       vv(1)=pizda(1,1)-pizda(2,2)
9594       vv(2)=pizda(1,2)+pizda(2,1)
9595       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9596        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9597 ! Explicit gradient in virtual-dihedral angles.
9598       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9599        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9600        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9601       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9602       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9603       vv(1)=pizda(1,1)-pizda(2,2)
9604       vv(2)=pizda(1,2)+pizda(2,1)
9605       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9606        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9607        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9608       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9609       vv(1)=pizda(1,1)-pizda(2,2)
9610       vv(2)=pizda(1,2)+pizda(2,1)
9611       if (l.eq.j+1) then
9612         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9613          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9614          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9615       else
9616         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9617          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9618          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9619       endif
9620 ! Cartesian gradient
9621       do iii=1,2
9622         do kkk=1,5
9623           do lll=1,3
9624             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9625               pizda(1,1))
9626             vv(1)=pizda(1,1)-pizda(2,2)
9627             vv(2)=pizda(1,2)+pizda(2,1)
9628             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9629              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9630              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9631           enddo
9632         enddo
9633       enddo
9634 !      goto 1112
9635 !1111  continue
9636 ! Contribution from graph II
9637       call transpose2(EE(1,1,itk),auxmat(1,1))
9638       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9639       vv(1)=pizda(1,1)+pizda(2,2)
9640       vv(2)=pizda(2,1)-pizda(1,2)
9641       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9642        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9643 ! Explicit gradient in virtual-dihedral angles.
9644       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9645        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9646       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9647       vv(1)=pizda(1,1)+pizda(2,2)
9648       vv(2)=pizda(2,1)-pizda(1,2)
9649       if (l.eq.j+1) then
9650         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9651          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9652          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9653       else
9654         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9655          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9656          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9657       endif
9658 ! Cartesian gradient
9659       do iii=1,2
9660         do kkk=1,5
9661           do lll=1,3
9662             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9663               pizda(1,1))
9664             vv(1)=pizda(1,1)+pizda(2,2)
9665             vv(2)=pizda(2,1)-pizda(1,2)
9666             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9667              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9668              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9669           enddo
9670         enddo
9671       enddo
9672 !d      goto 1112
9673 !d1111  continue
9674       if (l.eq.j+1) then
9675 !d        goto 1110
9676 ! Parallel orientation
9677 ! Contribution from graph III
9678         call transpose2(EUg(1,1,l),auxmat(1,1))
9679         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9680         vv(1)=pizda(1,1)-pizda(2,2)
9681         vv(2)=pizda(1,2)+pizda(2,1)
9682         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9683          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9684 ! Explicit gradient in virtual-dihedral angles.
9685         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9686          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9687          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9688         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9689         vv(1)=pizda(1,1)-pizda(2,2)
9690         vv(2)=pizda(1,2)+pizda(2,1)
9691         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9692          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9693          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9694         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9695         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9696         vv(1)=pizda(1,1)-pizda(2,2)
9697         vv(2)=pizda(1,2)+pizda(2,1)
9698         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9699          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9700          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9701 ! Cartesian gradient
9702         do iii=1,2
9703           do kkk=1,5
9704             do lll=1,3
9705               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9706                 pizda(1,1))
9707               vv(1)=pizda(1,1)-pizda(2,2)
9708               vv(2)=pizda(1,2)+pizda(2,1)
9709               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9710                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9711                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9712             enddo
9713           enddo
9714         enddo
9715 !d        goto 1112
9716 ! Contribution from graph IV
9717 !d1110    continue
9718         call transpose2(EE(1,1,itl),auxmat(1,1))
9719         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9720         vv(1)=pizda(1,1)+pizda(2,2)
9721         vv(2)=pizda(2,1)-pizda(1,2)
9722         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9723          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9724 ! Explicit gradient in virtual-dihedral angles.
9725         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9726          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9727         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9728         vv(1)=pizda(1,1)+pizda(2,2)
9729         vv(2)=pizda(2,1)-pizda(1,2)
9730         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9731          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9732          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9733 ! Cartesian gradient
9734         do iii=1,2
9735           do kkk=1,5
9736             do lll=1,3
9737               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9738                 pizda(1,1))
9739               vv(1)=pizda(1,1)+pizda(2,2)
9740               vv(2)=pizda(2,1)-pizda(1,2)
9741               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9742                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9743                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9744             enddo
9745           enddo
9746         enddo
9747       else
9748 ! Antiparallel orientation
9749 ! Contribution from graph III
9750 !        goto 1110
9751         call transpose2(EUg(1,1,j),auxmat(1,1))
9752         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9753         vv(1)=pizda(1,1)-pizda(2,2)
9754         vv(2)=pizda(1,2)+pizda(2,1)
9755         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9756          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9757 ! Explicit gradient in virtual-dihedral angles.
9758         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9759          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9760          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9761         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9762         vv(1)=pizda(1,1)-pizda(2,2)
9763         vv(2)=pizda(1,2)+pizda(2,1)
9764         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9765          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9766          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9767         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9768         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9769         vv(1)=pizda(1,1)-pizda(2,2)
9770         vv(2)=pizda(1,2)+pizda(2,1)
9771         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9772          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9773          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9774 ! Cartesian gradient
9775         do iii=1,2
9776           do kkk=1,5
9777             do lll=1,3
9778               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9779                 pizda(1,1))
9780               vv(1)=pizda(1,1)-pizda(2,2)
9781               vv(2)=pizda(1,2)+pizda(2,1)
9782               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9783                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9784                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9785             enddo
9786           enddo
9787         enddo
9788 !d        goto 1112
9789 ! Contribution from graph IV
9790 1110    continue
9791         call transpose2(EE(1,1,itj),auxmat(1,1))
9792         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9793         vv(1)=pizda(1,1)+pizda(2,2)
9794         vv(2)=pizda(2,1)-pizda(1,2)
9795         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9796          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9797 ! Explicit gradient in virtual-dihedral angles.
9798         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9799          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9800         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9801         vv(1)=pizda(1,1)+pizda(2,2)
9802         vv(2)=pizda(2,1)-pizda(1,2)
9803         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9804          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9805          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9806 ! Cartesian gradient
9807         do iii=1,2
9808           do kkk=1,5
9809             do lll=1,3
9810               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9811                 pizda(1,1))
9812               vv(1)=pizda(1,1)+pizda(2,2)
9813               vv(2)=pizda(2,1)-pizda(1,2)
9814               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9815                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9816                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9817             enddo
9818           enddo
9819         enddo
9820       endif
9821 1112  continue
9822       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9823 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9824 !d        write (2,*) 'ijkl',i,j,k,l
9825 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9826 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9827 !d      endif
9828 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9829 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9830 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9831 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9832       if (j.lt.nres-1) then
9833         j1=j+1
9834         j2=j-1
9835       else
9836         j1=j-1
9837         j2=j-2
9838       endif
9839       if (l.lt.nres-1) then
9840         l1=l+1
9841         l2=l-1
9842       else
9843         l1=l-1
9844         l2=l-2
9845       endif
9846 !d      eij=1.0d0
9847 !d      ekl=1.0d0
9848 !d      ekont=1.0d0
9849 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9850 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9851 !        summed up outside the subrouine as for the other subroutines
9852 !        handling long-range interactions. The old code is commented out
9853 !        with "cgrad" to keep track of changes.
9854       do ll=1,3
9855 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9856 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9857         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9858         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9859 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9860 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9861 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9862 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9863 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9864 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9865 !     &   gradcorr5ij,
9866 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9867 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9868 !grad        ghalf=0.5d0*ggg1(ll)
9869 !d        ghalf=0.0d0
9870         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9871         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9872         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9873         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9874         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9875         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9876 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9877 !grad        ghalf=0.5d0*ggg2(ll)
9878         ghalf=0.0d0
9879         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9880         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9881         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9882         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9883         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9884         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9885       enddo
9886 !d      goto 1112
9887 !grad      do m=i+1,j-1
9888 !grad        do ll=1,3
9889 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9890 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9891 !grad        enddo
9892 !grad      enddo
9893 !grad      do m=k+1,l-1
9894 !grad        do ll=1,3
9895 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9896 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9897 !grad        enddo
9898 !grad      enddo
9899 !1112  continue
9900 !grad      do m=i+2,j2
9901 !grad        do ll=1,3
9902 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9903 !grad        enddo
9904 !grad      enddo
9905 !grad      do m=k+2,l2
9906 !grad        do ll=1,3
9907 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9908 !grad        enddo
9909 !grad      enddo
9910 !d      do iii=1,nres-3
9911 !d        write (2,*) iii,g_corr5_loc(iii)
9912 !d      enddo
9913       eello5=ekont*eel5
9914 !d      write (2,*) 'ekont',ekont
9915 !d      write (iout,*) 'eello5',ekont*eel5
9916       return
9917       end function eello5
9918 !-----------------------------------------------------------------------------
9919       real(kind=8) function eello6(i,j,k,l,jj,kk)
9920 !      implicit real*8 (a-h,o-z)
9921 !      include 'DIMENSIONS'
9922 !      include 'COMMON.IOUNITS'
9923 !      include 'COMMON.CHAIN'
9924 !      include 'COMMON.DERIV'
9925 !      include 'COMMON.INTERACT'
9926 !      include 'COMMON.CONTACTS'
9927 !      include 'COMMON.TORSION'
9928 !      include 'COMMON.VAR'
9929 !      include 'COMMON.GEO'
9930 !      include 'COMMON.FFIELD'
9931       real(kind=8),dimension(3) :: ggg1,ggg2
9932       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9933                    eello6_6,eel6
9934       real(kind=8) :: gradcorr6ij,gradcorr6kl
9935       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9936 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9937 !d        eello6=0.0d0
9938 !d        return
9939 !d      endif
9940 !d      write (iout,*)
9941 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9942 !d     &   ' and',k,l
9943       eello6_1=0.0d0
9944       eello6_2=0.0d0
9945       eello6_3=0.0d0
9946       eello6_4=0.0d0
9947       eello6_5=0.0d0
9948       eello6_6=0.0d0
9949 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9950 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9951       do iii=1,2
9952         do kkk=1,5
9953           do lll=1,3
9954             derx(lll,kkk,iii)=0.0d0
9955           enddo
9956         enddo
9957       enddo
9958 !d      eij=facont_hb(jj,i)
9959 !d      ekl=facont_hb(kk,k)
9960 !d      ekont=eij*ekl
9961 !d      eij=1.0d0
9962 !d      ekl=1.0d0
9963 !d      ekont=1.0d0
9964       if (l.eq.j+1) then
9965         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9966         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9967         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9968         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9969         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9970         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9971       else
9972         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9973         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9974         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9975         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9976         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9977           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9978         else
9979           eello6_5=0.0d0
9980         endif
9981         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9982       endif
9983 ! If turn contributions are considered, they will be handled separately.
9984       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9985 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9986 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9987 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9988 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9989 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9990 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9991 !d      goto 1112
9992       if (j.lt.nres-1) then
9993         j1=j+1
9994         j2=j-1
9995       else
9996         j1=j-1
9997         j2=j-2
9998       endif
9999       if (l.lt.nres-1) then
10000         l1=l+1
10001         l2=l-1
10002       else
10003         l1=l-1
10004         l2=l-2
10005       endif
10006       do ll=1,3
10007 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10008 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10009 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10010 !grad        ghalf=0.5d0*ggg1(ll)
10011 !d        ghalf=0.0d0
10012         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10013         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10014         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10015         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10016         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10017         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10018         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10019         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10020 !grad        ghalf=0.5d0*ggg2(ll)
10021 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10022 !d        ghalf=0.0d0
10023         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10024         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10025         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10026         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10027         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10028         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10029       enddo
10030 !d      goto 1112
10031 !grad      do m=i+1,j-1
10032 !grad        do ll=1,3
10033 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10034 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10035 !grad        enddo
10036 !grad      enddo
10037 !grad      do m=k+1,l-1
10038 !grad        do ll=1,3
10039 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10040 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10041 !grad        enddo
10042 !grad      enddo
10043 !grad1112  continue
10044 !grad      do m=i+2,j2
10045 !grad        do ll=1,3
10046 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10047 !grad        enddo
10048 !grad      enddo
10049 !grad      do m=k+2,l2
10050 !grad        do ll=1,3
10051 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10052 !grad        enddo
10053 !grad      enddo
10054 !d      do iii=1,nres-3
10055 !d        write (2,*) iii,g_corr6_loc(iii)
10056 !d      enddo
10057       eello6=ekont*eel6
10058 !d      write (2,*) 'ekont',ekont
10059 !d      write (iout,*) 'eello6',ekont*eel6
10060       return
10061       end function eello6
10062 !-----------------------------------------------------------------------------
10063       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10064       use comm_kut
10065 !      implicit real*8 (a-h,o-z)
10066 !      include 'DIMENSIONS'
10067 !      include 'COMMON.IOUNITS'
10068 !      include 'COMMON.CHAIN'
10069 !      include 'COMMON.DERIV'
10070 !      include 'COMMON.INTERACT'
10071 !      include 'COMMON.CONTACTS'
10072 !      include 'COMMON.TORSION'
10073 !      include 'COMMON.VAR'
10074 !      include 'COMMON.GEO'
10075       real(kind=8),dimension(2) :: vv,vv1
10076       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10077       logical :: swap
10078 !el      logical :: lprn
10079 !el      common /kutas/ lprn
10080       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10081       real(kind=8) :: s1,s2,s3,s4,s5
10082 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10083 !                                                                              C
10084 !      Parallel       Antiparallel                                             C
10085 !                                                                              C
10086 !          o             o                                                     C
10087 !         /l\           /j\                                                    C
10088 !        /   \         /   \                                                   C
10089 !       /| o |         | o |\                                                  C
10090 !     \ j|/k\|  /   \  |/k\|l /                                                C
10091 !      \ /   \ /     \ /   \ /                                                 C
10092 !       o     o       o     o                                                  C
10093 !       i             i                                                        C
10094 !                                                                              C
10095 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10096       itk=itortyp(itype(k,1))
10097       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10098       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10099       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10100       call transpose2(EUgC(1,1,k),auxmat(1,1))
10101       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10102       vv1(1)=pizda1(1,1)-pizda1(2,2)
10103       vv1(2)=pizda1(1,2)+pizda1(2,1)
10104       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10105       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10106       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10107       s5=scalar2(vv(1),Dtobr2(1,i))
10108 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10109       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10110       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10111        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10112        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10113        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10114        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10115        +scalar2(vv(1),Dtobr2der(1,i)))
10116       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10117       vv1(1)=pizda1(1,1)-pizda1(2,2)
10118       vv1(2)=pizda1(1,2)+pizda1(2,1)
10119       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10120       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10121       if (l.eq.j+1) then
10122         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10123        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10124        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10125        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10126        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10127       else
10128         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10129        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10130        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10131        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10132        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10133       endif
10134       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10135       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10136       vv1(1)=pizda1(1,1)-pizda1(2,2)
10137       vv1(2)=pizda1(1,2)+pizda1(2,1)
10138       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10139        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10140        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10141        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10142       do iii=1,2
10143         if (swap) then
10144           ind=3-iii
10145         else
10146           ind=iii
10147         endif
10148         do kkk=1,5
10149           do lll=1,3
10150             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10151             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10152             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10153             call transpose2(EUgC(1,1,k),auxmat(1,1))
10154             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10155               pizda1(1,1))
10156             vv1(1)=pizda1(1,1)-pizda1(2,2)
10157             vv1(2)=pizda1(1,2)+pizda1(2,1)
10158             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10159             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10160              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10161             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10162              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10163             s5=scalar2(vv(1),Dtobr2(1,i))
10164             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10165           enddo
10166         enddo
10167       enddo
10168       return
10169       end function eello6_graph1
10170 !-----------------------------------------------------------------------------
10171       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10172       use comm_kut
10173 !      implicit real*8 (a-h,o-z)
10174 !      include 'DIMENSIONS'
10175 !      include 'COMMON.IOUNITS'
10176 !      include 'COMMON.CHAIN'
10177 !      include 'COMMON.DERIV'
10178 !      include 'COMMON.INTERACT'
10179 !      include 'COMMON.CONTACTS'
10180 !      include 'COMMON.TORSION'
10181 !      include 'COMMON.VAR'
10182 !      include 'COMMON.GEO'
10183       logical :: swap
10184       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10185       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10186 !el      logical :: lprn
10187 !el      common /kutas/ lprn
10188       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10189       real(kind=8) :: s2,s3,s4
10190 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10191 !                                                                              C
10192 !      Parallel       Antiparallel                                             C
10193 !                                                                              C
10194 !          o             o                                                     C
10195 !     \   /l\           /j\   /                                                C
10196 !      \ /   \         /   \ /                                                 C
10197 !       o| o |         | o |o                                                  C
10198 !     \ j|/k\|      \  |/k\|l                                                  C
10199 !      \ /   \       \ /   \                                                   C
10200 !       o             o                                                        C
10201 !       i             i                                                        C
10202 !                                                                              C
10203 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10204 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10205 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10206 !           but not in a cluster cumulant
10207 #ifdef MOMENT
10208       s1=dip(1,jj,i)*dip(1,kk,k)
10209 #endif
10210       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10211       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10212       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10213       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10214       call transpose2(EUg(1,1,k),auxmat(1,1))
10215       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10216       vv(1)=pizda(1,1)-pizda(2,2)
10217       vv(2)=pizda(1,2)+pizda(2,1)
10218       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10219 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10220 #ifdef MOMENT
10221       eello6_graph2=-(s1+s2+s3+s4)
10222 #else
10223       eello6_graph2=-(s2+s3+s4)
10224 #endif
10225 !      eello6_graph2=-s3
10226 ! Derivatives in gamma(i-1)
10227       if (i.gt.1) then
10228 #ifdef MOMENT
10229         s1=dipderg(1,jj,i)*dip(1,kk,k)
10230 #endif
10231         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10232         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10233         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10234         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10235 #ifdef MOMENT
10236         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10237 #else
10238         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10239 #endif
10240 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10241       endif
10242 ! Derivatives in gamma(k-1)
10243 #ifdef MOMENT
10244       s1=dip(1,jj,i)*dipderg(1,kk,k)
10245 #endif
10246       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10247       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10248       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10249       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10250       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10251       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10252       vv(1)=pizda(1,1)-pizda(2,2)
10253       vv(2)=pizda(1,2)+pizda(2,1)
10254       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10255 #ifdef MOMENT
10256       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10257 #else
10258       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10259 #endif
10260 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10261 ! Derivatives in gamma(j-1) or gamma(l-1)
10262       if (j.gt.1) then
10263 #ifdef MOMENT
10264         s1=dipderg(3,jj,i)*dip(1,kk,k)
10265 #endif
10266         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10267         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10268         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10269         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10270         vv(1)=pizda(1,1)-pizda(2,2)
10271         vv(2)=pizda(1,2)+pizda(2,1)
10272         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10273 #ifdef MOMENT
10274         if (swap) then
10275           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10276         else
10277           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10278         endif
10279 #endif
10280         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10281 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10282       endif
10283 ! Derivatives in gamma(l-1) or gamma(j-1)
10284       if (l.gt.1) then
10285 #ifdef MOMENT
10286         s1=dip(1,jj,i)*dipderg(3,kk,k)
10287 #endif
10288         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10289         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10290         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10291         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10292         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10293         vv(1)=pizda(1,1)-pizda(2,2)
10294         vv(2)=pizda(1,2)+pizda(2,1)
10295         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10296 #ifdef MOMENT
10297         if (swap) then
10298           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10299         else
10300           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10301         endif
10302 #endif
10303         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10304 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10305       endif
10306 ! Cartesian derivatives.
10307       if (lprn) then
10308         write (2,*) 'In eello6_graph2'
10309         do iii=1,2
10310           write (2,*) 'iii=',iii
10311           do kkk=1,5
10312             write (2,*) 'kkk=',kkk
10313             do jjj=1,2
10314               write (2,'(3(2f10.5),5x)') &
10315               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10316             enddo
10317           enddo
10318         enddo
10319       endif
10320       do iii=1,2
10321         do kkk=1,5
10322           do lll=1,3
10323 #ifdef MOMENT
10324             if (iii.eq.1) then
10325               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10326             else
10327               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10328             endif
10329 #endif
10330             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10331               auxvec(1))
10332             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10333             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10334               auxvec(1))
10335             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10336             call transpose2(EUg(1,1,k),auxmat(1,1))
10337             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10338               pizda(1,1))
10339             vv(1)=pizda(1,1)-pizda(2,2)
10340             vv(2)=pizda(1,2)+pizda(2,1)
10341             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10342 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10343 #ifdef MOMENT
10344             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10345 #else
10346             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10347 #endif
10348             if (swap) then
10349               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10350             else
10351               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10352             endif
10353           enddo
10354         enddo
10355       enddo
10356       return
10357       end function eello6_graph2
10358 !-----------------------------------------------------------------------------
10359       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10360 !      implicit real*8 (a-h,o-z)
10361 !      include 'DIMENSIONS'
10362 !      include 'COMMON.IOUNITS'
10363 !      include 'COMMON.CHAIN'
10364 !      include 'COMMON.DERIV'
10365 !      include 'COMMON.INTERACT'
10366 !      include 'COMMON.CONTACTS'
10367 !      include 'COMMON.TORSION'
10368 !      include 'COMMON.VAR'
10369 !      include 'COMMON.GEO'
10370       real(kind=8),dimension(2) :: vv,auxvec
10371       real(kind=8),dimension(2,2) :: pizda,auxmat
10372       logical :: swap
10373       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10374       real(kind=8) :: s1,s2,s3,s4
10375 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10376 !                                                                              C
10377 !      Parallel       Antiparallel                                             C
10378 !                                                                              C
10379 !          o             o                                                     C
10380 !         /l\   /   \   /j\                                                    C
10381 !        /   \ /     \ /   \                                                   C
10382 !       /| o |o       o| o |\                                                  C
10383 !       j|/k\|  /      |/k\|l /                                                C
10384 !        /   \ /       /   \ /                                                 C
10385 !       /     o       /     o                                                  C
10386 !       i             i                                                        C
10387 !                                                                              C
10388 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10389 !
10390 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10391 !           energy moment and not to the cluster cumulant.
10392       iti=itortyp(itype(i,1))
10393       if (j.lt.nres-1) then
10394         itj1=itortyp(itype(j+1,1))
10395       else
10396         itj1=ntortyp+1
10397       endif
10398       itk=itortyp(itype(k,1))
10399       itk1=itortyp(itype(k+1,1))
10400       if (l.lt.nres-1) then
10401         itl1=itortyp(itype(l+1,1))
10402       else
10403         itl1=ntortyp+1
10404       endif
10405 #ifdef MOMENT
10406       s1=dip(4,jj,i)*dip(4,kk,k)
10407 #endif
10408       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10409       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10410       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10411       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10412       call transpose2(EE(1,1,itk),auxmat(1,1))
10413       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10414       vv(1)=pizda(1,1)+pizda(2,2)
10415       vv(2)=pizda(2,1)-pizda(1,2)
10416       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10417 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10418 !d     & "sum",-(s2+s3+s4)
10419 #ifdef MOMENT
10420       eello6_graph3=-(s1+s2+s3+s4)
10421 #else
10422       eello6_graph3=-(s2+s3+s4)
10423 #endif
10424 !      eello6_graph3=-s4
10425 ! Derivatives in gamma(k-1)
10426       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10427       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10428       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10429       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10430 ! Derivatives in gamma(l-1)
10431       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10432       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10433       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10434       vv(1)=pizda(1,1)+pizda(2,2)
10435       vv(2)=pizda(2,1)-pizda(1,2)
10436       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10437       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10438 ! Cartesian derivatives.
10439       do iii=1,2
10440         do kkk=1,5
10441           do lll=1,3
10442 #ifdef MOMENT
10443             if (iii.eq.1) then
10444               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10445             else
10446               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10447             endif
10448 #endif
10449             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10450               auxvec(1))
10451             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10452             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10453               auxvec(1))
10454             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10455             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10456               pizda(1,1))
10457             vv(1)=pizda(1,1)+pizda(2,2)
10458             vv(2)=pizda(2,1)-pizda(1,2)
10459             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10460 #ifdef MOMENT
10461             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10462 #else
10463             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10464 #endif
10465             if (swap) then
10466               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10467             else
10468               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10469             endif
10470 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10471           enddo
10472         enddo
10473       enddo
10474       return
10475       end function eello6_graph3
10476 !-----------------------------------------------------------------------------
10477       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10478 !      implicit real*8 (a-h,o-z)
10479 !      include 'DIMENSIONS'
10480 !      include 'COMMON.IOUNITS'
10481 !      include 'COMMON.CHAIN'
10482 !      include 'COMMON.DERIV'
10483 !      include 'COMMON.INTERACT'
10484 !      include 'COMMON.CONTACTS'
10485 !      include 'COMMON.TORSION'
10486 !      include 'COMMON.VAR'
10487 !      include 'COMMON.GEO'
10488 !      include 'COMMON.FFIELD'
10489       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10490       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10491       logical :: swap
10492       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10493               iii,kkk,lll
10494       real(kind=8) :: s1,s2,s3,s4
10495 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10496 !                                                                              C
10497 !      Parallel       Antiparallel                                             C
10498 !                                                                              C
10499 !          o             o                                                     C
10500 !         /l\   /   \   /j\                                                    C
10501 !        /   \ /     \ /   \                                                   C
10502 !       /| o |o       o| o |\                                                  C
10503 !     \ j|/k\|      \  |/k\|l                                                  C
10504 !      \ /   \       \ /   \                                                   C
10505 !       o     \       o     \                                                  C
10506 !       i             i                                                        C
10507 !                                                                              C
10508 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10509 !
10510 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10511 !           energy moment and not to the cluster cumulant.
10512 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10513       iti=itortyp(itype(i,1))
10514       itj=itortyp(itype(j,1))
10515       if (j.lt.nres-1) then
10516         itj1=itortyp(itype(j+1,1))
10517       else
10518         itj1=ntortyp+1
10519       endif
10520       itk=itortyp(itype(k,1))
10521       if (k.lt.nres-1) then
10522         itk1=itortyp(itype(k+1,1))
10523       else
10524         itk1=ntortyp+1
10525       endif
10526       itl=itortyp(itype(l,1))
10527       if (l.lt.nres-1) then
10528         itl1=itortyp(itype(l+1,1))
10529       else
10530         itl1=ntortyp+1
10531       endif
10532 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10533 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10534 !d     & ' itl',itl,' itl1',itl1
10535 #ifdef MOMENT
10536       if (imat.eq.1) then
10537         s1=dip(3,jj,i)*dip(3,kk,k)
10538       else
10539         s1=dip(2,jj,j)*dip(2,kk,l)
10540       endif
10541 #endif
10542       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10543       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10544       if (j.eq.l+1) then
10545         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10546         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10547       else
10548         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10549         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10550       endif
10551       call transpose2(EUg(1,1,k),auxmat(1,1))
10552       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10553       vv(1)=pizda(1,1)-pizda(2,2)
10554       vv(2)=pizda(2,1)+pizda(1,2)
10555       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10556 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10557 #ifdef MOMENT
10558       eello6_graph4=-(s1+s2+s3+s4)
10559 #else
10560       eello6_graph4=-(s2+s3+s4)
10561 #endif
10562 ! Derivatives in gamma(i-1)
10563       if (i.gt.1) then
10564 #ifdef MOMENT
10565         if (imat.eq.1) then
10566           s1=dipderg(2,jj,i)*dip(3,kk,k)
10567         else
10568           s1=dipderg(4,jj,j)*dip(2,kk,l)
10569         endif
10570 #endif
10571         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10572         if (j.eq.l+1) then
10573           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10574           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10575         else
10576           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10577           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10578         endif
10579         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10580         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10581 !d          write (2,*) 'turn6 derivatives'
10582 #ifdef MOMENT
10583           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10584 #else
10585           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10586 #endif
10587         else
10588 #ifdef MOMENT
10589           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10590 #else
10591           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10592 #endif
10593         endif
10594       endif
10595 ! Derivatives in gamma(k-1)
10596 #ifdef MOMENT
10597       if (imat.eq.1) then
10598         s1=dip(3,jj,i)*dipderg(2,kk,k)
10599       else
10600         s1=dip(2,jj,j)*dipderg(4,kk,l)
10601       endif
10602 #endif
10603       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10604       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10605       if (j.eq.l+1) then
10606         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10607         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10608       else
10609         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10610         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10611       endif
10612       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10613       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10614       vv(1)=pizda(1,1)-pizda(2,2)
10615       vv(2)=pizda(2,1)+pizda(1,2)
10616       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10617       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10618 #ifdef MOMENT
10619         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10620 #else
10621         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10622 #endif
10623       else
10624 #ifdef MOMENT
10625         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10626 #else
10627         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10628 #endif
10629       endif
10630 ! Derivatives in gamma(j-1) or gamma(l-1)
10631       if (l.eq.j+1 .and. l.gt.1) then
10632         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10633         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10634         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10635         vv(1)=pizda(1,1)-pizda(2,2)
10636         vv(2)=pizda(2,1)+pizda(1,2)
10637         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10638         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10639       else if (j.gt.1) then
10640         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10641         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10642         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10643         vv(1)=pizda(1,1)-pizda(2,2)
10644         vv(2)=pizda(2,1)+pizda(1,2)
10645         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10646         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10647           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10648         else
10649           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10650         endif
10651       endif
10652 ! Cartesian derivatives.
10653       do iii=1,2
10654         do kkk=1,5
10655           do lll=1,3
10656 #ifdef MOMENT
10657             if (iii.eq.1) then
10658               if (imat.eq.1) then
10659                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10660               else
10661                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10662               endif
10663             else
10664               if (imat.eq.1) then
10665                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10666               else
10667                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10668               endif
10669             endif
10670 #endif
10671             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10672               auxvec(1))
10673             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10674             if (j.eq.l+1) then
10675               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10676                 b1(1,itj1),auxvec(1))
10677               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10678             else
10679               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10680                 b1(1,itl1),auxvec(1))
10681               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10682             endif
10683             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10684               pizda(1,1))
10685             vv(1)=pizda(1,1)-pizda(2,2)
10686             vv(2)=pizda(2,1)+pizda(1,2)
10687             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10688             if (swap) then
10689               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10690 #ifdef MOMENT
10691                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10692                    -(s1+s2+s4)
10693 #else
10694                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10695                    -(s2+s4)
10696 #endif
10697                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10698               else
10699 #ifdef MOMENT
10700                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10701 #else
10702                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10703 #endif
10704                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10705               endif
10706             else
10707 #ifdef MOMENT
10708               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10709 #else
10710               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10711 #endif
10712               if (l.eq.j+1) then
10713                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10714               else
10715                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10716               endif
10717             endif
10718           enddo
10719         enddo
10720       enddo
10721       return
10722       end function eello6_graph4
10723 !-----------------------------------------------------------------------------
10724       real(kind=8) function eello_turn6(i,jj,kk)
10725 !      implicit real*8 (a-h,o-z)
10726 !      include 'DIMENSIONS'
10727 !      include 'COMMON.IOUNITS'
10728 !      include 'COMMON.CHAIN'
10729 !      include 'COMMON.DERIV'
10730 !      include 'COMMON.INTERACT'
10731 !      include 'COMMON.CONTACTS'
10732 !      include 'COMMON.TORSION'
10733 !      include 'COMMON.VAR'
10734 !      include 'COMMON.GEO'
10735       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10736       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10737       real(kind=8),dimension(3) :: ggg1,ggg2
10738       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10739       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10740 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10741 !           the respective energy moment and not to the cluster cumulant.
10742 !el local variables
10743       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10744       integer :: j1,j2,l1,l2,ll
10745       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10746       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10747       s1=0.0d0
10748       s8=0.0d0
10749       s13=0.0d0
10750 !
10751       eello_turn6=0.0d0
10752       j=i+4
10753       k=i+1
10754       l=i+3
10755       iti=itortyp(itype(i,1))
10756       itk=itortyp(itype(k,1))
10757       itk1=itortyp(itype(k+1,1))
10758       itl=itortyp(itype(l,1))
10759       itj=itortyp(itype(j,1))
10760 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10761 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10762 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10763 !d        eello6=0.0d0
10764 !d        return
10765 !d      endif
10766 !d      write (iout,*)
10767 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10768 !d     &   ' and',k,l
10769 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10770       do iii=1,2
10771         do kkk=1,5
10772           do lll=1,3
10773             derx_turn(lll,kkk,iii)=0.0d0
10774           enddo
10775         enddo
10776       enddo
10777 !d      eij=1.0d0
10778 !d      ekl=1.0d0
10779 !d      ekont=1.0d0
10780       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10781 !d      eello6_5=0.0d0
10782 !d      write (2,*) 'eello6_5',eello6_5
10783 #ifdef MOMENT
10784       call transpose2(AEA(1,1,1),auxmat(1,1))
10785       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10786       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10787       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10788 #endif
10789       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10790       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10791       s2 = scalar2(b1(1,itk),vtemp1(1))
10792 #ifdef MOMENT
10793       call transpose2(AEA(1,1,2),atemp(1,1))
10794       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10795       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10796       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10797 #endif
10798       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10799       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10800       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10801 #ifdef MOMENT
10802       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10803       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10804       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10805       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10806       ss13 = scalar2(b1(1,itk),vtemp4(1))
10807       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10808 #endif
10809 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10810 !      s1=0.0d0
10811 !      s2=0.0d0
10812 !      s8=0.0d0
10813 !      s12=0.0d0
10814 !      s13=0.0d0
10815       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10816 ! Derivatives in gamma(i+2)
10817       s1d =0.0d0
10818       s8d =0.0d0
10819 #ifdef MOMENT
10820       call transpose2(AEA(1,1,1),auxmatd(1,1))
10821       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10822       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10823       call transpose2(AEAderg(1,1,2),atempd(1,1))
10824       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10825       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10826 #endif
10827       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10828       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10829       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10830 !      s1d=0.0d0
10831 !      s2d=0.0d0
10832 !      s8d=0.0d0
10833 !      s12d=0.0d0
10834 !      s13d=0.0d0
10835       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10836 ! Derivatives in gamma(i+3)
10837 #ifdef MOMENT
10838       call transpose2(AEA(1,1,1),auxmatd(1,1))
10839       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10840       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10841       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10842 #endif
10843       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10844       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10845       s2d = scalar2(b1(1,itk),vtemp1d(1))
10846 #ifdef MOMENT
10847       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10848       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10849 #endif
10850       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10851 #ifdef MOMENT
10852       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10853       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10855 #endif
10856 !      s1d=0.0d0
10857 !      s2d=0.0d0
10858 !      s8d=0.0d0
10859 !      s12d=0.0d0
10860 !      s13d=0.0d0
10861 #ifdef MOMENT
10862       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10863                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10864 #else
10865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10866                     -0.5d0*ekont*(s2d+s12d)
10867 #endif
10868 ! Derivatives in gamma(i+4)
10869       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10870       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10871       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10872 #ifdef MOMENT
10873       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10874       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10875       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10876 #endif
10877 !      s1d=0.0d0
10878 !      s2d=0.0d0
10879 !      s8d=0.0d0
10880 !      s12d=0.0d0
10881 !      s13d=0.0d0
10882 #ifdef MOMENT
10883       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10884 #else
10885       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10886 #endif
10887 ! Derivatives in gamma(i+5)
10888 #ifdef MOMENT
10889       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10890       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10891       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10892 #endif
10893       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10894       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10895       s2d = scalar2(b1(1,itk),vtemp1d(1))
10896 #ifdef MOMENT
10897       call transpose2(AEA(1,1,2),atempd(1,1))
10898       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10899       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10900 #endif
10901       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10902       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10903 #ifdef MOMENT
10904       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10905       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10906       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10907 #endif
10908 !      s1d=0.0d0
10909 !      s2d=0.0d0
10910 !      s8d=0.0d0
10911 !      s12d=0.0d0
10912 !      s13d=0.0d0
10913 #ifdef MOMENT
10914       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10915                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10916 #else
10917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10918                     -0.5d0*ekont*(s2d+s12d)
10919 #endif
10920 ! Cartesian derivatives
10921       do iii=1,2
10922         do kkk=1,5
10923           do lll=1,3
10924 #ifdef MOMENT
10925             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10926             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10927             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10928 #endif
10929             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10930             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10931                 vtemp1d(1))
10932             s2d = scalar2(b1(1,itk),vtemp1d(1))
10933 #ifdef MOMENT
10934             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10935             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10936             s8d = -(atempd(1,1)+atempd(2,2))* &
10937                  scalar2(cc(1,1,itl),vtemp2(1))
10938 #endif
10939             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10940                  auxmatd(1,1))
10941             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10942             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10943 !      s1d=0.0d0
10944 !      s2d=0.0d0
10945 !      s8d=0.0d0
10946 !      s12d=0.0d0
10947 !      s13d=0.0d0
10948 #ifdef MOMENT
10949             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10950               - 0.5d0*(s1d+s2d)
10951 #else
10952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10953               - 0.5d0*s2d
10954 #endif
10955 #ifdef MOMENT
10956             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10957               - 0.5d0*(s8d+s12d)
10958 #else
10959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10960               - 0.5d0*s12d
10961 #endif
10962           enddo
10963         enddo
10964       enddo
10965 #ifdef MOMENT
10966       do kkk=1,5
10967         do lll=1,3
10968           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10969             achuj_tempd(1,1))
10970           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10971           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10972           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10973           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10974           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10975             vtemp4d(1))
10976           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10977           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10978           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10979         enddo
10980       enddo
10981 #endif
10982 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10983 !d     &  16*eel_turn6_num
10984 !d      goto 1112
10985       if (j.lt.nres-1) then
10986         j1=j+1
10987         j2=j-1
10988       else
10989         j1=j-1
10990         j2=j-2
10991       endif
10992       if (l.lt.nres-1) then
10993         l1=l+1
10994         l2=l-1
10995       else
10996         l1=l-1
10997         l2=l-2
10998       endif
10999       do ll=1,3
11000 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11001 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11002 !grad        ghalf=0.5d0*ggg1(ll)
11003 !d        ghalf=0.0d0
11004         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11005         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11006         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11007           +ekont*derx_turn(ll,2,1)
11008         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11009         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11010           +ekont*derx_turn(ll,4,1)
11011         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11012         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11013         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11014 !grad        ghalf=0.5d0*ggg2(ll)
11015 !d        ghalf=0.0d0
11016         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11017           +ekont*derx_turn(ll,2,2)
11018         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11019         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11020           +ekont*derx_turn(ll,4,2)
11021         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11022         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11023         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11024       enddo
11025 !d      goto 1112
11026 !grad      do m=i+1,j-1
11027 !grad        do ll=1,3
11028 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11029 !grad        enddo
11030 !grad      enddo
11031 !grad      do m=k+1,l-1
11032 !grad        do ll=1,3
11033 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11034 !grad        enddo
11035 !grad      enddo
11036 !grad1112  continue
11037 !grad      do m=i+2,j2
11038 !grad        do ll=1,3
11039 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11040 !grad        enddo
11041 !grad      enddo
11042 !grad      do m=k+2,l2
11043 !grad        do ll=1,3
11044 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11045 !grad        enddo
11046 !grad      enddo
11047 !d      do iii=1,nres-3
11048 !d        write (2,*) iii,g_corr6_loc(iii)
11049 !d      enddo
11050       eello_turn6=ekont*eel_turn6
11051 !d      write (2,*) 'ekont',ekont
11052 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11053       return
11054       end function eello_turn6
11055 !-----------------------------------------------------------------------------
11056       subroutine MATVEC2(A1,V1,V2)
11057 !DIR$ INLINEALWAYS MATVEC2
11058 #ifndef OSF
11059 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11060 #endif
11061 !      implicit real*8 (a-h,o-z)
11062 !      include 'DIMENSIONS'
11063       real(kind=8),dimension(2) :: V1,V2
11064       real(kind=8),dimension(2,2) :: A1
11065       real(kind=8) :: vaux1,vaux2
11066 !      DO 1 I=1,2
11067 !        VI=0.0
11068 !        DO 3 K=1,2
11069 !    3     VI=VI+A1(I,K)*V1(K)
11070 !        Vaux(I)=VI
11071 !    1 CONTINUE
11072
11073       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11074       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11075
11076       v2(1)=vaux1
11077       v2(2)=vaux2
11078       end subroutine MATVEC2
11079 !-----------------------------------------------------------------------------
11080       subroutine MATMAT2(A1,A2,A3)
11081 #ifndef OSF
11082 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11083 #endif
11084 !      implicit real*8 (a-h,o-z)
11085 !      include 'DIMENSIONS'
11086       real(kind=8),dimension(2,2) :: A1,A2,A3
11087       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11088 !      DIMENSION AI3(2,2)
11089 !        DO  J=1,2
11090 !          A3IJ=0.0
11091 !          DO K=1,2
11092 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11093 !          enddo
11094 !          A3(I,J)=A3IJ
11095 !       enddo
11096 !      enddo
11097
11098       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11099       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11100       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11101       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11102
11103       A3(1,1)=AI3_11
11104       A3(2,1)=AI3_21
11105       A3(1,2)=AI3_12
11106       A3(2,2)=AI3_22
11107       end subroutine MATMAT2
11108 !-----------------------------------------------------------------------------
11109       real(kind=8) function scalar2(u,v)
11110 !DIR$ INLINEALWAYS scalar2
11111       implicit none
11112       real(kind=8),dimension(2) :: u,v
11113       real(kind=8) :: sc
11114       integer :: i
11115       scalar2=u(1)*v(1)+u(2)*v(2)
11116       return
11117       end function scalar2
11118 !-----------------------------------------------------------------------------
11119       subroutine transpose2(a,at)
11120 !DIR$ INLINEALWAYS transpose2
11121 #ifndef OSF
11122 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11123 #endif
11124       implicit none
11125       real(kind=8),dimension(2,2) :: a,at
11126       at(1,1)=a(1,1)
11127       at(1,2)=a(2,1)
11128       at(2,1)=a(1,2)
11129       at(2,2)=a(2,2)
11130       return
11131       end subroutine transpose2
11132 !-----------------------------------------------------------------------------
11133       subroutine transpose(n,a,at)
11134       implicit none
11135       integer :: n,i,j
11136       real(kind=8),dimension(n,n) :: a,at
11137       do i=1,n
11138         do j=1,n
11139           at(j,i)=a(i,j)
11140         enddo
11141       enddo
11142       return
11143       end subroutine transpose
11144 !-----------------------------------------------------------------------------
11145       subroutine prodmat3(a1,a2,kk,transp,prod)
11146 !DIR$ INLINEALWAYS prodmat3
11147 #ifndef OSF
11148 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11149 #endif
11150       implicit none
11151       integer :: i,j
11152       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11153       logical :: transp
11154 !rc      double precision auxmat(2,2),prod_(2,2)
11155
11156       if (transp) then
11157 !rc        call transpose2(kk(1,1),auxmat(1,1))
11158 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11159 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11160
11161            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11162        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11163            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11164        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11165            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11166        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11167            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11168        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11169
11170       else
11171 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11172 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11173
11174            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11175         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11176            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11177         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11178            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11179         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11180            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11181         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11182
11183       endif
11184 !      call transpose2(a2(1,1),a2t(1,1))
11185
11186 !rc      print *,transp
11187 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11188 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11189
11190       return
11191       end subroutine prodmat3
11192 !-----------------------------------------------------------------------------
11193 ! energy_p_new_barrier.F
11194 !-----------------------------------------------------------------------------
11195       subroutine sum_gradient
11196 !      implicit real*8 (a-h,o-z)
11197       use io_base, only: pdbout
11198 !      include 'DIMENSIONS'
11199 #ifndef ISNAN
11200       external proc_proc
11201 #ifdef WINPGI
11202 !MS$ATTRIBUTES C ::  proc_proc
11203 #endif
11204 #endif
11205 #ifdef MPI
11206       include 'mpif.h'
11207 #endif
11208       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11209                    gloc_scbuf !(3,maxres)
11210
11211       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11212 !#endif
11213 !el local variables
11214       integer :: i,j,k,ierror,ierr
11215       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11216                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11217                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11218                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11219                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11220                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11221                    gsccorr_max,gsccorrx_max,time00
11222
11223 !      include 'COMMON.SETUP'
11224 !      include 'COMMON.IOUNITS'
11225 !      include 'COMMON.FFIELD'
11226 !      include 'COMMON.DERIV'
11227 !      include 'COMMON.INTERACT'
11228 !      include 'COMMON.SBRIDGE'
11229 !      include 'COMMON.CHAIN'
11230 !      include 'COMMON.VAR'
11231 !      include 'COMMON.CONTROL'
11232 !      include 'COMMON.TIME1'
11233 !      include 'COMMON.MAXGRAD'
11234 !      include 'COMMON.SCCOR'
11235 #ifdef TIMING
11236       time01=MPI_Wtime()
11237 #endif
11238 !#define DEBUG
11239 #ifdef DEBUG
11240       write (iout,*) "sum_gradient gvdwc, gvdwx"
11241       do i=1,nres
11242         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11243          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11244       enddo
11245       call flush(iout)
11246 #endif
11247 #ifdef MPI
11248         gradbufc=0.0d0
11249         gradbufx=0.0d0
11250         gradbufc_sum=0.0d0
11251         gloc_scbuf=0.0d0
11252         glocbuf=0.0d0
11253 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11254         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11255           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11256 #endif
11257 !
11258 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11259 !            in virtual-bond-vector coordinates
11260 !
11261 #ifdef DEBUG
11262 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11263 !      do i=1,nres-1
11264 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11265 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11266 !      enddo
11267 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11268 !      do i=1,nres-1
11269 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11270 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11271 !      enddo
11272 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11273 !      do i=1,nres
11274 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11275 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11276 !         (gvdwc_scpp(j,i),j=1,3)
11277 !      enddo
11278 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11279 !      do i=1,nres
11280 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11281 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11282 !         (gelc_loc_long(j,i),j=1,3)
11283 !      enddo
11284       call flush(iout)
11285 #endif
11286 #ifdef SPLITELE
11287       do i=0,nct
11288         do j=1,3
11289           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11290                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11291                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11292                       wel_loc*gel_loc_long(j,i)+ &
11293                       wcorr*gradcorr_long(j,i)+ &
11294                       wcorr5*gradcorr5_long(j,i)+ &
11295                       wcorr6*gradcorr6_long(j,i)+ &
11296                       wturn6*gcorr6_turn_long(j,i)+ &
11297                       wstrain*ghpbc(j,i) &
11298                      +wliptran*gliptranc(j,i) &
11299                      +gradafm(j,i) &
11300                      +welec*gshieldc(j,i) &
11301                      +wcorr*gshieldc_ec(j,i) &
11302                      +wturn3*gshieldc_t3(j,i)&
11303                      +wturn4*gshieldc_t4(j,i)&
11304                      +wel_loc*gshieldc_ll(j,i)&
11305                      +wtube*gg_tube(j,i) &
11306                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11307                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11308                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11309                      wcorr_nucl*gradcorr_nucl(j,i)&
11310                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11311                      wcatprot* gradpepcat(j,i)+ &
11312                      wcatcat*gradcatcat(j,i)+   &
11313                      wscbase*gvdwc_scbase(j,i)+ &
11314                      wpepbase*gvdwc_pepbase(j,i)+&
11315                      wscpho*gvdwc_scpho(j,i)+   &
11316                      wpeppho*gvdwc_peppho(j,i)
11317
11318
11319
11320
11321
11322         enddo
11323       enddo
11324 #else
11325       do i=0,nct
11326         do j=1,3
11327           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11328                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11329                       welec*gelc_long(j,i)+ &
11330                       wbond*gradb(j,i)+ &
11331                       wel_loc*gel_loc_long(j,i)+ &
11332                       wcorr*gradcorr_long(j,i)+ &
11333                       wcorr5*gradcorr5_long(j,i)+ &
11334                       wcorr6*gradcorr6_long(j,i)+ &
11335                       wturn6*gcorr6_turn_long(j,i)+ &
11336                       wstrain*ghpbc(j,i) &
11337                      +wliptran*gliptranc(j,i) &
11338                      +gradafm(j,i) &
11339                      +welec*gshieldc(j,i)&
11340                      +wcorr*gshieldc_ec(j,i) &
11341                      +wturn4*gshieldc_t4(j,i) &
11342                      +wel_loc*gshieldc_ll(j,i)&
11343                      +wtube*gg_tube(j,i) &
11344                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11345                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11346                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11347                      wcorr_nucl*gradcorr_nucl(j,i) &
11348                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11349                      wcatprot* gradpepcat(j,i)+ &
11350                      wcatcat*gradcatcat(j,i)+   &
11351                      wscbase*gvdwc_scbase(j,i)+ &
11352                      wpepbase*gvdwc_pepbase(j,i)+&
11353                      wscpho*gvdwc_scpho(j,i)+&
11354                      wpeppho*gvdwc_peppho(j,i)
11355
11356
11357         enddo
11358       enddo
11359 #endif
11360 #ifdef MPI
11361       if (nfgtasks.gt.1) then
11362       time00=MPI_Wtime()
11363 #ifdef DEBUG
11364       write (iout,*) "gradbufc before allreduce"
11365       do i=1,nres
11366         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11367       enddo
11368       call flush(iout)
11369 #endif
11370       do i=0,nres
11371         do j=1,3
11372           gradbufc_sum(j,i)=gradbufc(j,i)
11373         enddo
11374       enddo
11375 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11376 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11377 !      time_reduce=time_reduce+MPI_Wtime()-time00
11378 #ifdef DEBUG
11379 !      write (iout,*) "gradbufc_sum after allreduce"
11380 !      do i=1,nres
11381 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11382 !      enddo
11383 !      call flush(iout)
11384 #endif
11385 #ifdef TIMING
11386 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11387 #endif
11388       do i=0,nres
11389         do k=1,3
11390           gradbufc(k,i)=0.0d0
11391         enddo
11392       enddo
11393 #ifdef DEBUG
11394       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11395       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11396                         " jgrad_end  ",jgrad_end(i),&
11397                         i=igrad_start,igrad_end)
11398 #endif
11399 !
11400 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11401 ! do not parallelize this part.
11402 !
11403 !      do i=igrad_start,igrad_end
11404 !        do j=jgrad_start(i),jgrad_end(i)
11405 !          do k=1,3
11406 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11407 !          enddo
11408 !        enddo
11409 !      enddo
11410       do j=1,3
11411         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11412       enddo
11413       do i=nres-2,-1,-1
11414         do j=1,3
11415           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11416         enddo
11417       enddo
11418 #ifdef DEBUG
11419       write (iout,*) "gradbufc after summing"
11420       do i=1,nres
11421         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11422       enddo
11423       call flush(iout)
11424 #endif
11425       else
11426 #endif
11427 !el#define DEBUG
11428 #ifdef DEBUG
11429       write (iout,*) "gradbufc"
11430       do i=1,nres
11431         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11432       enddo
11433       call flush(iout)
11434 #endif
11435 !el#undef DEBUG
11436       do i=-1,nres
11437         do j=1,3
11438           gradbufc_sum(j,i)=gradbufc(j,i)
11439           gradbufc(j,i)=0.0d0
11440         enddo
11441       enddo
11442       do j=1,3
11443         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11444       enddo
11445       do i=nres-2,-1,-1
11446         do j=1,3
11447           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11448         enddo
11449       enddo
11450 !      do i=nnt,nres-1
11451 !        do k=1,3
11452 !          gradbufc(k,i)=0.0d0
11453 !        enddo
11454 !        do j=i+1,nres
11455 !          do k=1,3
11456 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11457 !          enddo
11458 !        enddo
11459 !      enddo
11460 !el#define DEBUG
11461 #ifdef DEBUG
11462       write (iout,*) "gradbufc after summing"
11463       do i=1,nres
11464         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11465       enddo
11466       call flush(iout)
11467 #endif
11468 !el#undef DEBUG
11469 #ifdef MPI
11470       endif
11471 #endif
11472       do k=1,3
11473         gradbufc(k,nres)=0.0d0
11474       enddo
11475 !el----------------
11476 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11477 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11478 !el-----------------
11479       do i=-1,nct
11480         do j=1,3
11481 #ifdef SPLITELE
11482           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11483                       wel_loc*gel_loc(j,i)+ &
11484                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11485                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11486                       wel_loc*gel_loc_long(j,i)+ &
11487                       wcorr*gradcorr_long(j,i)+ &
11488                       wcorr5*gradcorr5_long(j,i)+ &
11489                       wcorr6*gradcorr6_long(j,i)+ &
11490                       wturn6*gcorr6_turn_long(j,i))+ &
11491                       wbond*gradb(j,i)+ &
11492                       wcorr*gradcorr(j,i)+ &
11493                       wturn3*gcorr3_turn(j,i)+ &
11494                       wturn4*gcorr4_turn(j,i)+ &
11495                       wcorr5*gradcorr5(j,i)+ &
11496                       wcorr6*gradcorr6(j,i)+ &
11497                       wturn6*gcorr6_turn(j,i)+ &
11498                       wsccor*gsccorc(j,i) &
11499                      +wscloc*gscloc(j,i)  &
11500                      +wliptran*gliptranc(j,i) &
11501                      +gradafm(j,i) &
11502                      +welec*gshieldc(j,i) &
11503                      +welec*gshieldc_loc(j,i) &
11504                      +wcorr*gshieldc_ec(j,i) &
11505                      +wcorr*gshieldc_loc_ec(j,i) &
11506                      +wturn3*gshieldc_t3(j,i) &
11507                      +wturn3*gshieldc_loc_t3(j,i) &
11508                      +wturn4*gshieldc_t4(j,i) &
11509                      +wturn4*gshieldc_loc_t4(j,i) &
11510                      +wel_loc*gshieldc_ll(j,i) &
11511                      +wel_loc*gshieldc_loc_ll(j,i) &
11512                      +wtube*gg_tube(j,i) &
11513                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11514                      +wvdwpsb*gvdwpsb1(j,i))&
11515                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11516 !                      if (i.eq.21) then
11517 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11518 !                      wturn4*gshieldc_t4(j,i), &
11519 !                     wturn4*gshieldc_loc_t4(j,i)
11520 !                       endif
11521 !                 if ((i.le.2).and.(i.ge.1))
11522 !                       print *,gradc(j,i,icg),&
11523 !                      gradbufc(j,i),welec*gelc(j,i), &
11524 !                      wel_loc*gel_loc(j,i), &
11525 !                      wscp*gvdwc_scpp(j,i), &
11526 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11527 !                      wel_loc*gel_loc_long(j,i), &
11528 !                      wcorr*gradcorr_long(j,i), &
11529 !                      wcorr5*gradcorr5_long(j,i), &
11530 !                      wcorr6*gradcorr6_long(j,i), &
11531 !                      wturn6*gcorr6_turn_long(j,i), &
11532 !                      wbond*gradb(j,i), &
11533 !                      wcorr*gradcorr(j,i), &
11534 !                      wturn3*gcorr3_turn(j,i), &
11535 !                      wturn4*gcorr4_turn(j,i), &
11536 !                      wcorr5*gradcorr5(j,i), &
11537 !                      wcorr6*gradcorr6(j,i), &
11538 !                      wturn6*gcorr6_turn(j,i), &
11539 !                      wsccor*gsccorc(j,i) &
11540 !                     ,wscloc*gscloc(j,i)  &
11541 !                     ,wliptran*gliptranc(j,i) &
11542 !                    ,gradafm(j,i) &
11543 !                     ,welec*gshieldc(j,i) &
11544 !                     ,welec*gshieldc_loc(j,i) &
11545 !                     ,wcorr*gshieldc_ec(j,i) &
11546 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11547 !                     ,wturn3*gshieldc_t3(j,i) &
11548 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11549 !                     ,wturn4*gshieldc_t4(j,i) &
11550 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11551 !                     ,wel_loc*gshieldc_ll(j,i) &
11552 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11553 !                     ,wtube*gg_tube(j,i) &
11554 !                     ,wbond_nucl*gradb_nucl(j,i) &
11555 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11556 !                     wvdwpsb*gvdwpsb1(j,i)&
11557 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11558 !
11559
11560 #else
11561           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11562                       wel_loc*gel_loc(j,i)+ &
11563                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11564                       welec*gelc_long(j,i)+ &
11565                       wel_loc*gel_loc_long(j,i)+ &
11566 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11567                       wcorr5*gradcorr5_long(j,i)+ &
11568                       wcorr6*gradcorr6_long(j,i)+ &
11569                       wturn6*gcorr6_turn_long(j,i))+ &
11570                       wbond*gradb(j,i)+ &
11571                       wcorr*gradcorr(j,i)+ &
11572                       wturn3*gcorr3_turn(j,i)+ &
11573                       wturn4*gcorr4_turn(j,i)+ &
11574                       wcorr5*gradcorr5(j,i)+ &
11575                       wcorr6*gradcorr6(j,i)+ &
11576                       wturn6*gcorr6_turn(j,i)+ &
11577                       wsccor*gsccorc(j,i) &
11578                      +wscloc*gscloc(j,i) &
11579                      +gradafm(j,i) &
11580                      +wliptran*gliptranc(j,i) &
11581                      +welec*gshieldc(j,i) &
11582                      +welec*gshieldc_loc(j,i) &
11583                      +wcorr*gshieldc_ec(j,i) &
11584                      +wcorr*gshieldc_loc_ec(j,i) &
11585                      +wturn3*gshieldc_t3(j,i) &
11586                      +wturn3*gshieldc_loc_t3(j,i) &
11587                      +wturn4*gshieldc_t4(j,i) &
11588                      +wturn4*gshieldc_loc_t4(j,i) &
11589                      +wel_loc*gshieldc_ll(j,i) &
11590                      +wel_loc*gshieldc_loc_ll(j,i) &
11591                      +wtube*gg_tube(j,i) &
11592                      +wbond_nucl*gradb_nucl(j,i) &
11593                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11594                      +wvdwpsb*gvdwpsb1(j,i))&
11595                      +wsbloc*gsbloc(j,i)
11596
11597
11598
11599
11600 #endif
11601           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11602                         wbond*gradbx(j,i)+ &
11603                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11604                         wsccor*gsccorx(j,i) &
11605                        +wscloc*gsclocx(j,i) &
11606                        +wliptran*gliptranx(j,i) &
11607                        +welec*gshieldx(j,i)     &
11608                        +wcorr*gshieldx_ec(j,i)  &
11609                        +wturn3*gshieldx_t3(j,i) &
11610                        +wturn4*gshieldx_t4(j,i) &
11611                        +wel_loc*gshieldx_ll(j,i)&
11612                        +wtube*gg_tube_sc(j,i)   &
11613                        +wbond_nucl*gradbx_nucl(j,i) &
11614                        +wvdwsb*gvdwsbx(j,i) &
11615                        +welsb*gelsbx(j,i) &
11616                        +wcorr_nucl*gradxorr_nucl(j,i)&
11617                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11618                        +wsbloc*gsblocx(j,i) &
11619                        +wcatprot* gradpepcatx(j,i)&
11620                        +wscbase*gvdwx_scbase(j,i) &
11621                        +wpepbase*gvdwx_pepbase(j,i)&
11622                        +wscpho*gvdwx_scpho(j,i)
11623 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11624
11625         enddo
11626       enddo
11627 !#define DEBUG
11628 #ifdef DEBUG
11629       write (iout,*) "gloc before adding corr"
11630       do i=1,4*nres
11631         write (iout,*) i,gloc(i,icg)
11632       enddo
11633 #endif
11634       do i=1,nres-3
11635         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11636          +wcorr5*g_corr5_loc(i) &
11637          +wcorr6*g_corr6_loc(i) &
11638          +wturn4*gel_loc_turn4(i) &
11639          +wturn3*gel_loc_turn3(i) &
11640          +wturn6*gel_loc_turn6(i) &
11641          +wel_loc*gel_loc_loc(i)
11642       enddo
11643 #ifdef DEBUG
11644       write (iout,*) "gloc after adding corr"
11645       do i=1,4*nres
11646         write (iout,*) i,gloc(i,icg)
11647       enddo
11648 #endif
11649 !#undef DEBUG
11650 #ifdef MPI
11651       if (nfgtasks.gt.1) then
11652         do j=1,3
11653           do i=0,nres
11654             gradbufc(j,i)=gradc(j,i,icg)
11655             gradbufx(j,i)=gradx(j,i,icg)
11656           enddo
11657         enddo
11658         do i=1,4*nres
11659           glocbuf(i)=gloc(i,icg)
11660         enddo
11661 !#define DEBUG
11662 #ifdef DEBUG
11663       write (iout,*) "gloc_sc before reduce"
11664       do i=1,nres
11665        do j=1,1
11666         write (iout,*) i,j,gloc_sc(j,i,icg)
11667        enddo
11668       enddo
11669 #endif
11670 !#undef DEBUG
11671         do i=1,nres
11672          do j=1,3
11673           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11674          enddo
11675         enddo
11676         time00=MPI_Wtime()
11677         call MPI_Barrier(FG_COMM,IERR)
11678         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11679         time00=MPI_Wtime()
11680         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11681           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11682         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11683           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11684         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11685           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11686         time_reduce=time_reduce+MPI_Wtime()-time00
11687         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11688           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11689         time_reduce=time_reduce+MPI_Wtime()-time00
11690 !#define DEBUG
11691 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11692 #ifdef DEBUG
11693       write (iout,*) "gloc_sc after reduce"
11694       do i=1,nres
11695        do j=1,1
11696         write (iout,*) i,j,gloc_sc(j,i,icg)
11697        enddo
11698       enddo
11699 #endif
11700 !#undef DEBUG
11701 #ifdef DEBUG
11702       write (iout,*) "gloc after reduce"
11703       do i=1,4*nres
11704         write (iout,*) i,gloc(i,icg)
11705       enddo
11706 #endif
11707       endif
11708 #endif
11709       if (gnorm_check) then
11710 !
11711 ! Compute the maximum elements of the gradient
11712 !
11713       gvdwc_max=0.0d0
11714       gvdwc_scp_max=0.0d0
11715       gelc_max=0.0d0
11716       gvdwpp_max=0.0d0
11717       gradb_max=0.0d0
11718       ghpbc_max=0.0d0
11719       gradcorr_max=0.0d0
11720       gel_loc_max=0.0d0
11721       gcorr3_turn_max=0.0d0
11722       gcorr4_turn_max=0.0d0
11723       gradcorr5_max=0.0d0
11724       gradcorr6_max=0.0d0
11725       gcorr6_turn_max=0.0d0
11726       gsccorc_max=0.0d0
11727       gscloc_max=0.0d0
11728       gvdwx_max=0.0d0
11729       gradx_scp_max=0.0d0
11730       ghpbx_max=0.0d0
11731       gradxorr_max=0.0d0
11732       gsccorx_max=0.0d0
11733       gsclocx_max=0.0d0
11734       do i=1,nct
11735         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11736         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11737         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11738         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11739          gvdwc_scp_max=gvdwc_scp_norm
11740         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11741         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11742         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11743         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11744         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11745         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11746         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11747         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11748         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11749         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11750         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11751         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11752         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11753           gcorr3_turn(1,i)))
11754         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11755           gcorr3_turn_max=gcorr3_turn_norm
11756         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11757           gcorr4_turn(1,i)))
11758         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11759           gcorr4_turn_max=gcorr4_turn_norm
11760         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11761         if (gradcorr5_norm.gt.gradcorr5_max) &
11762           gradcorr5_max=gradcorr5_norm
11763         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11764         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11765         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11766           gcorr6_turn(1,i)))
11767         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11768           gcorr6_turn_max=gcorr6_turn_norm
11769         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11770         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11771         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11772         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11773         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11774         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11775         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11776         if (gradx_scp_norm.gt.gradx_scp_max) &
11777           gradx_scp_max=gradx_scp_norm
11778         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11779         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11780         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11781         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11782         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11783         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11784         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11785         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11786       enddo
11787       if (gradout) then
11788 #ifdef AIX
11789         open(istat,file=statname,position="append")
11790 #else
11791         open(istat,file=statname,access="append")
11792 #endif
11793         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11794            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11795            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11796            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11797            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11798            gsccorx_max,gsclocx_max
11799         close(istat)
11800         if (gvdwc_max.gt.1.0d4) then
11801           write (iout,*) "gvdwc gvdwx gradb gradbx"
11802           do i=nnt,nct
11803             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11804               gradb(j,i),gradbx(j,i),j=1,3)
11805           enddo
11806           call pdbout(0.0d0,'cipiszcze',iout)
11807           call flush(iout)
11808         endif
11809       endif
11810       endif
11811 !#define DEBUG
11812 #ifdef DEBUG
11813       write (iout,*) "gradc gradx gloc"
11814       do i=1,nres
11815         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11816          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11817       enddo
11818 #endif
11819 !#undef DEBUG
11820 #ifdef TIMING
11821       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11822 #endif
11823       return
11824       end subroutine sum_gradient
11825 !-----------------------------------------------------------------------------
11826       subroutine sc_grad
11827 !      implicit real*8 (a-h,o-z)
11828       use calc_data
11829 !      include 'DIMENSIONS'
11830 !      include 'COMMON.CHAIN'
11831 !      include 'COMMON.DERIV'
11832 !      include 'COMMON.CALC'
11833 !      include 'COMMON.IOUNITS'
11834       real(kind=8), dimension(3) :: dcosom1,dcosom2
11835 !      print *,"wchodze"
11836       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11837           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11838       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11839           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11840
11841       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11842            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11843            +dCAVdOM12+ dGCLdOM12
11844 ! diagnostics only
11845 !      eom1=0.0d0
11846 !      eom2=0.0d0
11847 !      eom12=evdwij*eps1_om12
11848 ! end diagnostics
11849 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11850 !       " sigder",sigder
11851 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11852 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11853 !C      print *,sss_ele_cut,'in sc_grad'
11854       do k=1,3
11855         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11856         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11857       enddo
11858       do k=1,3
11859         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11860 !C      print *,'gg',k,gg(k)
11861        enddo
11862 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11863 !      write (iout,*) "gg",(gg(k),k=1,3)
11864       do k=1,3
11865         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11866                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11867                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11868                   *sss_ele_cut
11869
11870         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11871                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11872                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11873                   *sss_ele_cut
11874
11875 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11876 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11877 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11878 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11879       enddo
11880 !
11881 ! Calculate the components of the gradient in DC and X
11882 !
11883 !grad      do k=i,j-1
11884 !grad        do l=1,3
11885 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11886 !grad        enddo
11887 !grad      enddo
11888       do l=1,3
11889         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11890         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11891       enddo
11892       return
11893       end subroutine sc_grad
11894
11895       subroutine sc_grad_cat
11896 !      implicit real*8 (a-h,o-z)
11897       use calc_data
11898 !      include 'DIMENSIONS'
11899 !      include 'COMMON.CHAIN'
11900 !      include 'COMMON.DERIV'
11901 !      include 'COMMON.CALC'
11902 !      include 'COMMON.IOUNITS'
11903       real(kind=8), dimension(3) :: dcosom1,dcosom2
11904 !      print *,"wchodze"
11905       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11906           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11907       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11908           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11909
11910       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11911            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11912            +dCAVdOM12+ dGCLdOM12
11913 ! diagnostics only
11914 !      eom1=0.0d0
11915 !      eom2=0.0d0
11916 !      eom12=evdwij*eps1_om12
11917 ! end diagnostics
11918 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11919 !       " sigder",sigder
11920 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11921 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11922 !C      print *,sss_ele_cut,'in sc_grad'
11923
11924       do k=1,3
11925         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11926         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11927       enddo
11928       do k=1,3
11929         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11930 !C      print *,'gg',k,gg(k)
11931        enddo
11932 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11933 !      write (iout,*) "gg",(gg(k),k=1,3)
11934       do k=1,3
11935         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11936                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11937                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11938
11939         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11940                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11941                   +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11942
11943 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11944 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11945 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11946 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11947       enddo
11948 !
11949 ! Calculate the components of the gradient in DC and X
11950 !
11951 !grad      do k=i,j-1
11952 !grad        do l=1,3
11953 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11954 !grad        enddo
11955 !grad      enddo
11956       do l=1,3
11957         gvdwc(l,i)=gvdwc(l,i)-gg(l)
11958         gvdwc(l,j)=gvdwc(l,j)+gg(l)
11959       enddo
11960       end subroutine sc_grad_cat
11961
11962
11963 #ifdef CRYST_THETA
11964 !-----------------------------------------------------------------------------
11965       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11966
11967       use comm_calcthet
11968 !      implicit real*8 (a-h,o-z)
11969 !      include 'DIMENSIONS'
11970 !      include 'COMMON.LOCAL'
11971 !      include 'COMMON.IOUNITS'
11972 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11973 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11974 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11975       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11976       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11977 !el      integer :: it
11978 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11979 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11980 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11981 !el local variables
11982
11983       delthec=thetai-thet_pred_mean
11984       delthe0=thetai-theta0i
11985 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11986       t3 = thetai-thet_pred_mean
11987       t6 = t3**2
11988       t9 = term1
11989       t12 = t3*sigcsq
11990       t14 = t12+t6*sigsqtc
11991       t16 = 1.0d0
11992       t21 = thetai-theta0i
11993       t23 = t21**2
11994       t26 = term2
11995       t27 = t21*t26
11996       t32 = termexp
11997       t40 = t32**2
11998       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11999        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12000        *(-t12*t9-ak*sig0inv*t27)
12001       return
12002       end subroutine mixder
12003 #endif
12004 !-----------------------------------------------------------------------------
12005 ! cartder.F
12006 !-----------------------------------------------------------------------------
12007       subroutine cartder
12008 !-----------------------------------------------------------------------------
12009 ! This subroutine calculates the derivatives of the consecutive virtual
12010 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12011 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12012 ! in the angles alpha and omega, describing the location of a side chain
12013 ! in its local coordinate system.
12014 !
12015 ! The derivatives are stored in the following arrays:
12016 !
12017 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12018 ! The structure is as follows:
12019 !
12020 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12021 ! 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)
12022 !         . . . . . . . . . . . .  . . . . . .
12023 ! 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)
12024 !                          .
12025 !                          .
12026 !                          .
12027 ! 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)
12028 !
12029 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12030 ! The structure is same as above.
12031 !
12032 ! DCDS - the derivatives of the side chain vectors in the local spherical
12033 ! andgles alph and omega:
12034 !
12035 ! 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)
12036 ! 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)
12037 !                          .
12038 !                          .
12039 !                          .
12040 ! 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)
12041 !
12042 ! Version of March '95, based on an early version of November '91.
12043 !
12044 !**********************************************************************
12045 !      implicit real*8 (a-h,o-z)
12046 !      include 'DIMENSIONS'
12047 !      include 'COMMON.VAR'
12048 !      include 'COMMON.CHAIN'
12049 !      include 'COMMON.DERIV'
12050 !      include 'COMMON.GEO'
12051 !      include 'COMMON.LOCAL'
12052 !      include 'COMMON.INTERACT'
12053       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12054       real(kind=8),dimension(3,3) :: dp,temp
12055 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12056       real(kind=8),dimension(3) :: xx,xx1
12057 !el local variables
12058       integer :: i,k,l,j,m,ind,ind1,jjj
12059       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12060                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12061                  sint2,xp,yp,xxp,yyp,zzp,dj
12062
12063 !      common /przechowalnia/ fromto
12064       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12065 ! get the position of the jth ijth fragment of the chain coordinate system
12066 ! in the fromto array.
12067 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12068 !
12069 !      maxdim=(nres-1)*(nres-2)/2
12070 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12071 ! calculate the derivatives of transformation matrix elements in theta
12072 !
12073
12074 !el      call flush(iout) !el
12075       do i=1,nres-2
12076         rdt(1,1,i)=-rt(1,2,i)
12077         rdt(1,2,i)= rt(1,1,i)
12078         rdt(1,3,i)= 0.0d0
12079         rdt(2,1,i)=-rt(2,2,i)
12080         rdt(2,2,i)= rt(2,1,i)
12081         rdt(2,3,i)= 0.0d0
12082         rdt(3,1,i)=-rt(3,2,i)
12083         rdt(3,2,i)= rt(3,1,i)
12084         rdt(3,3,i)= 0.0d0
12085       enddo
12086 !
12087 ! derivatives in phi
12088 !
12089       do i=2,nres-2
12090         drt(1,1,i)= 0.0d0
12091         drt(1,2,i)= 0.0d0
12092         drt(1,3,i)= 0.0d0
12093         drt(2,1,i)= rt(3,1,i)
12094         drt(2,2,i)= rt(3,2,i)
12095         drt(2,3,i)= rt(3,3,i)
12096         drt(3,1,i)=-rt(2,1,i)
12097         drt(3,2,i)=-rt(2,2,i)
12098         drt(3,3,i)=-rt(2,3,i)
12099       enddo
12100 !
12101 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12102 !
12103       do i=2,nres-2
12104         ind=indmat(i,i+1)
12105         do k=1,3
12106           do l=1,3
12107             temp(k,l)=rt(k,l,i)
12108           enddo
12109         enddo
12110         do k=1,3
12111           do l=1,3
12112             fromto(k,l,ind)=temp(k,l)
12113           enddo
12114         enddo
12115         do j=i+1,nres-2
12116           ind=indmat(i,j+1)
12117           do k=1,3
12118             do l=1,3
12119               dpkl=0.0d0
12120               do m=1,3
12121                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12122               enddo
12123               dp(k,l)=dpkl
12124               fromto(k,l,ind)=dpkl
12125             enddo
12126           enddo
12127           do k=1,3
12128             do l=1,3
12129               temp(k,l)=dp(k,l)
12130             enddo
12131           enddo
12132         enddo
12133       enddo
12134 !
12135 ! Calculate derivatives.
12136 !
12137       ind1=0
12138       do i=1,nres-2
12139       ind1=ind1+1
12140 !
12141 ! Derivatives of DC(i+1) in theta(i+2)
12142 !
12143         do j=1,3
12144           do k=1,2
12145             dpjk=0.0D0
12146             do l=1,3
12147               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12148             enddo
12149             dp(j,k)=dpjk
12150             prordt(j,k,i)=dp(j,k)
12151           enddo
12152           dp(j,3)=0.0D0
12153           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12154         enddo
12155 !
12156 ! Derivatives of SC(i+1) in theta(i+2)
12157 !
12158         xx1(1)=-0.5D0*xloc(2,i+1)
12159         xx1(2)= 0.5D0*xloc(1,i+1)
12160         do j=1,3
12161           xj=0.0D0
12162           do k=1,2
12163             xj=xj+r(j,k,i)*xx1(k)
12164           enddo
12165           xx(j)=xj
12166         enddo
12167         do j=1,3
12168           rj=0.0D0
12169           do k=1,3
12170             rj=rj+prod(j,k,i)*xx(k)
12171           enddo
12172           dxdv(j,ind1)=rj
12173         enddo
12174 !
12175 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12176 ! than the other off-diagonal derivatives.
12177 !
12178         do j=1,3
12179           dxoiij=0.0D0
12180           do k=1,3
12181             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12182           enddo
12183           dxdv(j,ind1+1)=dxoiij
12184         enddo
12185 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12186 !
12187 ! Derivatives of DC(i+1) in phi(i+2)
12188 !
12189         do j=1,3
12190           do k=1,3
12191             dpjk=0.0
12192             do l=2,3
12193               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12194             enddo
12195             dp(j,k)=dpjk
12196             prodrt(j,k,i)=dp(j,k)
12197           enddo
12198           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12199         enddo
12200 !
12201 ! Derivatives of SC(i+1) in phi(i+2)
12202 !
12203         xx(1)= 0.0D0
12204         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12205         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12206         do j=1,3
12207           rj=0.0D0
12208           do k=2,3
12209             rj=rj+prod(j,k,i)*xx(k)
12210           enddo
12211           dxdv(j+3,ind1)=-rj
12212         enddo
12213 !
12214 ! Derivatives of SC(i+1) in phi(i+3).
12215 !
12216         do j=1,3
12217           dxoiij=0.0D0
12218           do k=1,3
12219             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12220           enddo
12221           dxdv(j+3,ind1+1)=dxoiij
12222         enddo
12223 !
12224 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12225 ! theta(nres) and phi(i+3) thru phi(nres).
12226 !
12227         do j=i+1,nres-2
12228         ind1=ind1+1
12229         ind=indmat(i+1,j+1)
12230 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12231           do k=1,3
12232             do l=1,3
12233               tempkl=0.0D0
12234               do m=1,2
12235                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12236               enddo
12237               temp(k,l)=tempkl
12238             enddo
12239           enddo
12240 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12241 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12242 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12243 ! Derivatives of virtual-bond vectors in theta
12244           do k=1,3
12245             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12246           enddo
12247 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12248 ! Derivatives of SC vectors in theta
12249           do k=1,3
12250             dxoijk=0.0D0
12251             do l=1,3
12252               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12253             enddo
12254             dxdv(k,ind1+1)=dxoijk
12255           enddo
12256 !
12257 !--- Calculate the derivatives in phi
12258 !
12259           do k=1,3
12260             do l=1,3
12261               tempkl=0.0D0
12262               do m=1,3
12263                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12264               enddo
12265               temp(k,l)=tempkl
12266             enddo
12267           enddo
12268           do k=1,3
12269             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12270         enddo
12271           do k=1,3
12272             dxoijk=0.0D0
12273             do l=1,3
12274               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12275             enddo
12276             dxdv(k+3,ind1+1)=dxoijk
12277           enddo
12278         enddo
12279       enddo
12280 !
12281 ! Derivatives in alpha and omega:
12282 !
12283       do i=2,nres-1
12284 !       dsci=dsc(itype(i,1))
12285         dsci=vbld(i+nres)
12286 #ifdef OSF
12287         alphi=alph(i)
12288         omegi=omeg(i)
12289         if(alphi.ne.alphi) alphi=100.0
12290         if(omegi.ne.omegi) omegi=-100.0
12291 #else
12292       alphi=alph(i)
12293       omegi=omeg(i)
12294 #endif
12295 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12296       cosalphi=dcos(alphi)
12297       sinalphi=dsin(alphi)
12298       cosomegi=dcos(omegi)
12299       sinomegi=dsin(omegi)
12300       temp(1,1)=-dsci*sinalphi
12301       temp(2,1)= dsci*cosalphi*cosomegi
12302       temp(3,1)=-dsci*cosalphi*sinomegi
12303       temp(1,2)=0.0D0
12304       temp(2,2)=-dsci*sinalphi*sinomegi
12305       temp(3,2)=-dsci*sinalphi*cosomegi
12306       theta2=pi-0.5D0*theta(i+1)
12307       cost2=dcos(theta2)
12308       sint2=dsin(theta2)
12309       jjj=0
12310 !d      print *,((temp(l,k),l=1,3),k=1,2)
12311         do j=1,2
12312         xp=temp(1,j)
12313         yp=temp(2,j)
12314         xxp= xp*cost2+yp*sint2
12315         yyp=-xp*sint2+yp*cost2
12316         zzp=temp(3,j)
12317         xx(1)=xxp
12318         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12319         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12320         do k=1,3
12321           dj=0.0D0
12322           do l=1,3
12323             dj=dj+prod(k,l,i-1)*xx(l)
12324             enddo
12325           dxds(jjj+k,i)=dj
12326           enddo
12327         jjj=jjj+3
12328       enddo
12329       enddo
12330       return
12331       end subroutine cartder
12332 !-----------------------------------------------------------------------------
12333 ! checkder_p.F
12334 !-----------------------------------------------------------------------------
12335       subroutine check_cartgrad
12336 ! Check the gradient of Cartesian coordinates in internal coordinates.
12337 !      implicit real*8 (a-h,o-z)
12338 !      include 'DIMENSIONS'
12339 !      include 'COMMON.IOUNITS'
12340 !      include 'COMMON.VAR'
12341 !      include 'COMMON.CHAIN'
12342 !      include 'COMMON.GEO'
12343 !      include 'COMMON.LOCAL'
12344 !      include 'COMMON.DERIV'
12345       real(kind=8),dimension(6,nres) :: temp
12346       real(kind=8),dimension(3) :: xx,gg
12347       integer :: i,k,j,ii
12348       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12349 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12350 !
12351 ! Check the gradient of the virtual-bond and SC vectors in the internal
12352 ! coordinates.
12353 !
12354       aincr=1.0d-6
12355       aincr2=5.0d-7
12356       call cartder
12357       write (iout,'(a)') '**************** dx/dalpha'
12358       write (iout,'(a)')
12359       do i=2,nres-1
12360       alphi=alph(i)
12361       alph(i)=alph(i)+aincr
12362       do k=1,3
12363         temp(k,i)=dc(k,nres+i)
12364         enddo
12365       call chainbuild
12366       do k=1,3
12367         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12368         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12369         enddo
12370         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12371         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12372         write (iout,'(a)')
12373       alph(i)=alphi
12374       call chainbuild
12375       enddo
12376       write (iout,'(a)')
12377       write (iout,'(a)') '**************** dx/domega'
12378       write (iout,'(a)')
12379       do i=2,nres-1
12380       omegi=omeg(i)
12381       omeg(i)=omeg(i)+aincr
12382       do k=1,3
12383         temp(k,i)=dc(k,nres+i)
12384         enddo
12385       call chainbuild
12386       do k=1,3
12387           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12388           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12389                 (aincr*dabs(dxds(k+3,i))+aincr))
12390         enddo
12391         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12392             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12393         write (iout,'(a)')
12394       omeg(i)=omegi
12395       call chainbuild
12396       enddo
12397       write (iout,'(a)')
12398       write (iout,'(a)') '**************** dx/dtheta'
12399       write (iout,'(a)')
12400       do i=3,nres
12401       theti=theta(i)
12402         theta(i)=theta(i)+aincr
12403         do j=i-1,nres-1
12404           do k=1,3
12405             temp(k,j)=dc(k,nres+j)
12406           enddo
12407         enddo
12408         call chainbuild
12409         do j=i-1,nres-1
12410         ii = indmat(i-2,j)
12411 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12412         do k=1,3
12413           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12414           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12415                   (aincr*dabs(dxdv(k,ii))+aincr))
12416           enddo
12417           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12418               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12419           write(iout,'(a)')
12420         enddo
12421         write (iout,'(a)')
12422         theta(i)=theti
12423         call chainbuild
12424       enddo
12425       write (iout,'(a)') '***************** dx/dphi'
12426       write (iout,'(a)')
12427       do i=4,nres
12428         phi(i)=phi(i)+aincr
12429         do j=i-1,nres-1
12430           do k=1,3
12431             temp(k,j)=dc(k,nres+j)
12432           enddo
12433         enddo
12434         call chainbuild
12435         do j=i-1,nres-1
12436         ii = indmat(i-2,j)
12437 !         print *,'ii=',ii
12438         do k=1,3
12439           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12440             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12441                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12442           enddo
12443           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12444               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12445           write(iout,'(a)')
12446         enddo
12447         phi(i)=phi(i)-aincr
12448         call chainbuild
12449       enddo
12450       write (iout,'(a)') '****************** ddc/dtheta'
12451       do i=1,nres-2
12452         thet=theta(i+2)
12453         theta(i+2)=thet+aincr
12454         do j=i,nres
12455           do k=1,3
12456             temp(k,j)=dc(k,j)
12457           enddo
12458         enddo
12459         call chainbuild
12460         do j=i+1,nres-1
12461         ii = indmat(i,j)
12462 !         print *,'ii=',ii
12463         do k=1,3
12464           gg(k)=(dc(k,j)-temp(k,j))/aincr
12465           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12466                  (aincr*dabs(dcdv(k,ii))+aincr))
12467           enddo
12468           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12469                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12470         write (iout,'(a)')
12471         enddo
12472         do j=1,nres
12473           do k=1,3
12474             dc(k,j)=temp(k,j)
12475           enddo
12476         enddo
12477         theta(i+2)=thet
12478       enddo
12479       write (iout,'(a)') '******************* ddc/dphi'
12480       do i=1,nres-3
12481         phii=phi(i+3)
12482         phi(i+3)=phii+aincr
12483         do j=1,nres
12484           do k=1,3
12485             temp(k,j)=dc(k,j)
12486           enddo
12487         enddo
12488         call chainbuild
12489         do j=i+2,nres-1
12490         ii = indmat(i+1,j)
12491 !         print *,'ii=',ii
12492         do k=1,3
12493           gg(k)=(dc(k,j)-temp(k,j))/aincr
12494             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12495                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12496           enddo
12497           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12498                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12499         write (iout,'(a)')
12500         enddo
12501         do j=1,nres
12502           do k=1,3
12503             dc(k,j)=temp(k,j)
12504           enddo
12505         enddo
12506         phi(i+3)=phii
12507       enddo
12508       return
12509       end subroutine check_cartgrad
12510 !-----------------------------------------------------------------------------
12511       subroutine check_ecart
12512 ! Check the gradient of the energy in Cartesian coordinates.
12513 !     implicit real*8 (a-h,o-z)
12514 !     include 'DIMENSIONS'
12515 !     include 'COMMON.CHAIN'
12516 !     include 'COMMON.DERIV'
12517 !     include 'COMMON.IOUNITS'
12518 !     include 'COMMON.VAR'
12519 !     include 'COMMON.CONTACTS'
12520       use comm_srutu
12521 !el      integer :: icall
12522 !el      common /srutu/ icall
12523       real(kind=8),dimension(6) :: ggg
12524       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12525       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12526       real(kind=8),dimension(6,nres) :: grad_s
12527       real(kind=8),dimension(0:n_ene) :: energia,energia1
12528       integer :: uiparm(1)
12529       real(kind=8) :: urparm(1)
12530 !EL      external fdum
12531       integer :: nf,i,j,k
12532       real(kind=8) :: aincr,etot,etot1
12533       icg=1
12534       nf=0
12535       nfl=0
12536       call zerograd
12537       aincr=1.0D-5
12538       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12539       nf=0
12540       icall=0
12541       call geom_to_var(nvar,x)
12542       call etotal(energia)
12543       etot=energia(0)
12544 !el      call enerprint(energia)
12545       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12546       icall =1
12547       do i=1,nres
12548         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12549       enddo
12550       do i=1,nres
12551       do j=1,3
12552         grad_s(j,i)=gradc(j,i,icg)
12553         grad_s(j+3,i)=gradx(j,i,icg)
12554         enddo
12555       enddo
12556       call flush(iout)
12557       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12558       do i=1,nres
12559         do j=1,3
12560         xx(j)=c(j,i+nres)
12561         ddc(j)=dc(j,i)
12562         ddx(j)=dc(j,i+nres)
12563         enddo
12564       do j=1,3
12565         dc(j,i)=dc(j,i)+aincr
12566         do k=i+1,nres
12567           c(j,k)=c(j,k)+aincr
12568           c(j,k+nres)=c(j,k+nres)+aincr
12569           enddo
12570           call zerograd
12571           call etotal(energia1)
12572           etot1=energia1(0)
12573         ggg(j)=(etot1-etot)/aincr
12574         dc(j,i)=ddc(j)
12575         do k=i+1,nres
12576           c(j,k)=c(j,k)-aincr
12577           c(j,k+nres)=c(j,k+nres)-aincr
12578           enddo
12579         enddo
12580       do j=1,3
12581         c(j,i+nres)=c(j,i+nres)+aincr
12582         dc(j,i+nres)=dc(j,i+nres)+aincr
12583           call zerograd
12584           call etotal(energia1)
12585           etot1=energia1(0)
12586         ggg(j+3)=(etot1-etot)/aincr
12587         c(j,i+nres)=xx(j)
12588         dc(j,i+nres)=ddx(j)
12589         enddo
12590       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12591          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12592       enddo
12593       return
12594       end subroutine check_ecart
12595 #ifdef CARGRAD
12596 !-----------------------------------------------------------------------------
12597       subroutine check_ecartint
12598 ! Check the gradient of the energy in Cartesian coordinates.
12599       use io_base, only: intout
12600 !      implicit real*8 (a-h,o-z)
12601 !      include 'DIMENSIONS'
12602 !      include 'COMMON.CONTROL'
12603 !      include 'COMMON.CHAIN'
12604 !      include 'COMMON.DERIV'
12605 !      include 'COMMON.IOUNITS'
12606 !      include 'COMMON.VAR'
12607 !      include 'COMMON.CONTACTS'
12608 !      include 'COMMON.MD'
12609 !      include 'COMMON.LOCAL'
12610 !      include 'COMMON.SPLITELE'
12611       use comm_srutu
12612 !el      integer :: icall
12613 !el      common /srutu/ icall
12614       real(kind=8),dimension(6) :: ggg,ggg1
12615       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12616       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12617       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12618       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12619       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12620       real(kind=8),dimension(0:n_ene) :: energia,energia1
12621       integer :: uiparm(1)
12622       real(kind=8) :: urparm(1)
12623 !EL      external fdum
12624       integer :: i,j,k,nf
12625       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12626                    etot21,etot22
12627       r_cut=2.0d0
12628       rlambd=0.3d0
12629       icg=1
12630       nf=0
12631       nfl=0
12632       call intout
12633 !      call intcartderiv
12634 !      call checkintcartgrad
12635       call zerograd
12636       aincr=1.0D-4
12637       write(iout,*) 'Calling CHECK_ECARTINT.'
12638       nf=0
12639       icall=0
12640       call geom_to_var(nvar,x)
12641       write (iout,*) "split_ene ",split_ene
12642       call flush(iout)
12643       if (.not.split_ene) then
12644         call zerograd
12645         call etotal(energia)
12646         etot=energia(0)
12647         call cartgrad
12648         icall =1
12649         do i=1,nres
12650           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12651         enddo
12652         do j=1,3
12653           grad_s(j,0)=gcart(j,0)
12654         enddo
12655         do i=1,nres
12656           do j=1,3
12657             grad_s(j,i)=gcart(j,i)
12658             grad_s(j+3,i)=gxcart(j,i)
12659           enddo
12660         enddo
12661       else
12662 !- split gradient check
12663         call zerograd
12664         call etotal_long(energia)
12665 !el        call enerprint(energia)
12666         call cartgrad
12667         icall =1
12668         do i=1,nres
12669           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12670           (gxcart(j,i),j=1,3)
12671         enddo
12672         do j=1,3
12673           grad_s(j,0)=gcart(j,0)
12674         enddo
12675         do i=1,nres
12676           do j=1,3
12677             grad_s(j,i)=gcart(j,i)
12678             grad_s(j+3,i)=gxcart(j,i)
12679           enddo
12680         enddo
12681         call zerograd
12682         call etotal_short(energia)
12683         call enerprint(energia)
12684         call cartgrad
12685         icall =1
12686         do i=1,nres
12687           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12688           (gxcart(j,i),j=1,3)
12689         enddo
12690         do j=1,3
12691           grad_s1(j,0)=gcart(j,0)
12692         enddo
12693         do i=1,nres
12694           do j=1,3
12695             grad_s1(j,i)=gcart(j,i)
12696             grad_s1(j+3,i)=gxcart(j,i)
12697           enddo
12698         enddo
12699       endif
12700       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12701 !      do i=1,nres
12702       do i=nnt,nct
12703         do j=1,3
12704           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12705           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12706         ddc(j)=c(j,i)
12707         ddx(j)=c(j,i+nres)
12708           dcnorm_safe1(j)=dc_norm(j,i-1)
12709           dcnorm_safe2(j)=dc_norm(j,i)
12710           dxnorm_safe(j)=dc_norm(j,i+nres)
12711         enddo
12712       do j=1,3
12713         c(j,i)=ddc(j)+aincr
12714           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12715           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12716           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12717           dc(j,i)=c(j,i+1)-c(j,i)
12718           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12719           call int_from_cart1(.false.)
12720           if (.not.split_ene) then
12721            call zerograd
12722             call etotal(energia1)
12723             etot1=energia1(0)
12724             write (iout,*) "ij",i,j," etot1",etot1
12725           else
12726 !- split gradient
12727             call etotal_long(energia1)
12728             etot11=energia1(0)
12729             call etotal_short(energia1)
12730             etot12=energia1(0)
12731           endif
12732 !- end split gradient
12733 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12734         c(j,i)=ddc(j)-aincr
12735           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12736           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12737           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12738           dc(j,i)=c(j,i+1)-c(j,i)
12739           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12740           call int_from_cart1(.false.)
12741           if (.not.split_ene) then
12742             call zerograd
12743             call etotal(energia1)
12744             etot2=energia1(0)
12745             write (iout,*) "ij",i,j," etot2",etot2
12746           ggg(j)=(etot1-etot2)/(2*aincr)
12747           else
12748 !- split gradient
12749             call etotal_long(energia1)
12750             etot21=energia1(0)
12751           ggg(j)=(etot11-etot21)/(2*aincr)
12752             call etotal_short(energia1)
12753             etot22=energia1(0)
12754           ggg1(j)=(etot12-etot22)/(2*aincr)
12755 !- end split gradient
12756 !            write (iout,*) "etot21",etot21," etot22",etot22
12757           endif
12758 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12759         c(j,i)=ddc(j)
12760           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12761           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12762           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12763           dc(j,i)=c(j,i+1)-c(j,i)
12764           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12765           dc_norm(j,i-1)=dcnorm_safe1(j)
12766           dc_norm(j,i)=dcnorm_safe2(j)
12767           dc_norm(j,i+nres)=dxnorm_safe(j)
12768         enddo
12769       do j=1,3
12770         c(j,i+nres)=ddx(j)+aincr
12771           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12772           call int_from_cart1(.false.)
12773           if (.not.split_ene) then
12774             call zerograd
12775             call etotal(energia1)
12776             etot1=energia1(0)
12777           else
12778 !- split gradient
12779             call etotal_long(energia1)
12780             etot11=energia1(0)
12781             call etotal_short(energia1)
12782             etot12=energia1(0)
12783           endif
12784 !- end split gradient
12785         c(j,i+nres)=ddx(j)-aincr
12786           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12787           call int_from_cart1(.false.)
12788           if (.not.split_ene) then
12789            call zerograd
12790            call etotal(energia1)
12791             etot2=energia1(0)
12792           ggg(j+3)=(etot1-etot2)/(2*aincr)
12793           else
12794 !- split gradient
12795             call etotal_long(energia1)
12796             etot21=energia1(0)
12797           ggg(j+3)=(etot11-etot21)/(2*aincr)
12798             call etotal_short(energia1)
12799             etot22=energia1(0)
12800           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12801 !- end split gradient
12802           endif
12803 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12804         c(j,i+nres)=ddx(j)
12805           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12806           dc_norm(j,i+nres)=dxnorm_safe(j)
12807           call int_from_cart1(.false.)
12808         enddo
12809       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12810          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12811         if (split_ene) then
12812           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12813          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12814          k=1,6)
12815          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12816          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12817          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12818         endif
12819       enddo
12820       return
12821       end subroutine check_ecartint
12822 #else
12823 !-----------------------------------------------------------------------------
12824       subroutine check_ecartint
12825 ! Check the gradient of the energy in Cartesian coordinates.
12826       use io_base, only: intout
12827 !      implicit real*8 (a-h,o-z)
12828 !      include 'DIMENSIONS'
12829 !      include 'COMMON.CONTROL'
12830 !      include 'COMMON.CHAIN'
12831 !      include 'COMMON.DERIV'
12832 !      include 'COMMON.IOUNITS'
12833 !      include 'COMMON.VAR'
12834 !      include 'COMMON.CONTACTS'
12835 !      include 'COMMON.MD'
12836 !      include 'COMMON.LOCAL'
12837 !      include 'COMMON.SPLITELE'
12838       use comm_srutu
12839 !el      integer :: icall
12840 !el      common /srutu/ icall
12841       real(kind=8),dimension(6) :: ggg,ggg1
12842       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12843       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12844       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12845       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12846       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12847       real(kind=8),dimension(0:n_ene) :: energia,energia1
12848       integer :: uiparm(1)
12849       real(kind=8) :: urparm(1)
12850 !EL      external fdum
12851       integer :: i,j,k,nf
12852       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12853                    etot21,etot22
12854       r_cut=2.0d0
12855       rlambd=0.3d0
12856       icg=1
12857       nf=0
12858       nfl=0
12859       call intout
12860 !      call intcartderiv
12861 !      call checkintcartgrad
12862       call zerograd
12863       aincr=1.0D-7
12864       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12865       nf=0
12866       icall=0
12867       call geom_to_var(nvar,x)
12868       if (.not.split_ene) then
12869         call etotal(energia)
12870         etot=energia(0)
12871 !el        call enerprint(energia)
12872         call cartgrad
12873         icall =1
12874         do i=1,nres
12875           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12876         enddo
12877         do j=1,3
12878           grad_s(j,0)=gcart(j,0)
12879         enddo
12880         do i=1,nres
12881           do j=1,3
12882             grad_s(j,i)=gcart(j,i)
12883 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12884
12885 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12886             grad_s(j+3,i)=gxcart(j,i)
12887           enddo
12888         enddo
12889       else
12890 !- split gradient check
12891         call zerograd
12892         call etotal_long(energia)
12893 !el        call enerprint(energia)
12894         call cartgrad
12895         icall =1
12896         do i=1,nres
12897           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12898           (gxcart(j,i),j=1,3)
12899         enddo
12900         do j=1,3
12901           grad_s(j,0)=gcart(j,0)
12902         enddo
12903         do i=1,nres
12904           do j=1,3
12905             grad_s(j,i)=gcart(j,i)
12906 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12907             grad_s(j+3,i)=gxcart(j,i)
12908           enddo
12909         enddo
12910         call zerograd
12911         call etotal_short(energia)
12912 !el        call enerprint(energia)
12913         call cartgrad
12914         icall =1
12915         do i=1,nres
12916           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12917           (gxcart(j,i),j=1,3)
12918         enddo
12919         do j=1,3
12920           grad_s1(j,0)=gcart(j,0)
12921         enddo
12922         do i=1,nres
12923           do j=1,3
12924             grad_s1(j,i)=gcart(j,i)
12925             grad_s1(j+3,i)=gxcart(j,i)
12926           enddo
12927         enddo
12928       endif
12929       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12930       do i=0,nres
12931         do j=1,3
12932         xx(j)=c(j,i+nres)
12933         ddc(j)=dc(j,i)
12934         ddx(j)=dc(j,i+nres)
12935           do k=1,3
12936             dcnorm_safe(k)=dc_norm(k,i)
12937             dxnorm_safe(k)=dc_norm(k,i+nres)
12938           enddo
12939         enddo
12940       do j=1,3
12941         dc(j,i)=ddc(j)+aincr
12942           call chainbuild_cart
12943 #ifdef MPI
12944 ! Broadcast the order to compute internal coordinates to the slaves.
12945 !          if (nfgtasks.gt.1)
12946 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12947 #endif
12948 !          call int_from_cart1(.false.)
12949           if (.not.split_ene) then
12950            call zerograd
12951             call etotal(energia1)
12952             etot1=energia1(0)
12953 !            call enerprint(energia1)
12954           else
12955 !- split gradient
12956             call etotal_long(energia1)
12957             etot11=energia1(0)
12958             call etotal_short(energia1)
12959             etot12=energia1(0)
12960 !            write (iout,*) "etot11",etot11," etot12",etot12
12961           endif
12962 !- end split gradient
12963 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12964         dc(j,i)=ddc(j)-aincr
12965           call chainbuild_cart
12966 !          call int_from_cart1(.false.)
12967           if (.not.split_ene) then
12968                   call zerograd
12969             call etotal(energia1)
12970             etot2=energia1(0)
12971           ggg(j)=(etot1-etot2)/(2*aincr)
12972           else
12973 !- split gradient
12974             call etotal_long(energia1)
12975             etot21=energia1(0)
12976           ggg(j)=(etot11-etot21)/(2*aincr)
12977             call etotal_short(energia1)
12978             etot22=energia1(0)
12979           ggg1(j)=(etot12-etot22)/(2*aincr)
12980 !- end split gradient
12981 !            write (iout,*) "etot21",etot21," etot22",etot22
12982           endif
12983 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12984         dc(j,i)=ddc(j)
12985           call chainbuild_cart
12986         enddo
12987       do j=1,3
12988         dc(j,i+nres)=ddx(j)+aincr
12989           call chainbuild_cart
12990 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12991 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12992 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12993 !          write (iout,*) "dxnormnorm",dsqrt(
12994 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12995 !          write (iout,*) "dxnormnormsafe",dsqrt(
12996 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12997 !          write (iout,*)
12998           if (.not.split_ene) then
12999             call zerograd
13000             call etotal(energia1)
13001             etot1=energia1(0)
13002           else
13003 !- split gradient
13004             call etotal_long(energia1)
13005             etot11=energia1(0)
13006             call etotal_short(energia1)
13007             etot12=energia1(0)
13008           endif
13009 !- end split gradient
13010 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13011         dc(j,i+nres)=ddx(j)-aincr
13012           call chainbuild_cart
13013 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13014 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13015 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13016 !          write (iout,*)
13017 !          write (iout,*) "dxnormnorm",dsqrt(
13018 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13019 !          write (iout,*) "dxnormnormsafe",dsqrt(
13020 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13021           if (.not.split_ene) then
13022             call zerograd
13023             call etotal(energia1)
13024             etot2=energia1(0)
13025           ggg(j+3)=(etot1-etot2)/(2*aincr)
13026           else
13027 !- split gradient
13028             call etotal_long(energia1)
13029             etot21=energia1(0)
13030           ggg(j+3)=(etot11-etot21)/(2*aincr)
13031             call etotal_short(energia1)
13032             etot22=energia1(0)
13033           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13034 !- end split gradient
13035           endif
13036 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13037         dc(j,i+nres)=ddx(j)
13038           call chainbuild_cart
13039         enddo
13040       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13041          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13042         if (split_ene) then
13043           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13044          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13045          k=1,6)
13046          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13047          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13048          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13049         endif
13050       enddo
13051       return
13052       end subroutine check_ecartint
13053 #endif
13054 !-----------------------------------------------------------------------------
13055       subroutine check_eint
13056 ! Check the gradient of energy in internal coordinates.
13057 !      implicit real*8 (a-h,o-z)
13058 !      include 'DIMENSIONS'
13059 !      include 'COMMON.CHAIN'
13060 !      include 'COMMON.DERIV'
13061 !      include 'COMMON.IOUNITS'
13062 !      include 'COMMON.VAR'
13063 !      include 'COMMON.GEO'
13064       use comm_srutu
13065 !el      integer :: icall
13066 !el      common /srutu/ icall
13067       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13068       integer :: uiparm(1)
13069       real(kind=8) :: urparm(1)
13070       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13071       character(len=6) :: key
13072 !EL      external fdum
13073       integer :: i,ii,nf
13074       real(kind=8) :: xi,aincr,etot,etot1,etot2
13075       call zerograd
13076       aincr=1.0D-7
13077       print '(a)','Calling CHECK_INT.'
13078       nf=0
13079       nfl=0
13080       icg=1
13081       call geom_to_var(nvar,x)
13082       call var_to_geom(nvar,x)
13083       call chainbuild
13084       icall=1
13085 !      print *,'ICG=',ICG
13086       call etotal(energia)
13087       etot = energia(0)
13088 !el      call enerprint(energia)
13089 !      print *,'ICG=',ICG
13090 #ifdef MPL
13091       if (MyID.ne.BossID) then
13092         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13093         nf=x(nvar+1)
13094         nfl=x(nvar+2)
13095         icg=x(nvar+3)
13096       endif
13097 #endif
13098       nf=1
13099       nfl=3
13100 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13101       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13102 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13103       icall=1
13104       do i=1,nvar
13105         xi=x(i)
13106         x(i)=xi-0.5D0*aincr
13107         call var_to_geom(nvar,x)
13108         call chainbuild
13109         call etotal(energia1)
13110         etot1=energia1(0)
13111         x(i)=xi+0.5D0*aincr
13112         call var_to_geom(nvar,x)
13113         call chainbuild
13114         call etotal(energia2)
13115         etot2=energia2(0)
13116         gg(i)=(etot2-etot1)/aincr
13117         write (iout,*) i,etot1,etot2
13118         x(i)=xi
13119       enddo
13120       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13121           '     RelDiff*100% '
13122       do i=1,nvar
13123         if (i.le.nphi) then
13124           ii=i
13125           key = ' phi'
13126         else if (i.le.nphi+ntheta) then
13127           ii=i-nphi
13128           key=' theta'
13129         else if (i.le.nphi+ntheta+nside) then
13130            ii=i-(nphi+ntheta)
13131            key=' alpha'
13132         else
13133            ii=i-(nphi+ntheta+nside)
13134            key=' omega'
13135         endif
13136         write (iout,'(i3,a,i3,3(1pd16.6))') &
13137        i,key,ii,gg(i),gana(i),&
13138        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13139       enddo
13140       return
13141       end subroutine check_eint
13142 !-----------------------------------------------------------------------------
13143 ! econstr_local.F
13144 !-----------------------------------------------------------------------------
13145       subroutine Econstr_back
13146 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13147 !      implicit real*8 (a-h,o-z)
13148 !      include 'DIMENSIONS'
13149 !      include 'COMMON.CONTROL'
13150 !      include 'COMMON.VAR'
13151 !      include 'COMMON.MD'
13152       use MD_data
13153 !#ifndef LANG0
13154 !      include 'COMMON.LANGEVIN'
13155 !#else
13156 !      include 'COMMON.LANGEVIN.lang0'
13157 !#endif
13158 !      include 'COMMON.CHAIN'
13159 !      include 'COMMON.DERIV'
13160 !      include 'COMMON.GEO'
13161 !      include 'COMMON.LOCAL'
13162 !      include 'COMMON.INTERACT'
13163 !      include 'COMMON.IOUNITS'
13164 !      include 'COMMON.NAMES'
13165 !      include 'COMMON.TIME1'
13166       integer :: i,j,ii,k
13167       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13168
13169       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13170       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13171       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13172
13173       Uconst_back=0.0d0
13174       do i=1,nres
13175         dutheta(i)=0.0d0
13176         dugamma(i)=0.0d0
13177         do j=1,3
13178           duscdiff(j,i)=0.0d0
13179           duscdiffx(j,i)=0.0d0
13180         enddo
13181       enddo
13182       do i=1,nfrag_back
13183         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13184 !
13185 ! Deviations from theta angles
13186 !
13187         utheta_i=0.0d0
13188         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13189           dtheta_i=theta(j)-thetaref(j)
13190           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13191           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13192         enddo
13193         utheta(i)=utheta_i/(ii-1)
13194 !
13195 ! Deviations from gamma angles
13196 !
13197         ugamma_i=0.0d0
13198         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13199           dgamma_i=pinorm(phi(j)-phiref(j))
13200 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13201           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13202           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13203 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13204         enddo
13205         ugamma(i)=ugamma_i/(ii-2)
13206 !
13207 ! Deviations from local SC geometry
13208 !
13209         uscdiff(i)=0.0d0
13210         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13211           dxx=xxtab(j)-xxref(j)
13212           dyy=yytab(j)-yyref(j)
13213           dzz=zztab(j)-zzref(j)
13214           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13215           do k=1,3
13216             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13217              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13218              (ii-1)
13219             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13220              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13221              (ii-1)
13222             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13223            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13224             /(ii-1)
13225           enddo
13226 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13227 !     &      xxref(j),yyref(j),zzref(j)
13228         enddo
13229         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13230 !        write (iout,*) i," uscdiff",uscdiff(i)
13231 !
13232 ! Put together deviations from local geometry
13233 !
13234         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13235           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13236 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13237 !     &   " uconst_back",uconst_back
13238         utheta(i)=dsqrt(utheta(i))
13239         ugamma(i)=dsqrt(ugamma(i))
13240         uscdiff(i)=dsqrt(uscdiff(i))
13241       enddo
13242       return
13243       end subroutine Econstr_back
13244 !-----------------------------------------------------------------------------
13245 ! energy_p_new-sep_barrier.F
13246 !-----------------------------------------------------------------------------
13247       real(kind=8) function sscale(r)
13248 !      include "COMMON.SPLITELE"
13249       real(kind=8) :: r,gamm
13250       if(r.lt.r_cut-rlamb) then
13251         sscale=1.0d0
13252       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13253         gamm=(r-(r_cut-rlamb))/rlamb
13254         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13255       else
13256         sscale=0d0
13257       endif
13258       return
13259       end function sscale
13260       real(kind=8) function sscale_grad(r)
13261 !      include "COMMON.SPLITELE"
13262       real(kind=8) :: r,gamm
13263       if(r.lt.r_cut-rlamb) then
13264         sscale_grad=0.0d0
13265       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13266         gamm=(r-(r_cut-rlamb))/rlamb
13267         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13268       else
13269         sscale_grad=0d0
13270       endif
13271       return
13272       end function sscale_grad
13273
13274 !!!!!!!!!! PBCSCALE
13275       real(kind=8) function sscale_ele(r)
13276 !      include "COMMON.SPLITELE"
13277       real(kind=8) :: r,gamm
13278       if(r.lt.r_cut_ele-rlamb_ele) then
13279         sscale_ele=1.0d0
13280       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13281         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13282         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13283       else
13284         sscale_ele=0d0
13285       endif
13286       return
13287       end function sscale_ele
13288
13289       real(kind=8)  function sscagrad_ele(r)
13290       real(kind=8) :: r,gamm
13291 !      include "COMMON.SPLITELE"
13292       if(r.lt.r_cut_ele-rlamb_ele) then
13293         sscagrad_ele=0.0d0
13294       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13295         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13296         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13297       else
13298         sscagrad_ele=0.0d0
13299       endif
13300       return
13301       end function sscagrad_ele
13302       real(kind=8) function sscalelip(r)
13303       real(kind=8) r,gamm
13304         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13305       return
13306       end function sscalelip
13307 !C-----------------------------------------------------------------------
13308       real(kind=8) function sscagradlip(r)
13309       real(kind=8) r,gamm
13310         sscagradlip=r*(6.0d0*r-6.0d0)
13311       return
13312       end function sscagradlip
13313
13314 !!!!!!!!!!!!!!!
13315 !-----------------------------------------------------------------------------
13316       subroutine elj_long(evdw)
13317 !
13318 ! This subroutine calculates the interaction energy of nonbonded side chains
13319 ! assuming the LJ potential of interaction.
13320 !
13321 !      implicit real*8 (a-h,o-z)
13322 !      include 'DIMENSIONS'
13323 !      include 'COMMON.GEO'
13324 !      include 'COMMON.VAR'
13325 !      include 'COMMON.LOCAL'
13326 !      include 'COMMON.CHAIN'
13327 !      include 'COMMON.DERIV'
13328 !      include 'COMMON.INTERACT'
13329 !      include 'COMMON.TORSION'
13330 !      include 'COMMON.SBRIDGE'
13331 !      include 'COMMON.NAMES'
13332 !      include 'COMMON.IOUNITS'
13333 !      include 'COMMON.CONTACTS'
13334       real(kind=8),parameter :: accur=1.0d-10
13335       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13336 !el local variables
13337       integer :: i,iint,j,k,itypi,itypi1,itypj
13338       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13339       real(kind=8) :: e1,e2,evdwij,evdw
13340 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13341       evdw=0.0D0
13342       do i=iatsc_s,iatsc_e
13343         itypi=itype(i,1)
13344         if (itypi.eq.ntyp1) cycle
13345         itypi1=itype(i+1,1)
13346         xi=c(1,nres+i)
13347         yi=c(2,nres+i)
13348         zi=c(3,nres+i)
13349 !
13350 ! Calculate SC interaction energy.
13351 !
13352         do iint=1,nint_gr(i)
13353 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13354 !d   &                  'iend=',iend(i,iint)
13355           do j=istart(i,iint),iend(i,iint)
13356             itypj=itype(j,1)
13357             if (itypj.eq.ntyp1) cycle
13358             xj=c(1,nres+j)-xi
13359             yj=c(2,nres+j)-yi
13360             zj=c(3,nres+j)-zi
13361             rij=xj*xj+yj*yj+zj*zj
13362             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13363             if (sss.lt.1.0d0) then
13364               rrij=1.0D0/rij
13365               eps0ij=eps(itypi,itypj)
13366               fac=rrij**expon2
13367               e1=fac*fac*aa_aq(itypi,itypj)
13368               e2=fac*bb_aq(itypi,itypj)
13369               evdwij=e1+e2
13370               evdw=evdw+(1.0d0-sss)*evdwij
13371 !
13372 ! Calculate the components of the gradient in DC and X
13373 !
13374               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13375               gg(1)=xj*fac
13376               gg(2)=yj*fac
13377               gg(3)=zj*fac
13378               do k=1,3
13379                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13380                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13381                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13382                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13383               enddo
13384             endif
13385           enddo      ! j
13386         enddo        ! iint
13387       enddo          ! i
13388       do i=1,nct
13389         do j=1,3
13390           gvdwc(j,i)=expon*gvdwc(j,i)
13391           gvdwx(j,i)=expon*gvdwx(j,i)
13392         enddo
13393       enddo
13394 !******************************************************************************
13395 !
13396 !                              N O T E !!!
13397 !
13398 ! To save time, the factor of EXPON has been extracted from ALL components
13399 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13400 ! use!
13401 !
13402 !******************************************************************************
13403       return
13404       end subroutine elj_long
13405 !-----------------------------------------------------------------------------
13406       subroutine elj_short(evdw)
13407 !
13408 ! This subroutine calculates the interaction energy of nonbonded side chains
13409 ! assuming the LJ potential of interaction.
13410 !
13411 !      implicit real*8 (a-h,o-z)
13412 !      include 'DIMENSIONS'
13413 !      include 'COMMON.GEO'
13414 !      include 'COMMON.VAR'
13415 !      include 'COMMON.LOCAL'
13416 !      include 'COMMON.CHAIN'
13417 !      include 'COMMON.DERIV'
13418 !      include 'COMMON.INTERACT'
13419 !      include 'COMMON.TORSION'
13420 !      include 'COMMON.SBRIDGE'
13421 !      include 'COMMON.NAMES'
13422 !      include 'COMMON.IOUNITS'
13423 !      include 'COMMON.CONTACTS'
13424       real(kind=8),parameter :: accur=1.0d-10
13425       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13426 !el local variables
13427       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13428       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13429       real(kind=8) :: e1,e2,evdwij,evdw
13430 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13431       evdw=0.0D0
13432       do i=iatsc_s,iatsc_e
13433         itypi=itype(i,1)
13434         if (itypi.eq.ntyp1) cycle
13435         itypi1=itype(i+1,1)
13436         xi=c(1,nres+i)
13437         yi=c(2,nres+i)
13438         zi=c(3,nres+i)
13439 ! Change 12/1/95
13440         num_conti=0
13441 !
13442 ! Calculate SC interaction energy.
13443 !
13444         do iint=1,nint_gr(i)
13445 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13446 !d   &                  'iend=',iend(i,iint)
13447           do j=istart(i,iint),iend(i,iint)
13448             itypj=itype(j,1)
13449             if (itypj.eq.ntyp1) cycle
13450             xj=c(1,nres+j)-xi
13451             yj=c(2,nres+j)-yi
13452             zj=c(3,nres+j)-zi
13453 ! Change 12/1/95 to calculate four-body interactions
13454             rij=xj*xj+yj*yj+zj*zj
13455             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13456             if (sss.gt.0.0d0) then
13457               rrij=1.0D0/rij
13458               eps0ij=eps(itypi,itypj)
13459               fac=rrij**expon2
13460               e1=fac*fac*aa_aq(itypi,itypj)
13461               e2=fac*bb_aq(itypi,itypj)
13462               evdwij=e1+e2
13463               evdw=evdw+sss*evdwij
13464 !
13465 ! Calculate the components of the gradient in DC and X
13466 !
13467               fac=-rrij*(e1+evdwij)*sss
13468               gg(1)=xj*fac
13469               gg(2)=yj*fac
13470               gg(3)=zj*fac
13471               do k=1,3
13472                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13473                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13474                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13475                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13476               enddo
13477             endif
13478           enddo      ! j
13479         enddo        ! iint
13480       enddo          ! i
13481       do i=1,nct
13482         do j=1,3
13483           gvdwc(j,i)=expon*gvdwc(j,i)
13484           gvdwx(j,i)=expon*gvdwx(j,i)
13485         enddo
13486       enddo
13487 !******************************************************************************
13488 !
13489 !                              N O T E !!!
13490 !
13491 ! To save time, the factor of EXPON has been extracted from ALL components
13492 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13493 ! use!
13494 !
13495 !******************************************************************************
13496       return
13497       end subroutine elj_short
13498 !-----------------------------------------------------------------------------
13499       subroutine eljk_long(evdw)
13500 !
13501 ! This subroutine calculates the interaction energy of nonbonded side chains
13502 ! assuming the LJK potential of interaction.
13503 !
13504 !      implicit real*8 (a-h,o-z)
13505 !      include 'DIMENSIONS'
13506 !      include 'COMMON.GEO'
13507 !      include 'COMMON.VAR'
13508 !      include 'COMMON.LOCAL'
13509 !      include 'COMMON.CHAIN'
13510 !      include 'COMMON.DERIV'
13511 !      include 'COMMON.INTERACT'
13512 !      include 'COMMON.IOUNITS'
13513 !      include 'COMMON.NAMES'
13514       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13515       logical :: scheck
13516 !el local variables
13517       integer :: i,iint,j,k,itypi,itypi1,itypj
13518       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13519                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13520 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13521       evdw=0.0D0
13522       do i=iatsc_s,iatsc_e
13523         itypi=itype(i,1)
13524         if (itypi.eq.ntyp1) cycle
13525         itypi1=itype(i+1,1)
13526         xi=c(1,nres+i)
13527         yi=c(2,nres+i)
13528         zi=c(3,nres+i)
13529 !
13530 ! Calculate SC interaction energy.
13531 !
13532         do iint=1,nint_gr(i)
13533           do j=istart(i,iint),iend(i,iint)
13534             itypj=itype(j,1)
13535             if (itypj.eq.ntyp1) cycle
13536             xj=c(1,nres+j)-xi
13537             yj=c(2,nres+j)-yi
13538             zj=c(3,nres+j)-zi
13539             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13540             fac_augm=rrij**expon
13541             e_augm=augm(itypi,itypj)*fac_augm
13542             r_inv_ij=dsqrt(rrij)
13543             rij=1.0D0/r_inv_ij
13544             sss=sscale(rij/sigma(itypi,itypj))
13545             if (sss.lt.1.0d0) then
13546               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13547               fac=r_shift_inv**expon
13548               e1=fac*fac*aa_aq(itypi,itypj)
13549               e2=fac*bb_aq(itypi,itypj)
13550               evdwij=e_augm+e1+e2
13551 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13552 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13553 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13554 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13555 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13556 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13557 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13558               evdw=evdw+(1.0d0-sss)*evdwij
13559 !
13560 ! Calculate the components of the gradient in DC and X
13561 !
13562               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13563               fac=fac*(1.0d0-sss)
13564               gg(1)=xj*fac
13565               gg(2)=yj*fac
13566               gg(3)=zj*fac
13567               do k=1,3
13568                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13569                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13570                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13571                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13572               enddo
13573             endif
13574           enddo      ! j
13575         enddo        ! iint
13576       enddo          ! i
13577       do i=1,nct
13578         do j=1,3
13579           gvdwc(j,i)=expon*gvdwc(j,i)
13580           gvdwx(j,i)=expon*gvdwx(j,i)
13581         enddo
13582       enddo
13583       return
13584       end subroutine eljk_long
13585 !-----------------------------------------------------------------------------
13586       subroutine eljk_short(evdw)
13587 !
13588 ! This subroutine calculates the interaction energy of nonbonded side chains
13589 ! assuming the LJK potential of interaction.
13590 !
13591 !      implicit real*8 (a-h,o-z)
13592 !      include 'DIMENSIONS'
13593 !      include 'COMMON.GEO'
13594 !      include 'COMMON.VAR'
13595 !      include 'COMMON.LOCAL'
13596 !      include 'COMMON.CHAIN'
13597 !      include 'COMMON.DERIV'
13598 !      include 'COMMON.INTERACT'
13599 !      include 'COMMON.IOUNITS'
13600 !      include 'COMMON.NAMES'
13601       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13602       logical :: scheck
13603 !el local variables
13604       integer :: i,iint,j,k,itypi,itypi1,itypj
13605       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13606                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13607 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13608       evdw=0.0D0
13609       do i=iatsc_s,iatsc_e
13610         itypi=itype(i,1)
13611         if (itypi.eq.ntyp1) cycle
13612         itypi1=itype(i+1,1)
13613         xi=c(1,nres+i)
13614         yi=c(2,nres+i)
13615         zi=c(3,nres+i)
13616 !
13617 ! Calculate SC interaction energy.
13618 !
13619         do iint=1,nint_gr(i)
13620           do j=istart(i,iint),iend(i,iint)
13621             itypj=itype(j,1)
13622             if (itypj.eq.ntyp1) cycle
13623             xj=c(1,nres+j)-xi
13624             yj=c(2,nres+j)-yi
13625             zj=c(3,nres+j)-zi
13626             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13627             fac_augm=rrij**expon
13628             e_augm=augm(itypi,itypj)*fac_augm
13629             r_inv_ij=dsqrt(rrij)
13630             rij=1.0D0/r_inv_ij
13631             sss=sscale(rij/sigma(itypi,itypj))
13632             if (sss.gt.0.0d0) then
13633               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13634               fac=r_shift_inv**expon
13635               e1=fac*fac*aa_aq(itypi,itypj)
13636               e2=fac*bb_aq(itypi,itypj)
13637               evdwij=e_augm+e1+e2
13638 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13639 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13640 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13641 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13642 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13643 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13644 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13645               evdw=evdw+sss*evdwij
13646 !
13647 ! Calculate the components of the gradient in DC and X
13648 !
13649               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13650               fac=fac*sss
13651               gg(1)=xj*fac
13652               gg(2)=yj*fac
13653               gg(3)=zj*fac
13654               do k=1,3
13655                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13656                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13657                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13658                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13659               enddo
13660             endif
13661           enddo      ! j
13662         enddo        ! iint
13663       enddo          ! i
13664       do i=1,nct
13665         do j=1,3
13666           gvdwc(j,i)=expon*gvdwc(j,i)
13667           gvdwx(j,i)=expon*gvdwx(j,i)
13668         enddo
13669       enddo
13670       return
13671       end subroutine eljk_short
13672 !-----------------------------------------------------------------------------
13673       subroutine ebp_long(evdw)
13674 !
13675 ! This subroutine calculates the interaction energy of nonbonded side chains
13676 ! assuming the Berne-Pechukas potential of interaction.
13677 !
13678       use calc_data
13679 !      implicit real*8 (a-h,o-z)
13680 !      include 'DIMENSIONS'
13681 !      include 'COMMON.GEO'
13682 !      include 'COMMON.VAR'
13683 !      include 'COMMON.LOCAL'
13684 !      include 'COMMON.CHAIN'
13685 !      include 'COMMON.DERIV'
13686 !      include 'COMMON.NAMES'
13687 !      include 'COMMON.INTERACT'
13688 !      include 'COMMON.IOUNITS'
13689 !      include 'COMMON.CALC'
13690       use comm_srutu
13691 !el      integer :: icall
13692 !el      common /srutu/ icall
13693 !     double precision rrsave(maxdim)
13694       logical :: lprn
13695 !el local variables
13696       integer :: iint,itypi,itypi1,itypj
13697       real(kind=8) :: rrij,xi,yi,zi,fac
13698       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13699       evdw=0.0D0
13700 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13701       evdw=0.0D0
13702 !     if (icall.eq.0) then
13703 !       lprn=.true.
13704 !     else
13705         lprn=.false.
13706 !     endif
13707 !el      ind=0
13708       do i=iatsc_s,iatsc_e
13709         itypi=itype(i,1)
13710         if (itypi.eq.ntyp1) cycle
13711         itypi1=itype(i+1,1)
13712         xi=c(1,nres+i)
13713         yi=c(2,nres+i)
13714         zi=c(3,nres+i)
13715         dxi=dc_norm(1,nres+i)
13716         dyi=dc_norm(2,nres+i)
13717         dzi=dc_norm(3,nres+i)
13718 !        dsci_inv=dsc_inv(itypi)
13719         dsci_inv=vbld_inv(i+nres)
13720 !
13721 ! Calculate SC interaction energy.
13722 !
13723         do iint=1,nint_gr(i)
13724           do j=istart(i,iint),iend(i,iint)
13725 !el            ind=ind+1
13726             itypj=itype(j,1)
13727             if (itypj.eq.ntyp1) cycle
13728 !            dscj_inv=dsc_inv(itypj)
13729             dscj_inv=vbld_inv(j+nres)
13730             chi1=chi(itypi,itypj)
13731             chi2=chi(itypj,itypi)
13732             chi12=chi1*chi2
13733             chip1=chip(itypi)
13734             chip2=chip(itypj)
13735             chip12=chip1*chip2
13736             alf1=alp(itypi)
13737             alf2=alp(itypj)
13738             alf12=0.5D0*(alf1+alf2)
13739             xj=c(1,nres+j)-xi
13740             yj=c(2,nres+j)-yi
13741             zj=c(3,nres+j)-zi
13742             dxj=dc_norm(1,nres+j)
13743             dyj=dc_norm(2,nres+j)
13744             dzj=dc_norm(3,nres+j)
13745             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13746             rij=dsqrt(rrij)
13747             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13748
13749             if (sss.lt.1.0d0) then
13750
13751 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13752               call sc_angular
13753 ! Calculate whole angle-dependent part of epsilon and contributions
13754 ! to its derivatives
13755               fac=(rrij*sigsq)**expon2
13756               e1=fac*fac*aa_aq(itypi,itypj)
13757               e2=fac*bb_aq(itypi,itypj)
13758               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13759               eps2der=evdwij*eps3rt
13760               eps3der=evdwij*eps2rt
13761               evdwij=evdwij*eps2rt*eps3rt
13762               evdw=evdw+evdwij*(1.0d0-sss)
13763               if (lprn) then
13764               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13765               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13766 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13767 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13768 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13769 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13770 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13771 !d     &          evdwij
13772               endif
13773 ! Calculate gradient components.
13774               e1=e1*eps1*eps2rt**2*eps3rt**2
13775               fac=-expon*(e1+evdwij)
13776               sigder=fac/sigsq
13777               fac=rrij*fac
13778 ! Calculate radial part of the gradient
13779               gg(1)=xj*fac
13780               gg(2)=yj*fac
13781               gg(3)=zj*fac
13782 ! Calculate the angular part of the gradient and sum add the contributions
13783 ! to the appropriate components of the Cartesian gradient.
13784               call sc_grad_scale(1.0d0-sss)
13785             endif
13786           enddo      ! j
13787         enddo        ! iint
13788       enddo          ! i
13789 !     stop
13790       return
13791       end subroutine ebp_long
13792 !-----------------------------------------------------------------------------
13793       subroutine ebp_short(evdw)
13794 !
13795 ! This subroutine calculates the interaction energy of nonbonded side chains
13796 ! assuming the Berne-Pechukas potential of interaction.
13797 !
13798       use calc_data
13799 !      implicit real*8 (a-h,o-z)
13800 !      include 'DIMENSIONS'
13801 !      include 'COMMON.GEO'
13802 !      include 'COMMON.VAR'
13803 !      include 'COMMON.LOCAL'
13804 !      include 'COMMON.CHAIN'
13805 !      include 'COMMON.DERIV'
13806 !      include 'COMMON.NAMES'
13807 !      include 'COMMON.INTERACT'
13808 !      include 'COMMON.IOUNITS'
13809 !      include 'COMMON.CALC'
13810       use comm_srutu
13811 !el      integer :: icall
13812 !el      common /srutu/ icall
13813 !     double precision rrsave(maxdim)
13814       logical :: lprn
13815 !el local variables
13816       integer :: iint,itypi,itypi1,itypj
13817       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13818       real(kind=8) :: sss,e1,e2,evdw
13819       evdw=0.0D0
13820 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13821       evdw=0.0D0
13822 !     if (icall.eq.0) then
13823 !       lprn=.true.
13824 !     else
13825         lprn=.false.
13826 !     endif
13827 !el      ind=0
13828       do i=iatsc_s,iatsc_e
13829         itypi=itype(i,1)
13830         if (itypi.eq.ntyp1) cycle
13831         itypi1=itype(i+1,1)
13832         xi=c(1,nres+i)
13833         yi=c(2,nres+i)
13834         zi=c(3,nres+i)
13835         dxi=dc_norm(1,nres+i)
13836         dyi=dc_norm(2,nres+i)
13837         dzi=dc_norm(3,nres+i)
13838 !        dsci_inv=dsc_inv(itypi)
13839         dsci_inv=vbld_inv(i+nres)
13840 !
13841 ! Calculate SC interaction energy.
13842 !
13843         do iint=1,nint_gr(i)
13844           do j=istart(i,iint),iend(i,iint)
13845 !el            ind=ind+1
13846             itypj=itype(j,1)
13847             if (itypj.eq.ntyp1) cycle
13848 !            dscj_inv=dsc_inv(itypj)
13849             dscj_inv=vbld_inv(j+nres)
13850             chi1=chi(itypi,itypj)
13851             chi2=chi(itypj,itypi)
13852             chi12=chi1*chi2
13853             chip1=chip(itypi)
13854             chip2=chip(itypj)
13855             chip12=chip1*chip2
13856             alf1=alp(itypi)
13857             alf2=alp(itypj)
13858             alf12=0.5D0*(alf1+alf2)
13859             xj=c(1,nres+j)-xi
13860             yj=c(2,nres+j)-yi
13861             zj=c(3,nres+j)-zi
13862             dxj=dc_norm(1,nres+j)
13863             dyj=dc_norm(2,nres+j)
13864             dzj=dc_norm(3,nres+j)
13865             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13866             rij=dsqrt(rrij)
13867             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13868
13869             if (sss.gt.0.0d0) then
13870
13871 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13872               call sc_angular
13873 ! Calculate whole angle-dependent part of epsilon and contributions
13874 ! to its derivatives
13875               fac=(rrij*sigsq)**expon2
13876               e1=fac*fac*aa_aq(itypi,itypj)
13877               e2=fac*bb_aq(itypi,itypj)
13878               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13879               eps2der=evdwij*eps3rt
13880               eps3der=evdwij*eps2rt
13881               evdwij=evdwij*eps2rt*eps3rt
13882               evdw=evdw+evdwij*sss
13883               if (lprn) then
13884               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13885               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13886 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13887 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13888 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13889 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13890 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13891 !d     &          evdwij
13892               endif
13893 ! Calculate gradient components.
13894               e1=e1*eps1*eps2rt**2*eps3rt**2
13895               fac=-expon*(e1+evdwij)
13896               sigder=fac/sigsq
13897               fac=rrij*fac
13898 ! Calculate radial part of the gradient
13899               gg(1)=xj*fac
13900               gg(2)=yj*fac
13901               gg(3)=zj*fac
13902 ! Calculate the angular part of the gradient and sum add the contributions
13903 ! to the appropriate components of the Cartesian gradient.
13904               call sc_grad_scale(sss)
13905             endif
13906           enddo      ! j
13907         enddo        ! iint
13908       enddo          ! i
13909 !     stop
13910       return
13911       end subroutine ebp_short
13912 !-----------------------------------------------------------------------------
13913       subroutine egb_long(evdw)
13914 !
13915 ! This subroutine calculates the interaction energy of nonbonded side chains
13916 ! assuming the Gay-Berne potential of interaction.
13917 !
13918       use calc_data
13919 !      implicit real*8 (a-h,o-z)
13920 !      include 'DIMENSIONS'
13921 !      include 'COMMON.GEO'
13922 !      include 'COMMON.VAR'
13923 !      include 'COMMON.LOCAL'
13924 !      include 'COMMON.CHAIN'
13925 !      include 'COMMON.DERIV'
13926 !      include 'COMMON.NAMES'
13927 !      include 'COMMON.INTERACT'
13928 !      include 'COMMON.IOUNITS'
13929 !      include 'COMMON.CALC'
13930 !      include 'COMMON.CONTROL'
13931       logical :: lprn
13932 !el local variables
13933       integer :: iint,itypi,itypi1,itypj,subchap
13934       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13935       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13936       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13937                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13938                     ssgradlipi,ssgradlipj
13939
13940
13941       evdw=0.0D0
13942 !cccc      energy_dec=.false.
13943 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13944       evdw=0.0D0
13945       lprn=.false.
13946 !     if (icall.eq.0) lprn=.false.
13947 !el      ind=0
13948       do i=iatsc_s,iatsc_e
13949         itypi=itype(i,1)
13950         if (itypi.eq.ntyp1) cycle
13951         itypi1=itype(i+1,1)
13952         xi=c(1,nres+i)
13953         yi=c(2,nres+i)
13954         zi=c(3,nres+i)
13955           xi=mod(xi,boxxsize)
13956           if (xi.lt.0) xi=xi+boxxsize
13957           yi=mod(yi,boxysize)
13958           if (yi.lt.0) yi=yi+boxysize
13959           zi=mod(zi,boxzsize)
13960           if (zi.lt.0) zi=zi+boxzsize
13961        if ((zi.gt.bordlipbot)    &
13962         .and.(zi.lt.bordliptop)) then
13963 !C the energy transfer exist
13964         if (zi.lt.buflipbot) then
13965 !C what fraction I am in
13966          fracinbuf=1.0d0-    &
13967              ((zi-bordlipbot)/lipbufthick)
13968 !C lipbufthick is thickenes of lipid buffore
13969          sslipi=sscalelip(fracinbuf)
13970          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13971         elseif (zi.gt.bufliptop) then
13972          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13973          sslipi=sscalelip(fracinbuf)
13974          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13975         else
13976          sslipi=1.0d0
13977          ssgradlipi=0.0
13978         endif
13979        else
13980          sslipi=0.0d0
13981          ssgradlipi=0.0
13982        endif
13983
13984         dxi=dc_norm(1,nres+i)
13985         dyi=dc_norm(2,nres+i)
13986         dzi=dc_norm(3,nres+i)
13987 !        dsci_inv=dsc_inv(itypi)
13988         dsci_inv=vbld_inv(i+nres)
13989 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13990 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13991 !
13992 ! Calculate SC interaction energy.
13993 !
13994         do iint=1,nint_gr(i)
13995           do j=istart(i,iint),iend(i,iint)
13996             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13997 !              call dyn_ssbond_ene(i,j,evdwij)
13998 !              evdw=evdw+evdwij
13999 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14000 !                              'evdw',i,j,evdwij,' ss'
14001 !              if (energy_dec) write (iout,*) &
14002 !                              'evdw',i,j,evdwij,' ss'
14003 !             do k=j+1,iend(i,iint)
14004 !C search over all next residues
14005 !              if (dyn_ss_mask(k)) then
14006 !C check if they are cysteins
14007 !C              write(iout,*) 'k=',k
14008
14009 !c              write(iout,*) "PRZED TRI", evdwij
14010 !               evdwij_przed_tri=evdwij
14011 !              call triple_ssbond_ene(i,j,k,evdwij)
14012 !c               if(evdwij_przed_tri.ne.evdwij) then
14013 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14014 !c               endif
14015
14016 !c              write(iout,*) "PO TRI", evdwij
14017 !C call the energy function that removes the artifical triple disulfide
14018 !C bond the soubroutine is located in ssMD.F
14019 !              evdw=evdw+evdwij
14020               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14021                             'evdw',i,j,evdwij,'tss'
14022 !              endif!dyn_ss_mask(k)
14023 !             enddo! k
14024
14025             ELSE
14026 !el            ind=ind+1
14027             itypj=itype(j,1)
14028             if (itypj.eq.ntyp1) cycle
14029 !            dscj_inv=dsc_inv(itypj)
14030             dscj_inv=vbld_inv(j+nres)
14031 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14032 !     &       1.0d0/vbld(j+nres)
14033 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14034             sig0ij=sigma(itypi,itypj)
14035             chi1=chi(itypi,itypj)
14036             chi2=chi(itypj,itypi)
14037             chi12=chi1*chi2
14038             chip1=chip(itypi)
14039             chip2=chip(itypj)
14040             chip12=chip1*chip2
14041             alf1=alp(itypi)
14042             alf2=alp(itypj)
14043             alf12=0.5D0*(alf1+alf2)
14044             xj=c(1,nres+j)
14045             yj=c(2,nres+j)
14046             zj=c(3,nres+j)
14047 ! Searching for nearest neighbour
14048           xj=mod(xj,boxxsize)
14049           if (xj.lt.0) xj=xj+boxxsize
14050           yj=mod(yj,boxysize)
14051           if (yj.lt.0) yj=yj+boxysize
14052           zj=mod(zj,boxzsize)
14053           if (zj.lt.0) zj=zj+boxzsize
14054        if ((zj.gt.bordlipbot)   &
14055       .and.(zj.lt.bordliptop)) then
14056 !C the energy transfer exist
14057         if (zj.lt.buflipbot) then
14058 !C what fraction I am in
14059          fracinbuf=1.0d0-  &
14060              ((zj-bordlipbot)/lipbufthick)
14061 !C lipbufthick is thickenes of lipid buffore
14062          sslipj=sscalelip(fracinbuf)
14063          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14064         elseif (zj.gt.bufliptop) then
14065          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14066          sslipj=sscalelip(fracinbuf)
14067          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14068         else
14069          sslipj=1.0d0
14070          ssgradlipj=0.0
14071         endif
14072        else
14073          sslipj=0.0d0
14074          ssgradlipj=0.0
14075        endif
14076       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14077        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14078       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14079        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14080
14081           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14082           xj_safe=xj
14083           yj_safe=yj
14084           zj_safe=zj
14085           subchap=0
14086           do xshift=-1,1
14087           do yshift=-1,1
14088           do zshift=-1,1
14089           xj=xj_safe+xshift*boxxsize
14090           yj=yj_safe+yshift*boxysize
14091           zj=zj_safe+zshift*boxzsize
14092           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14093           if(dist_temp.lt.dist_init) then
14094             dist_init=dist_temp
14095             xj_temp=xj
14096             yj_temp=yj
14097             zj_temp=zj
14098             subchap=1
14099           endif
14100           enddo
14101           enddo
14102           enddo
14103           if (subchap.eq.1) then
14104           xj=xj_temp-xi
14105           yj=yj_temp-yi
14106           zj=zj_temp-zi
14107           else
14108           xj=xj_safe-xi
14109           yj=yj_safe-yi
14110           zj=zj_safe-zi
14111           endif
14112
14113             dxj=dc_norm(1,nres+j)
14114             dyj=dc_norm(2,nres+j)
14115             dzj=dc_norm(3,nres+j)
14116             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14117             rij=dsqrt(rrij)
14118             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14119             sss_ele_cut=sscale_ele(1.0d0/(rij))
14120             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14121             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14122             if (sss_ele_cut.le.0.0) cycle
14123             if (sss.lt.1.0d0) then
14124
14125 ! Calculate angle-dependent terms of energy and contributions to their
14126 ! derivatives.
14127               call sc_angular
14128               sigsq=1.0D0/sigsq
14129               sig=sig0ij*dsqrt(sigsq)
14130               rij_shift=1.0D0/rij-sig+sig0ij
14131 ! for diagnostics; uncomment
14132 !              rij_shift=1.2*sig0ij
14133 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14134               if (rij_shift.le.0.0D0) then
14135                 evdw=1.0D20
14136 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14137 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14138 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14139                 return
14140               endif
14141               sigder=-sig*sigsq
14142 !---------------------------------------------------------------
14143               rij_shift=1.0D0/rij_shift
14144               fac=rij_shift**expon
14145               e1=fac*fac*aa
14146               e2=fac*bb
14147               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14148               eps2der=evdwij*eps3rt
14149               eps3der=evdwij*eps2rt
14150 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14151 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14152               evdwij=evdwij*eps2rt*eps3rt
14153               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14154               if (lprn) then
14155               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14156               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14157               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14158                 restyp(itypi,1),i,restyp(itypj,1),j,&
14159                 epsi,sigm,chi1,chi2,chip1,chip2,&
14160                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14161                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14162                 evdwij
14163               endif
14164
14165               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14166                               'evdw',i,j,evdwij
14167 !              if (energy_dec) write (iout,*) &
14168 !                              'evdw',i,j,evdwij,"egb_long"
14169
14170 ! Calculate gradient components.
14171               e1=e1*eps1*eps2rt**2*eps3rt**2
14172               fac=-expon*(e1+evdwij)*rij_shift
14173               sigder=fac*sigder
14174               fac=rij*fac
14175               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14176               *rij-sss_grad/(1.0-sss)*rij  &
14177             /sigmaii(itypi,itypj))
14178 !              fac=0.0d0
14179 ! Calculate the radial part of the gradient
14180               gg(1)=xj*fac
14181               gg(2)=yj*fac
14182               gg(3)=zj*fac
14183 ! Calculate angular part of the gradient.
14184               call sc_grad_scale(1.0d0-sss)
14185             ENDIF    !mask_dyn_ss
14186             endif
14187           enddo      ! j
14188         enddo        ! iint
14189       enddo          ! i
14190 !      write (iout,*) "Number of loop steps in EGB:",ind
14191 !ccc      energy_dec=.false.
14192       return
14193       end subroutine egb_long
14194 !-----------------------------------------------------------------------------
14195       subroutine egb_short(evdw)
14196 !
14197 ! This subroutine calculates the interaction energy of nonbonded side chains
14198 ! assuming the Gay-Berne potential of interaction.
14199 !
14200       use calc_data
14201 !      implicit real*8 (a-h,o-z)
14202 !      include 'DIMENSIONS'
14203 !      include 'COMMON.GEO'
14204 !      include 'COMMON.VAR'
14205 !      include 'COMMON.LOCAL'
14206 !      include 'COMMON.CHAIN'
14207 !      include 'COMMON.DERIV'
14208 !      include 'COMMON.NAMES'
14209 !      include 'COMMON.INTERACT'
14210 !      include 'COMMON.IOUNITS'
14211 !      include 'COMMON.CALC'
14212 !      include 'COMMON.CONTROL'
14213       logical :: lprn
14214 !el local variables
14215       integer :: iint,itypi,itypi1,itypj,subchap
14216       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14217       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14218       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14219                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14220                     ssgradlipi,ssgradlipj
14221       evdw=0.0D0
14222 !cccc      energy_dec=.false.
14223 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14224       evdw=0.0D0
14225       lprn=.false.
14226 !     if (icall.eq.0) lprn=.false.
14227 !el      ind=0
14228       do i=iatsc_s,iatsc_e
14229         itypi=itype(i,1)
14230         if (itypi.eq.ntyp1) cycle
14231         itypi1=itype(i+1,1)
14232         xi=c(1,nres+i)
14233         yi=c(2,nres+i)
14234         zi=c(3,nres+i)
14235           xi=mod(xi,boxxsize)
14236           if (xi.lt.0) xi=xi+boxxsize
14237           yi=mod(yi,boxysize)
14238           if (yi.lt.0) yi=yi+boxysize
14239           zi=mod(zi,boxzsize)
14240           if (zi.lt.0) zi=zi+boxzsize
14241        if ((zi.gt.bordlipbot)    &
14242         .and.(zi.lt.bordliptop)) then
14243 !C the energy transfer exist
14244         if (zi.lt.buflipbot) then
14245 !C what fraction I am in
14246          fracinbuf=1.0d0-    &
14247              ((zi-bordlipbot)/lipbufthick)
14248 !C lipbufthick is thickenes of lipid buffore
14249          sslipi=sscalelip(fracinbuf)
14250          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14251         elseif (zi.gt.bufliptop) then
14252          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14253          sslipi=sscalelip(fracinbuf)
14254          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14255         else
14256          sslipi=1.0d0
14257          ssgradlipi=0.0
14258         endif
14259        else
14260          sslipi=0.0d0
14261          ssgradlipi=0.0
14262        endif
14263
14264         dxi=dc_norm(1,nres+i)
14265         dyi=dc_norm(2,nres+i)
14266         dzi=dc_norm(3,nres+i)
14267 !        dsci_inv=dsc_inv(itypi)
14268         dsci_inv=vbld_inv(i+nres)
14269
14270         dxi=dc_norm(1,nres+i)
14271         dyi=dc_norm(2,nres+i)
14272         dzi=dc_norm(3,nres+i)
14273 !        dsci_inv=dsc_inv(itypi)
14274         dsci_inv=vbld_inv(i+nres)
14275 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14276 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14277 !
14278 ! Calculate SC interaction energy.
14279 !
14280         do iint=1,nint_gr(i)
14281           do j=istart(i,iint),iend(i,iint)
14282             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14283               call dyn_ssbond_ene(i,j,evdwij)
14284               evdw=evdw+evdwij
14285               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14286                               'evdw',i,j,evdwij,' ss'
14287              do k=j+1,iend(i,iint)
14288 !C search over all next residues
14289               if (dyn_ss_mask(k)) then
14290 !C check if they are cysteins
14291 !C              write(iout,*) 'k=',k
14292
14293 !c              write(iout,*) "PRZED TRI", evdwij
14294 !               evdwij_przed_tri=evdwij
14295               call triple_ssbond_ene(i,j,k,evdwij)
14296 !c               if(evdwij_przed_tri.ne.evdwij) then
14297 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14298 !c               endif
14299
14300 !c              write(iout,*) "PO TRI", evdwij
14301 !C call the energy function that removes the artifical triple disulfide
14302 !C bond the soubroutine is located in ssMD.F
14303               evdw=evdw+evdwij
14304               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14305                             'evdw',i,j,evdwij,'tss'
14306               endif!dyn_ss_mask(k)
14307              enddo! k
14308
14309 !              if (energy_dec) write (iout,*) &
14310 !                              'evdw',i,j,evdwij,' ss'
14311             ELSE
14312 !el            ind=ind+1
14313             itypj=itype(j,1)
14314             if (itypj.eq.ntyp1) cycle
14315 !            dscj_inv=dsc_inv(itypj)
14316             dscj_inv=vbld_inv(j+nres)
14317 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14318 !     &       1.0d0/vbld(j+nres)
14319 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14320             sig0ij=sigma(itypi,itypj)
14321             chi1=chi(itypi,itypj)
14322             chi2=chi(itypj,itypi)
14323             chi12=chi1*chi2
14324             chip1=chip(itypi)
14325             chip2=chip(itypj)
14326             chip12=chip1*chip2
14327             alf1=alp(itypi)
14328             alf2=alp(itypj)
14329             alf12=0.5D0*(alf1+alf2)
14330 !            xj=c(1,nres+j)-xi
14331 !            yj=c(2,nres+j)-yi
14332 !            zj=c(3,nres+j)-zi
14333             xj=c(1,nres+j)
14334             yj=c(2,nres+j)
14335             zj=c(3,nres+j)
14336 ! Searching for nearest neighbour
14337           xj=mod(xj,boxxsize)
14338           if (xj.lt.0) xj=xj+boxxsize
14339           yj=mod(yj,boxysize)
14340           if (yj.lt.0) yj=yj+boxysize
14341           zj=mod(zj,boxzsize)
14342           if (zj.lt.0) zj=zj+boxzsize
14343        if ((zj.gt.bordlipbot)   &
14344       .and.(zj.lt.bordliptop)) then
14345 !C the energy transfer exist
14346         if (zj.lt.buflipbot) then
14347 !C what fraction I am in
14348          fracinbuf=1.0d0-  &
14349              ((zj-bordlipbot)/lipbufthick)
14350 !C lipbufthick is thickenes of lipid buffore
14351          sslipj=sscalelip(fracinbuf)
14352          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14353         elseif (zj.gt.bufliptop) then
14354          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14355          sslipj=sscalelip(fracinbuf)
14356          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14357         else
14358          sslipj=1.0d0
14359          ssgradlipj=0.0
14360         endif
14361        else
14362          sslipj=0.0d0
14363          ssgradlipj=0.0
14364        endif
14365       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14366        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14367       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14368        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14369
14370           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14371           xj_safe=xj
14372           yj_safe=yj
14373           zj_safe=zj
14374           subchap=0
14375
14376           do xshift=-1,1
14377           do yshift=-1,1
14378           do zshift=-1,1
14379           xj=xj_safe+xshift*boxxsize
14380           yj=yj_safe+yshift*boxysize
14381           zj=zj_safe+zshift*boxzsize
14382           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14383           if(dist_temp.lt.dist_init) then
14384             dist_init=dist_temp
14385             xj_temp=xj
14386             yj_temp=yj
14387             zj_temp=zj
14388             subchap=1
14389           endif
14390           enddo
14391           enddo
14392           enddo
14393           if (subchap.eq.1) then
14394           xj=xj_temp-xi
14395           yj=yj_temp-yi
14396           zj=zj_temp-zi
14397           else
14398           xj=xj_safe-xi
14399           yj=yj_safe-yi
14400           zj=zj_safe-zi
14401           endif
14402
14403             dxj=dc_norm(1,nres+j)
14404             dyj=dc_norm(2,nres+j)
14405             dzj=dc_norm(3,nres+j)
14406             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14407             rij=dsqrt(rrij)
14408             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14409             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14410             sss_ele_cut=sscale_ele(1.0d0/(rij))
14411             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14412             if (sss_ele_cut.le.0.0) cycle
14413
14414             if (sss.gt.0.0d0) then
14415
14416 ! Calculate angle-dependent terms of energy and contributions to their
14417 ! derivatives.
14418               call sc_angular
14419               sigsq=1.0D0/sigsq
14420               sig=sig0ij*dsqrt(sigsq)
14421               rij_shift=1.0D0/rij-sig+sig0ij
14422 ! for diagnostics; uncomment
14423 !              rij_shift=1.2*sig0ij
14424 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14425               if (rij_shift.le.0.0D0) then
14426                 evdw=1.0D20
14427 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14428 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14429 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14430                 return
14431               endif
14432               sigder=-sig*sigsq
14433 !---------------------------------------------------------------
14434               rij_shift=1.0D0/rij_shift
14435               fac=rij_shift**expon
14436               e1=fac*fac*aa
14437               e2=fac*bb
14438               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14439               eps2der=evdwij*eps3rt
14440               eps3der=evdwij*eps2rt
14441 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14442 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14443               evdwij=evdwij*eps2rt*eps3rt
14444               evdw=evdw+evdwij*sss*sss_ele_cut
14445               if (lprn) then
14446               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14447               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14448               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14449                 restyp(itypi,1),i,restyp(itypj,1),j,&
14450                 epsi,sigm,chi1,chi2,chip1,chip2,&
14451                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14452                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14453                 evdwij
14454               endif
14455
14456               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14457                               'evdw',i,j,evdwij
14458 !              if (energy_dec) write (iout,*) &
14459 !                              'evdw',i,j,evdwij,"egb_short"
14460
14461 ! Calculate gradient components.
14462               e1=e1*eps1*eps2rt**2*eps3rt**2
14463               fac=-expon*(e1+evdwij)*rij_shift
14464               sigder=fac*sigder
14465               fac=rij*fac
14466               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14467             *rij+sss_grad/sss*rij  &
14468             /sigmaii(itypi,itypj))
14469
14470 !              fac=0.0d0
14471 ! Calculate the radial part of the gradient
14472               gg(1)=xj*fac
14473               gg(2)=yj*fac
14474               gg(3)=zj*fac
14475 ! Calculate angular part of the gradient.
14476               call sc_grad_scale(sss)
14477             endif
14478           ENDIF !mask_dyn_ss
14479           enddo      ! j
14480         enddo        ! iint
14481       enddo          ! i
14482 !      write (iout,*) "Number of loop steps in EGB:",ind
14483 !ccc      energy_dec=.false.
14484       return
14485       end subroutine egb_short
14486 !-----------------------------------------------------------------------------
14487       subroutine egbv_long(evdw)
14488 !
14489 ! This subroutine calculates the interaction energy of nonbonded side chains
14490 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14491 !
14492       use calc_data
14493 !      implicit real*8 (a-h,o-z)
14494 !      include 'DIMENSIONS'
14495 !      include 'COMMON.GEO'
14496 !      include 'COMMON.VAR'
14497 !      include 'COMMON.LOCAL'
14498 !      include 'COMMON.CHAIN'
14499 !      include 'COMMON.DERIV'
14500 !      include 'COMMON.NAMES'
14501 !      include 'COMMON.INTERACT'
14502 !      include 'COMMON.IOUNITS'
14503 !      include 'COMMON.CALC'
14504       use comm_srutu
14505 !el      integer :: icall
14506 !el      common /srutu/ icall
14507       logical :: lprn
14508 !el local variables
14509       integer :: iint,itypi,itypi1,itypj
14510       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14511       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14512       evdw=0.0D0
14513 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14514       evdw=0.0D0
14515       lprn=.false.
14516 !     if (icall.eq.0) lprn=.true.
14517 !el      ind=0
14518       do i=iatsc_s,iatsc_e
14519         itypi=itype(i,1)
14520         if (itypi.eq.ntyp1) cycle
14521         itypi1=itype(i+1,1)
14522         xi=c(1,nres+i)
14523         yi=c(2,nres+i)
14524         zi=c(3,nres+i)
14525         dxi=dc_norm(1,nres+i)
14526         dyi=dc_norm(2,nres+i)
14527         dzi=dc_norm(3,nres+i)
14528 !        dsci_inv=dsc_inv(itypi)
14529         dsci_inv=vbld_inv(i+nres)
14530 !
14531 ! Calculate SC interaction energy.
14532 !
14533         do iint=1,nint_gr(i)
14534           do j=istart(i,iint),iend(i,iint)
14535 !el            ind=ind+1
14536             itypj=itype(j,1)
14537             if (itypj.eq.ntyp1) cycle
14538 !            dscj_inv=dsc_inv(itypj)
14539             dscj_inv=vbld_inv(j+nres)
14540             sig0ij=sigma(itypi,itypj)
14541             r0ij=r0(itypi,itypj)
14542             chi1=chi(itypi,itypj)
14543             chi2=chi(itypj,itypi)
14544             chi12=chi1*chi2
14545             chip1=chip(itypi)
14546             chip2=chip(itypj)
14547             chip12=chip1*chip2
14548             alf1=alp(itypi)
14549             alf2=alp(itypj)
14550             alf12=0.5D0*(alf1+alf2)
14551             xj=c(1,nres+j)-xi
14552             yj=c(2,nres+j)-yi
14553             zj=c(3,nres+j)-zi
14554             dxj=dc_norm(1,nres+j)
14555             dyj=dc_norm(2,nres+j)
14556             dzj=dc_norm(3,nres+j)
14557             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14558             rij=dsqrt(rrij)
14559
14560             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14561
14562             if (sss.lt.1.0d0) then
14563
14564 ! Calculate angle-dependent terms of energy and contributions to their
14565 ! derivatives.
14566               call sc_angular
14567               sigsq=1.0D0/sigsq
14568               sig=sig0ij*dsqrt(sigsq)
14569               rij_shift=1.0D0/rij-sig+r0ij
14570 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14571               if (rij_shift.le.0.0D0) then
14572                 evdw=1.0D20
14573                 return
14574               endif
14575               sigder=-sig*sigsq
14576 !---------------------------------------------------------------
14577               rij_shift=1.0D0/rij_shift
14578               fac=rij_shift**expon
14579               e1=fac*fac*aa_aq(itypi,itypj)
14580               e2=fac*bb_aq(itypi,itypj)
14581               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14582               eps2der=evdwij*eps3rt
14583               eps3der=evdwij*eps2rt
14584               fac_augm=rrij**expon
14585               e_augm=augm(itypi,itypj)*fac_augm
14586               evdwij=evdwij*eps2rt*eps3rt
14587               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14588               if (lprn) then
14589               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14590               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14591               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14592                 restyp(itypi,1),i,restyp(itypj,1),j,&
14593                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14594                 chi1,chi2,chip1,chip2,&
14595                 eps1,eps2rt**2,eps3rt**2,&
14596                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14597                 evdwij+e_augm
14598               endif
14599 ! Calculate gradient components.
14600               e1=e1*eps1*eps2rt**2*eps3rt**2
14601               fac=-expon*(e1+evdwij)*rij_shift
14602               sigder=fac*sigder
14603               fac=rij*fac-2*expon*rrij*e_augm
14604 ! Calculate the radial part of the gradient
14605               gg(1)=xj*fac
14606               gg(2)=yj*fac
14607               gg(3)=zj*fac
14608 ! Calculate angular part of the gradient.
14609               call sc_grad_scale(1.0d0-sss)
14610             endif
14611           enddo      ! j
14612         enddo        ! iint
14613       enddo          ! i
14614       end subroutine egbv_long
14615 !-----------------------------------------------------------------------------
14616       subroutine egbv_short(evdw)
14617 !
14618 ! This subroutine calculates the interaction energy of nonbonded side chains
14619 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14620 !
14621       use calc_data
14622 !      implicit real*8 (a-h,o-z)
14623 !      include 'DIMENSIONS'
14624 !      include 'COMMON.GEO'
14625 !      include 'COMMON.VAR'
14626 !      include 'COMMON.LOCAL'
14627 !      include 'COMMON.CHAIN'
14628 !      include 'COMMON.DERIV'
14629 !      include 'COMMON.NAMES'
14630 !      include 'COMMON.INTERACT'
14631 !      include 'COMMON.IOUNITS'
14632 !      include 'COMMON.CALC'
14633       use comm_srutu
14634 !el      integer :: icall
14635 !el      common /srutu/ icall
14636       logical :: lprn
14637 !el local variables
14638       integer :: iint,itypi,itypi1,itypj
14639       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14640       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14641       evdw=0.0D0
14642 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14643       evdw=0.0D0
14644       lprn=.false.
14645 !     if (icall.eq.0) lprn=.true.
14646 !el      ind=0
14647       do i=iatsc_s,iatsc_e
14648         itypi=itype(i,1)
14649         if (itypi.eq.ntyp1) cycle
14650         itypi1=itype(i+1,1)
14651         xi=c(1,nres+i)
14652         yi=c(2,nres+i)
14653         zi=c(3,nres+i)
14654         dxi=dc_norm(1,nres+i)
14655         dyi=dc_norm(2,nres+i)
14656         dzi=dc_norm(3,nres+i)
14657 !        dsci_inv=dsc_inv(itypi)
14658         dsci_inv=vbld_inv(i+nres)
14659 !
14660 ! Calculate SC interaction energy.
14661 !
14662         do iint=1,nint_gr(i)
14663           do j=istart(i,iint),iend(i,iint)
14664 !el            ind=ind+1
14665             itypj=itype(j,1)
14666             if (itypj.eq.ntyp1) cycle
14667 !            dscj_inv=dsc_inv(itypj)
14668             dscj_inv=vbld_inv(j+nres)
14669             sig0ij=sigma(itypi,itypj)
14670             r0ij=r0(itypi,itypj)
14671             chi1=chi(itypi,itypj)
14672             chi2=chi(itypj,itypi)
14673             chi12=chi1*chi2
14674             chip1=chip(itypi)
14675             chip2=chip(itypj)
14676             chip12=chip1*chip2
14677             alf1=alp(itypi)
14678             alf2=alp(itypj)
14679             alf12=0.5D0*(alf1+alf2)
14680             xj=c(1,nres+j)-xi
14681             yj=c(2,nres+j)-yi
14682             zj=c(3,nres+j)-zi
14683             dxj=dc_norm(1,nres+j)
14684             dyj=dc_norm(2,nres+j)
14685             dzj=dc_norm(3,nres+j)
14686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14687             rij=dsqrt(rrij)
14688
14689             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14690
14691             if (sss.gt.0.0d0) then
14692
14693 ! Calculate angle-dependent terms of energy and contributions to their
14694 ! derivatives.
14695               call sc_angular
14696               sigsq=1.0D0/sigsq
14697               sig=sig0ij*dsqrt(sigsq)
14698               rij_shift=1.0D0/rij-sig+r0ij
14699 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14700               if (rij_shift.le.0.0D0) then
14701                 evdw=1.0D20
14702                 return
14703               endif
14704               sigder=-sig*sigsq
14705 !---------------------------------------------------------------
14706               rij_shift=1.0D0/rij_shift
14707               fac=rij_shift**expon
14708               e1=fac*fac*aa_aq(itypi,itypj)
14709               e2=fac*bb_aq(itypi,itypj)
14710               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14711               eps2der=evdwij*eps3rt
14712               eps3der=evdwij*eps2rt
14713               fac_augm=rrij**expon
14714               e_augm=augm(itypi,itypj)*fac_augm
14715               evdwij=evdwij*eps2rt*eps3rt
14716               evdw=evdw+(evdwij+e_augm)*sss
14717               if (lprn) then
14718               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14719               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14720               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14721                 restyp(itypi,1),i,restyp(itypj,1),j,&
14722                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14723                 chi1,chi2,chip1,chip2,&
14724                 eps1,eps2rt**2,eps3rt**2,&
14725                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14726                 evdwij+e_augm
14727               endif
14728 ! Calculate gradient components.
14729               e1=e1*eps1*eps2rt**2*eps3rt**2
14730               fac=-expon*(e1+evdwij)*rij_shift
14731               sigder=fac*sigder
14732               fac=rij*fac-2*expon*rrij*e_augm
14733 ! Calculate the radial part of the gradient
14734               gg(1)=xj*fac
14735               gg(2)=yj*fac
14736               gg(3)=zj*fac
14737 ! Calculate angular part of the gradient.
14738               call sc_grad_scale(sss)
14739             endif
14740           enddo      ! j
14741         enddo        ! iint
14742       enddo          ! i
14743       end subroutine egbv_short
14744 !-----------------------------------------------------------------------------
14745       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14746 !
14747 ! This subroutine calculates the average interaction energy and its gradient
14748 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14749 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14750 ! The potential depends both on the distance of peptide-group centers and on
14751 ! the orientation of the CA-CA virtual bonds.
14752 !
14753 !      implicit real*8 (a-h,o-z)
14754
14755       use comm_locel
14756 #ifdef MPI
14757       include 'mpif.h'
14758 #endif
14759 !      include 'DIMENSIONS'
14760 !      include 'COMMON.CONTROL'
14761 !      include 'COMMON.SETUP'
14762 !      include 'COMMON.IOUNITS'
14763 !      include 'COMMON.GEO'
14764 !      include 'COMMON.VAR'
14765 !      include 'COMMON.LOCAL'
14766 !      include 'COMMON.CHAIN'
14767 !      include 'COMMON.DERIV'
14768 !      include 'COMMON.INTERACT'
14769 !      include 'COMMON.CONTACTS'
14770 !      include 'COMMON.TORSION'
14771 !      include 'COMMON.VECTORS'
14772 !      include 'COMMON.FFIELD'
14773 !      include 'COMMON.TIME1'
14774       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14775       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14776       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14777 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14778       real(kind=8),dimension(4) :: muij
14779 !el      integer :: num_conti,j1,j2
14780 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14781 !el                   dz_normi,xmedi,ymedi,zmedi
14782 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14783 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14784 !el          num_conti,j1,j2
14785 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14786 #ifdef MOMENT
14787       real(kind=8) :: scal_el=1.0d0
14788 #else
14789       real(kind=8) :: scal_el=0.5d0
14790 #endif
14791 ! 12/13/98
14792 ! 13-go grudnia roku pamietnego...
14793       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14794                                              0.0d0,1.0d0,0.0d0,&
14795                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14796 !el local variables
14797       integer :: i,j,k
14798       real(kind=8) :: fac
14799       real(kind=8) :: dxj,dyj,dzj
14800       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14801
14802 !      allocate(num_cont_hb(nres)) !(maxres)
14803 !d      write(iout,*) 'In EELEC'
14804 !d      do i=1,nloctyp
14805 !d        write(iout,*) 'Type',i
14806 !d        write(iout,*) 'B1',B1(:,i)
14807 !d        write(iout,*) 'B2',B2(:,i)
14808 !d        write(iout,*) 'CC',CC(:,:,i)
14809 !d        write(iout,*) 'DD',DD(:,:,i)
14810 !d        write(iout,*) 'EE',EE(:,:,i)
14811 !d      enddo
14812 !d      call check_vecgrad
14813 !d      stop
14814       if (icheckgrad.eq.1) then
14815         do i=1,nres-1
14816           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14817           do k=1,3
14818             dc_norm(k,i)=dc(k,i)*fac
14819           enddo
14820 !          write (iout,*) 'i',i,' fac',fac
14821         enddo
14822       endif
14823       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14824           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14825           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14826 !        call vec_and_deriv
14827 #ifdef TIMING
14828         time01=MPI_Wtime()
14829 #endif
14830 !        print *, "before set matrices"
14831         call set_matrices
14832 !        print *,"after set martices"
14833 #ifdef TIMING
14834         time_mat=time_mat+MPI_Wtime()-time01
14835 #endif
14836       endif
14837 !d      do i=1,nres-1
14838 !d        write (iout,*) 'i=',i
14839 !d        do k=1,3
14840 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14841 !d        enddo
14842 !d        do k=1,3
14843 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14844 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14845 !d        enddo
14846 !d      enddo
14847       t_eelecij=0.0d0
14848       ees=0.0D0
14849       evdw1=0.0D0
14850       eel_loc=0.0d0
14851       eello_turn3=0.0d0
14852       eello_turn4=0.0d0
14853 !el      ind=0
14854       do i=1,nres
14855         num_cont_hb(i)=0
14856       enddo
14857 !d      print '(a)','Enter EELEC'
14858 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14859 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14860 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14861       do i=1,nres
14862         gel_loc_loc(i)=0.0d0
14863         gcorr_loc(i)=0.0d0
14864       enddo
14865 !
14866 !
14867 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14868 !
14869 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14870 !
14871       do i=iturn3_start,iturn3_end
14872         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14873         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14874         dxi=dc(1,i)
14875         dyi=dc(2,i)
14876         dzi=dc(3,i)
14877         dx_normi=dc_norm(1,i)
14878         dy_normi=dc_norm(2,i)
14879         dz_normi=dc_norm(3,i)
14880         xmedi=c(1,i)+0.5d0*dxi
14881         ymedi=c(2,i)+0.5d0*dyi
14882         zmedi=c(3,i)+0.5d0*dzi
14883           xmedi=dmod(xmedi,boxxsize)
14884           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14885           ymedi=dmod(ymedi,boxysize)
14886           if (ymedi.lt.0) ymedi=ymedi+boxysize
14887           zmedi=dmod(zmedi,boxzsize)
14888           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14889         num_conti=0
14890         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14891         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14892         num_cont_hb(i)=num_conti
14893       enddo
14894       do i=iturn4_start,iturn4_end
14895         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14896           .or. itype(i+3,1).eq.ntyp1 &
14897           .or. itype(i+4,1).eq.ntyp1) cycle
14898         dxi=dc(1,i)
14899         dyi=dc(2,i)
14900         dzi=dc(3,i)
14901         dx_normi=dc_norm(1,i)
14902         dy_normi=dc_norm(2,i)
14903         dz_normi=dc_norm(3,i)
14904         xmedi=c(1,i)+0.5d0*dxi
14905         ymedi=c(2,i)+0.5d0*dyi
14906         zmedi=c(3,i)+0.5d0*dzi
14907           xmedi=dmod(xmedi,boxxsize)
14908           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14909           ymedi=dmod(ymedi,boxysize)
14910           if (ymedi.lt.0) ymedi=ymedi+boxysize
14911           zmedi=dmod(zmedi,boxzsize)
14912           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14913         num_conti=num_cont_hb(i)
14914         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14915         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14916           call eturn4(i,eello_turn4)
14917         num_cont_hb(i)=num_conti
14918       enddo   ! i
14919 !
14920 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14921 !
14922       do i=iatel_s,iatel_e
14923         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14924         dxi=dc(1,i)
14925         dyi=dc(2,i)
14926         dzi=dc(3,i)
14927         dx_normi=dc_norm(1,i)
14928         dy_normi=dc_norm(2,i)
14929         dz_normi=dc_norm(3,i)
14930         xmedi=c(1,i)+0.5d0*dxi
14931         ymedi=c(2,i)+0.5d0*dyi
14932         zmedi=c(3,i)+0.5d0*dzi
14933           xmedi=dmod(xmedi,boxxsize)
14934           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14935           ymedi=dmod(ymedi,boxysize)
14936           if (ymedi.lt.0) ymedi=ymedi+boxysize
14937           zmedi=dmod(zmedi,boxzsize)
14938           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14939 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14940         num_conti=num_cont_hb(i)
14941         do j=ielstart(i),ielend(i)
14942           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14943           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14944         enddo ! j
14945         num_cont_hb(i)=num_conti
14946       enddo   ! i
14947 !      write (iout,*) "Number of loop steps in EELEC:",ind
14948 !d      do i=1,nres
14949 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14950 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14951 !d      enddo
14952 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14953 !cc      eel_loc=eel_loc+eello_turn3
14954 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14955       return
14956       end subroutine eelec_scale
14957 !-----------------------------------------------------------------------------
14958       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14959 !      implicit real*8 (a-h,o-z)
14960
14961       use comm_locel
14962 !      include 'DIMENSIONS'
14963 #ifdef MPI
14964       include "mpif.h"
14965 #endif
14966 !      include 'COMMON.CONTROL'
14967 !      include 'COMMON.IOUNITS'
14968 !      include 'COMMON.GEO'
14969 !      include 'COMMON.VAR'
14970 !      include 'COMMON.LOCAL'
14971 !      include 'COMMON.CHAIN'
14972 !      include 'COMMON.DERIV'
14973 !      include 'COMMON.INTERACT'
14974 !      include 'COMMON.CONTACTS'
14975 !      include 'COMMON.TORSION'
14976 !      include 'COMMON.VECTORS'
14977 !      include 'COMMON.FFIELD'
14978 !      include 'COMMON.TIME1'
14979       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14980       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14981       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14982 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14983       real(kind=8),dimension(4) :: muij
14984       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14985                     dist_temp, dist_init,sss_grad
14986       integer xshift,yshift,zshift
14987
14988 !el      integer :: num_conti,j1,j2
14989 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14990 !el                   dz_normi,xmedi,ymedi,zmedi
14991 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14992 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14993 !el          num_conti,j1,j2
14994 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14995 #ifdef MOMENT
14996       real(kind=8) :: scal_el=1.0d0
14997 #else
14998       real(kind=8) :: scal_el=0.5d0
14999 #endif
15000 ! 12/13/98
15001 ! 13-go grudnia roku pamietnego...
15002       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15003                                              0.0d0,1.0d0,0.0d0,&
15004                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15005 !el local variables
15006       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15007       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15008       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15009       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15010       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15011       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15012       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15013                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15014                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15015                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15016                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15017                   ecosam,ecosbm,ecosgm,ghalf,time00
15018 !      integer :: maxconts
15019 !      maxconts = nres/4
15020 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15021 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15022 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15023 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15024 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15025 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15026 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15027 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15028 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15029 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15030 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15031 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15032 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15033
15034 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15035 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15036
15037 #ifdef MPI
15038           time00=MPI_Wtime()
15039 #endif
15040 !d      write (iout,*) "eelecij",i,j
15041 !el          ind=ind+1
15042           iteli=itel(i)
15043           itelj=itel(j)
15044           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15045           aaa=app(iteli,itelj)
15046           bbb=bpp(iteli,itelj)
15047           ael6i=ael6(iteli,itelj)
15048           ael3i=ael3(iteli,itelj)
15049           dxj=dc(1,j)
15050           dyj=dc(2,j)
15051           dzj=dc(3,j)
15052           dx_normj=dc_norm(1,j)
15053           dy_normj=dc_norm(2,j)
15054           dz_normj=dc_norm(3,j)
15055 !          xj=c(1,j)+0.5D0*dxj-xmedi
15056 !          yj=c(2,j)+0.5D0*dyj-ymedi
15057 !          zj=c(3,j)+0.5D0*dzj-zmedi
15058           xj=c(1,j)+0.5D0*dxj
15059           yj=c(2,j)+0.5D0*dyj
15060           zj=c(3,j)+0.5D0*dzj
15061           xj=mod(xj,boxxsize)
15062           if (xj.lt.0) xj=xj+boxxsize
15063           yj=mod(yj,boxysize)
15064           if (yj.lt.0) yj=yj+boxysize
15065           zj=mod(zj,boxzsize)
15066           if (zj.lt.0) zj=zj+boxzsize
15067       isubchap=0
15068       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15069       xj_safe=xj
15070       yj_safe=yj
15071       zj_safe=zj
15072       do xshift=-1,1
15073       do yshift=-1,1
15074       do zshift=-1,1
15075           xj=xj_safe+xshift*boxxsize
15076           yj=yj_safe+yshift*boxysize
15077           zj=zj_safe+zshift*boxzsize
15078           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15079           if(dist_temp.lt.dist_init) then
15080             dist_init=dist_temp
15081             xj_temp=xj
15082             yj_temp=yj
15083             zj_temp=zj
15084             isubchap=1
15085           endif
15086        enddo
15087        enddo
15088        enddo
15089        if (isubchap.eq.1) then
15090 !C          print *,i,j
15091           xj=xj_temp-xmedi
15092           yj=yj_temp-ymedi
15093           zj=zj_temp-zmedi
15094        else
15095           xj=xj_safe-xmedi
15096           yj=yj_safe-ymedi
15097           zj=zj_safe-zmedi
15098        endif
15099
15100           rij=xj*xj+yj*yj+zj*zj
15101           rrmij=1.0D0/rij
15102           rij=dsqrt(rij)
15103           rmij=1.0D0/rij
15104 ! For extracting the short-range part of Evdwpp
15105           sss=sscale(rij/rpp(iteli,itelj))
15106             sss_ele_cut=sscale_ele(rij)
15107             sss_ele_grad=sscagrad_ele(rij)
15108             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15109 !             sss_ele_cut=1.0d0
15110 !             sss_ele_grad=0.0d0
15111             if (sss_ele_cut.le.0.0) go to 128
15112
15113           r3ij=rrmij*rmij
15114           r6ij=r3ij*r3ij
15115           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15116           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15117           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15118           fac=cosa-3.0D0*cosb*cosg
15119           ev1=aaa*r6ij*r6ij
15120 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15121           if (j.eq.i+2) ev1=scal_el*ev1
15122           ev2=bbb*r6ij
15123           fac3=ael6i*r6ij
15124           fac4=ael3i*r3ij
15125           evdwij=ev1+ev2
15126           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15127           el2=fac4*fac
15128           eesij=el1+el2
15129 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15130           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15131           ees=ees+eesij*sss_ele_cut
15132           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15133 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15134 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15135 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15136 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15137
15138           if (energy_dec) then
15139               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15140               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15141           endif
15142
15143 !
15144 ! Calculate contributions to the Cartesian gradient.
15145 !
15146 #ifdef SPLITELE
15147           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15148           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15149           fac1=fac
15150           erij(1)=xj*rmij
15151           erij(2)=yj*rmij
15152           erij(3)=zj*rmij
15153 !
15154 ! Radial derivatives. First process both termini of the fragment (i,j)
15155 !
15156           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15157           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15158           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15159 !          do k=1,3
15160 !            ghalf=0.5D0*ggg(k)
15161 !            gelc(k,i)=gelc(k,i)+ghalf
15162 !            gelc(k,j)=gelc(k,j)+ghalf
15163 !          enddo
15164 ! 9/28/08 AL Gradient compotents will be summed only at the end
15165           do k=1,3
15166             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15167             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15168           enddo
15169 !
15170 ! Loop over residues i+1 thru j-1.
15171 !
15172 !grad          do k=i+1,j-1
15173 !grad            do l=1,3
15174 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15175 !grad            enddo
15176 !grad          enddo
15177           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15178           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15179           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15180           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15181           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15182           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15183 !          do k=1,3
15184 !            ghalf=0.5D0*ggg(k)
15185 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15186 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15187 !          enddo
15188 ! 9/28/08 AL Gradient compotents will be summed only at the end
15189           do k=1,3
15190             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15191             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15192           enddo
15193 !
15194 ! Loop over residues i+1 thru j-1.
15195 !
15196 !grad          do k=i+1,j-1
15197 !grad            do l=1,3
15198 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15199 !grad            enddo
15200 !grad          enddo
15201 #else
15202           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15203           facel=(el1+eesij)*sss_ele_cut
15204           fac1=fac
15205           fac=-3*rrmij*(facvdw+facvdw+facel)
15206           erij(1)=xj*rmij
15207           erij(2)=yj*rmij
15208           erij(3)=zj*rmij
15209 !
15210 ! Radial derivatives. First process both termini of the fragment (i,j)
15211 !
15212           ggg(1)=fac*xj
15213           ggg(2)=fac*yj
15214           ggg(3)=fac*zj
15215 !          do k=1,3
15216 !            ghalf=0.5D0*ggg(k)
15217 !            gelc(k,i)=gelc(k,i)+ghalf
15218 !            gelc(k,j)=gelc(k,j)+ghalf
15219 !          enddo
15220 ! 9/28/08 AL Gradient compotents will be summed only at the end
15221           do k=1,3
15222             gelc_long(k,j)=gelc(k,j)+ggg(k)
15223             gelc_long(k,i)=gelc(k,i)-ggg(k)
15224           enddo
15225 !
15226 ! Loop over residues i+1 thru j-1.
15227 !
15228 !grad          do k=i+1,j-1
15229 !grad            do l=1,3
15230 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15231 !grad            enddo
15232 !grad          enddo
15233 ! 9/28/08 AL Gradient compotents will be summed only at the end
15234           ggg(1)=facvdw*xj
15235           ggg(2)=facvdw*yj
15236           ggg(3)=facvdw*zj
15237           do k=1,3
15238             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15239             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15240           enddo
15241 #endif
15242 !
15243 ! Angular part
15244 !
15245           ecosa=2.0D0*fac3*fac1+fac4
15246           fac4=-3.0D0*fac4
15247           fac3=-6.0D0*fac3
15248           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15249           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15250           do k=1,3
15251             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15252             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15253           enddo
15254 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15255 !d   &          (dcosg(k),k=1,3)
15256           do k=1,3
15257             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15258           enddo
15259 !          do k=1,3
15260 !            ghalf=0.5D0*ggg(k)
15261 !            gelc(k,i)=gelc(k,i)+ghalf
15262 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15263 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15264 !            gelc(k,j)=gelc(k,j)+ghalf
15265 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15266 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15267 !          enddo
15268 !grad          do k=i+1,j-1
15269 !grad            do l=1,3
15270 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15271 !grad            enddo
15272 !grad          enddo
15273           do k=1,3
15274             gelc(k,i)=gelc(k,i) &
15275                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15276                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15277                      *sss_ele_cut
15278             gelc(k,j)=gelc(k,j) &
15279                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15280                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15281                      *sss_ele_cut
15282             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15283             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15284           enddo
15285           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15286               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15287               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15288 !
15289 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15290 !   energy of a peptide unit is assumed in the form of a second-order
15291 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15292 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15293 !   are computed for EVERY pair of non-contiguous peptide groups.
15294 !
15295           if (j.lt.nres-1) then
15296             j1=j+1
15297             j2=j-1
15298           else
15299             j1=j-1
15300             j2=j-2
15301           endif
15302           kkk=0
15303           do k=1,2
15304             do l=1,2
15305               kkk=kkk+1
15306               muij(kkk)=mu(k,i)*mu(l,j)
15307             enddo
15308           enddo
15309 !d         write (iout,*) 'EELEC: i',i,' j',j
15310 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15311 !d          write(iout,*) 'muij',muij
15312           ury=scalar(uy(1,i),erij)
15313           urz=scalar(uz(1,i),erij)
15314           vry=scalar(uy(1,j),erij)
15315           vrz=scalar(uz(1,j),erij)
15316           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15317           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15318           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15319           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15320           fac=dsqrt(-ael6i)*r3ij
15321           a22=a22*fac
15322           a23=a23*fac
15323           a32=a32*fac
15324           a33=a33*fac
15325 !d          write (iout,'(4i5,4f10.5)')
15326 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15327 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15328 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15329 !d     &      uy(:,j),uz(:,j)
15330 !d          write (iout,'(4f10.5)')
15331 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15332 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15333 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15334 !d           write (iout,'(9f10.5/)')
15335 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15336 ! Derivatives of the elements of A in virtual-bond vectors
15337           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15338           do k=1,3
15339             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15340             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15341             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15342             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15343             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15344             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15345             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15346             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15347             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15348             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15349             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15350             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15351           enddo
15352 ! Compute radial contributions to the gradient
15353           facr=-3.0d0*rrmij
15354           a22der=a22*facr
15355           a23der=a23*facr
15356           a32der=a32*facr
15357           a33der=a33*facr
15358           agg(1,1)=a22der*xj
15359           agg(2,1)=a22der*yj
15360           agg(3,1)=a22der*zj
15361           agg(1,2)=a23der*xj
15362           agg(2,2)=a23der*yj
15363           agg(3,2)=a23der*zj
15364           agg(1,3)=a32der*xj
15365           agg(2,3)=a32der*yj
15366           agg(3,3)=a32der*zj
15367           agg(1,4)=a33der*xj
15368           agg(2,4)=a33der*yj
15369           agg(3,4)=a33der*zj
15370 ! Add the contributions coming from er
15371           fac3=-3.0d0*fac
15372           do k=1,3
15373             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15374             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15375             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15376             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15377           enddo
15378           do k=1,3
15379 ! Derivatives in DC(i)
15380 !grad            ghalf1=0.5d0*agg(k,1)
15381 !grad            ghalf2=0.5d0*agg(k,2)
15382 !grad            ghalf3=0.5d0*agg(k,3)
15383 !grad            ghalf4=0.5d0*agg(k,4)
15384             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15385             -3.0d0*uryg(k,2)*vry)!+ghalf1
15386             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15387             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15388             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15389             -3.0d0*urzg(k,2)*vry)!+ghalf3
15390             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15391             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15392 ! Derivatives in DC(i+1)
15393             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15394             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15395             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15396             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15397             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15398             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15399             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15400             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15401 ! Derivatives in DC(j)
15402             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15403             -3.0d0*vryg(k,2)*ury)!+ghalf1
15404             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15405             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15406             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15407             -3.0d0*vryg(k,2)*urz)!+ghalf3
15408             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15409             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15410 ! Derivatives in DC(j+1) or DC(nres-1)
15411             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15412             -3.0d0*vryg(k,3)*ury)
15413             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15414             -3.0d0*vrzg(k,3)*ury)
15415             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15416             -3.0d0*vryg(k,3)*urz)
15417             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15418             -3.0d0*vrzg(k,3)*urz)
15419 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15420 !grad              do l=1,4
15421 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15422 !grad              enddo
15423 !grad            endif
15424           enddo
15425           acipa(1,1)=a22
15426           acipa(1,2)=a23
15427           acipa(2,1)=a32
15428           acipa(2,2)=a33
15429           a22=-a22
15430           a23=-a23
15431           do l=1,2
15432             do k=1,3
15433               agg(k,l)=-agg(k,l)
15434               aggi(k,l)=-aggi(k,l)
15435               aggi1(k,l)=-aggi1(k,l)
15436               aggj(k,l)=-aggj(k,l)
15437               aggj1(k,l)=-aggj1(k,l)
15438             enddo
15439           enddo
15440           if (j.lt.nres-1) then
15441             a22=-a22
15442             a32=-a32
15443             do l=1,3,2
15444               do k=1,3
15445                 agg(k,l)=-agg(k,l)
15446                 aggi(k,l)=-aggi(k,l)
15447                 aggi1(k,l)=-aggi1(k,l)
15448                 aggj(k,l)=-aggj(k,l)
15449                 aggj1(k,l)=-aggj1(k,l)
15450               enddo
15451             enddo
15452           else
15453             a22=-a22
15454             a23=-a23
15455             a32=-a32
15456             a33=-a33
15457             do l=1,4
15458               do k=1,3
15459                 agg(k,l)=-agg(k,l)
15460                 aggi(k,l)=-aggi(k,l)
15461                 aggi1(k,l)=-aggi1(k,l)
15462                 aggj(k,l)=-aggj(k,l)
15463                 aggj1(k,l)=-aggj1(k,l)
15464               enddo
15465             enddo
15466           endif
15467           ENDIF ! WCORR
15468           IF (wel_loc.gt.0.0d0) THEN
15469 ! Contribution to the local-electrostatic energy coming from the i-j pair
15470           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15471            +a33*muij(4)
15472 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15473 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15474           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15475                   'eelloc',i,j,eel_loc_ij
15476 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15477
15478           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15479 ! Partial derivatives in virtual-bond dihedral angles gamma
15480           if (i.gt.1) &
15481           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15482                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15483                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15484                  *sss_ele_cut
15485           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15486                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15487                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15488                  *sss_ele_cut
15489            xtemp(1)=xj
15490            xtemp(2)=yj
15491            xtemp(3)=zj
15492
15493 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15494           do l=1,3
15495             ggg(l)=(agg(l,1)*muij(1)+ &
15496                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15497             *sss_ele_cut &
15498              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15499
15500             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15501             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15502 !grad            ghalf=0.5d0*ggg(l)
15503 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15504 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15505           enddo
15506 !grad          do k=i+1,j2
15507 !grad            do l=1,3
15508 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15509 !grad            enddo
15510 !grad          enddo
15511 ! Remaining derivatives of eello
15512           do l=1,3
15513             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15514                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15515             *sss_ele_cut
15516
15517             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15518                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15519             *sss_ele_cut
15520
15521             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15522                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15523             *sss_ele_cut
15524
15525             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15526                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15527             *sss_ele_cut
15528
15529           enddo
15530           ENDIF
15531 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15532 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15534              .and. num_conti.le.maxconts) then
15535 !            write (iout,*) i,j," entered corr"
15536 !
15537 ! Calculate the contact function. The ith column of the array JCONT will
15538 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15539 ! greater than I). The arrays FACONT and GACONT will contain the values of
15540 ! the contact function and its derivative.
15541 !           r0ij=1.02D0*rpp(iteli,itelj)
15542 !           r0ij=1.11D0*rpp(iteli,itelj)
15543             r0ij=2.20D0*rpp(iteli,itelj)
15544 !           r0ij=1.55D0*rpp(iteli,itelj)
15545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15546 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15547             if (fcont.gt.0.0D0) then
15548               num_conti=num_conti+1
15549               if (num_conti.gt.maxconts) then
15550 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15551                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15552                                ' will skip next contacts for this conf.',num_conti
15553               else
15554                 jcont_hb(num_conti,i)=j
15555 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15556 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15557                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15558                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15559 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15560 !  terms.
15561                 d_cont(num_conti,i)=rij
15562 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15563 !     --- Electrostatic-interaction matrix ---
15564                 a_chuj(1,1,num_conti,i)=a22
15565                 a_chuj(1,2,num_conti,i)=a23
15566                 a_chuj(2,1,num_conti,i)=a32
15567                 a_chuj(2,2,num_conti,i)=a33
15568 !     --- Gradient of rij
15569                 do kkk=1,3
15570                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15571                 enddo
15572                 kkll=0
15573                 do k=1,2
15574                   do l=1,2
15575                     kkll=kkll+1
15576                     do m=1,3
15577                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15578                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15579                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15580                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15581                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15582                     enddo
15583                   enddo
15584                 enddo
15585                 ENDIF
15586                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15587 ! Calculate contact energies
15588                 cosa4=4.0D0*cosa
15589                 wij=cosa-3.0D0*cosb*cosg
15590                 cosbg1=cosb+cosg
15591                 cosbg2=cosb-cosg
15592 !               fac3=dsqrt(-ael6i)/r0ij**3
15593                 fac3=dsqrt(-ael6i)*r3ij
15594 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15595                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15596                 if (ees0tmp.gt.0) then
15597                   ees0pij=dsqrt(ees0tmp)
15598                 else
15599                   ees0pij=0
15600                 endif
15601 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15602                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15603                 if (ees0tmp.gt.0) then
15604                   ees0mij=dsqrt(ees0tmp)
15605                 else
15606                   ees0mij=0
15607                 endif
15608 !               ees0mij=0.0D0
15609                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15610                      *sss_ele_cut
15611
15612                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15613                      *sss_ele_cut
15614
15615 ! Diagnostics. Comment out or remove after debugging!
15616 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15617 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15618 !               ees0m(num_conti,i)=0.0D0
15619 ! End diagnostics.
15620 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15621 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15622 ! Angular derivatives of the contact function
15623                 ees0pij1=fac3/ees0pij
15624                 ees0mij1=fac3/ees0mij
15625                 fac3p=-3.0D0*fac3*rrmij
15626                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15627                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15628 !               ees0mij1=0.0D0
15629                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15630                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15631                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15632                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15633                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15634                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15635                 ecosap=ecosa1+ecosa2
15636                 ecosbp=ecosb1+ecosb2
15637                 ecosgp=ecosg1+ecosg2
15638                 ecosam=ecosa1-ecosa2
15639                 ecosbm=ecosb1-ecosb2
15640                 ecosgm=ecosg1-ecosg2
15641 ! Diagnostics
15642 !               ecosap=ecosa1
15643 !               ecosbp=ecosb1
15644 !               ecosgp=ecosg1
15645 !               ecosam=0.0D0
15646 !               ecosbm=0.0D0
15647 !               ecosgm=0.0D0
15648 ! End diagnostics
15649                 facont_hb(num_conti,i)=fcont
15650                 fprimcont=fprimcont/rij
15651 !d              facont_hb(num_conti,i)=1.0D0
15652 ! Following line is for diagnostics.
15653 !d              fprimcont=0.0D0
15654                 do k=1,3
15655                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15656                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15657                 enddo
15658                 do k=1,3
15659                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15660                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15661                 enddo
15662 !                gggp(1)=gggp(1)+ees0pijp*xj
15663 !                gggp(2)=gggp(2)+ees0pijp*yj
15664 !                gggp(3)=gggp(3)+ees0pijp*zj
15665 !                gggm(1)=gggm(1)+ees0mijp*xj
15666 !                gggm(2)=gggm(2)+ees0mijp*yj
15667 !                gggm(3)=gggm(3)+ees0mijp*zj
15668                 gggp(1)=gggp(1)+ees0pijp*xj &
15669                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15670                 gggp(2)=gggp(2)+ees0pijp*yj &
15671                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15672                 gggp(3)=gggp(3)+ees0pijp*zj &
15673                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15674
15675                 gggm(1)=gggm(1)+ees0mijp*xj &
15676                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15677
15678                 gggm(2)=gggm(2)+ees0mijp*yj &
15679                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15680
15681                 gggm(3)=gggm(3)+ees0mijp*zj &
15682                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15683
15684 ! Derivatives due to the contact function
15685                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15686                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15687                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15688                 do k=1,3
15689 !
15690 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15691 !          following the change of gradient-summation algorithm.
15692 !
15693 !grad                  ghalfp=0.5D0*gggp(k)
15694 !grad                  ghalfm=0.5D0*gggm(k)
15695 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15696 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15697 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15698 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15699 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15700 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15701 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15702 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15703 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15704 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15705 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15706 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15707 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15708 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15709                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15710                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15711                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15712                      *sss_ele_cut
15713
15714                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15715                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15716                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15717                      *sss_ele_cut
15718
15719                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15720                      *sss_ele_cut
15721
15722                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15723                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15724                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15725                      *sss_ele_cut
15726
15727                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15728                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15729                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15730                      *sss_ele_cut
15731
15732                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15733                      *sss_ele_cut
15734
15735                 enddo
15736               ENDIF ! wcorr
15737               endif  ! num_conti.le.maxconts
15738             endif  ! fcont.gt.0
15739           endif    ! j.gt.i+1
15740           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15741             do k=1,4
15742               do l=1,3
15743                 ghalf=0.5d0*agg(l,k)
15744                 aggi(l,k)=aggi(l,k)+ghalf
15745                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15746                 aggj(l,k)=aggj(l,k)+ghalf
15747               enddo
15748             enddo
15749             if (j.eq.nres-1 .and. i.lt.j-2) then
15750               do k=1,4
15751                 do l=1,3
15752                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15753                 enddo
15754               enddo
15755             endif
15756           endif
15757  128      continue
15758 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15759       return
15760       end subroutine eelecij_scale
15761 !-----------------------------------------------------------------------------
15762       subroutine evdwpp_short(evdw1)
15763 !
15764 ! Compute Evdwpp
15765 !
15766 !      implicit real*8 (a-h,o-z)
15767 !      include 'DIMENSIONS'
15768 !      include 'COMMON.CONTROL'
15769 !      include 'COMMON.IOUNITS'
15770 !      include 'COMMON.GEO'
15771 !      include 'COMMON.VAR'
15772 !      include 'COMMON.LOCAL'
15773 !      include 'COMMON.CHAIN'
15774 !      include 'COMMON.DERIV'
15775 !      include 'COMMON.INTERACT'
15776 !      include 'COMMON.CONTACTS'
15777 !      include 'COMMON.TORSION'
15778 !      include 'COMMON.VECTORS'
15779 !      include 'COMMON.FFIELD'
15780       real(kind=8),dimension(3) :: ggg
15781 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15782 #ifdef MOMENT
15783       real(kind=8) :: scal_el=1.0d0
15784 #else
15785       real(kind=8) :: scal_el=0.5d0
15786 #endif
15787 !el local variables
15788       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15789       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15790       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15791                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15792                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15793       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15794                     dist_temp, dist_init,sss_grad
15795       integer xshift,yshift,zshift
15796
15797
15798       evdw1=0.0D0
15799 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15800 !     & " iatel_e_vdw",iatel_e_vdw
15801       call flush(iout)
15802       do i=iatel_s_vdw,iatel_e_vdw
15803         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15804         dxi=dc(1,i)
15805         dyi=dc(2,i)
15806         dzi=dc(3,i)
15807         dx_normi=dc_norm(1,i)
15808         dy_normi=dc_norm(2,i)
15809         dz_normi=dc_norm(3,i)
15810         xmedi=c(1,i)+0.5d0*dxi
15811         ymedi=c(2,i)+0.5d0*dyi
15812         zmedi=c(3,i)+0.5d0*dzi
15813           xmedi=dmod(xmedi,boxxsize)
15814           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15815           ymedi=dmod(ymedi,boxysize)
15816           if (ymedi.lt.0) ymedi=ymedi+boxysize
15817           zmedi=dmod(zmedi,boxzsize)
15818           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15819         num_conti=0
15820 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15821 !     &   ' ielend',ielend_vdw(i)
15822         call flush(iout)
15823         do j=ielstart_vdw(i),ielend_vdw(i)
15824           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15825 !el          ind=ind+1
15826           iteli=itel(i)
15827           itelj=itel(j)
15828           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15829           aaa=app(iteli,itelj)
15830           bbb=bpp(iteli,itelj)
15831           dxj=dc(1,j)
15832           dyj=dc(2,j)
15833           dzj=dc(3,j)
15834           dx_normj=dc_norm(1,j)
15835           dy_normj=dc_norm(2,j)
15836           dz_normj=dc_norm(3,j)
15837 !          xj=c(1,j)+0.5D0*dxj-xmedi
15838 !          yj=c(2,j)+0.5D0*dyj-ymedi
15839 !          zj=c(3,j)+0.5D0*dzj-zmedi
15840           xj=c(1,j)+0.5D0*dxj
15841           yj=c(2,j)+0.5D0*dyj
15842           zj=c(3,j)+0.5D0*dzj
15843           xj=mod(xj,boxxsize)
15844           if (xj.lt.0) xj=xj+boxxsize
15845           yj=mod(yj,boxysize)
15846           if (yj.lt.0) yj=yj+boxysize
15847           zj=mod(zj,boxzsize)
15848           if (zj.lt.0) zj=zj+boxzsize
15849       isubchap=0
15850       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15851       xj_safe=xj
15852       yj_safe=yj
15853       zj_safe=zj
15854       do xshift=-1,1
15855       do yshift=-1,1
15856       do zshift=-1,1
15857           xj=xj_safe+xshift*boxxsize
15858           yj=yj_safe+yshift*boxysize
15859           zj=zj_safe+zshift*boxzsize
15860           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15861           if(dist_temp.lt.dist_init) then
15862             dist_init=dist_temp
15863             xj_temp=xj
15864             yj_temp=yj
15865             zj_temp=zj
15866             isubchap=1
15867           endif
15868        enddo
15869        enddo
15870        enddo
15871        if (isubchap.eq.1) then
15872 !C          print *,i,j
15873           xj=xj_temp-xmedi
15874           yj=yj_temp-ymedi
15875           zj=zj_temp-zmedi
15876        else
15877           xj=xj_safe-xmedi
15878           yj=yj_safe-ymedi
15879           zj=zj_safe-zmedi
15880        endif
15881
15882           rij=xj*xj+yj*yj+zj*zj
15883           rrmij=1.0D0/rij
15884           rij=dsqrt(rij)
15885           sss=sscale(rij/rpp(iteli,itelj))
15886             sss_ele_cut=sscale_ele(rij)
15887             sss_ele_grad=sscagrad_ele(rij)
15888             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15889             if (sss_ele_cut.le.0.0) cycle
15890           if (sss.gt.0.0d0) then
15891             rmij=1.0D0/rij
15892             r3ij=rrmij*rmij
15893             r6ij=r3ij*r3ij
15894             ev1=aaa*r6ij*r6ij
15895 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15896             if (j.eq.i+2) ev1=scal_el*ev1
15897             ev2=bbb*r6ij
15898             evdwij=ev1+ev2
15899             if (energy_dec) then
15900               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15901             endif
15902             evdw1=evdw1+evdwij*sss*sss_ele_cut
15903 !
15904 ! Calculate contributions to the Cartesian gradient.
15905 !
15906             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15907 !            ggg(1)=facvdw*xj
15908 !            ggg(2)=facvdw*yj
15909 !            ggg(3)=facvdw*zj
15910           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15911           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15912           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15913           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15914           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15915           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15916
15917             do k=1,3
15918               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15919               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15920             enddo
15921           endif
15922         enddo ! j
15923       enddo   ! i
15924       return
15925       end subroutine evdwpp_short
15926 !-----------------------------------------------------------------------------
15927       subroutine escp_long(evdw2,evdw2_14)
15928 !
15929 ! This subroutine calculates the excluded-volume interaction energy between
15930 ! peptide-group centers and side chains and its gradient in virtual-bond and
15931 ! side-chain vectors.
15932 !
15933 !      implicit real*8 (a-h,o-z)
15934 !      include 'DIMENSIONS'
15935 !      include 'COMMON.GEO'
15936 !      include 'COMMON.VAR'
15937 !      include 'COMMON.LOCAL'
15938 !      include 'COMMON.CHAIN'
15939 !      include 'COMMON.DERIV'
15940 !      include 'COMMON.INTERACT'
15941 !      include 'COMMON.FFIELD'
15942 !      include 'COMMON.IOUNITS'
15943 !      include 'COMMON.CONTROL'
15944       real(kind=8),dimension(3) :: ggg
15945 !el local variables
15946       integer :: i,iint,j,k,iteli,itypj,subchap
15947       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15948       real(kind=8) :: evdw2,evdw2_14,evdwij
15949       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15950                     dist_temp, dist_init
15951
15952       evdw2=0.0D0
15953       evdw2_14=0.0d0
15954 !d    print '(a)','Enter ESCP'
15955 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15956       do i=iatscp_s,iatscp_e
15957         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15958         iteli=itel(i)
15959         xi=0.5D0*(c(1,i)+c(1,i+1))
15960         yi=0.5D0*(c(2,i)+c(2,i+1))
15961         zi=0.5D0*(c(3,i)+c(3,i+1))
15962           xi=mod(xi,boxxsize)
15963           if (xi.lt.0) xi=xi+boxxsize
15964           yi=mod(yi,boxysize)
15965           if (yi.lt.0) yi=yi+boxysize
15966           zi=mod(zi,boxzsize)
15967           if (zi.lt.0) zi=zi+boxzsize
15968
15969         do iint=1,nscp_gr(i)
15970
15971         do j=iscpstart(i,iint),iscpend(i,iint)
15972           itypj=itype(j,1)
15973           if (itypj.eq.ntyp1) cycle
15974 ! Uncomment following three lines for SC-p interactions
15975 !         xj=c(1,nres+j)-xi
15976 !         yj=c(2,nres+j)-yi
15977 !         zj=c(3,nres+j)-zi
15978 ! Uncomment following three lines for Ca-p interactions
15979           xj=c(1,j)
15980           yj=c(2,j)
15981           zj=c(3,j)
15982           xj=mod(xj,boxxsize)
15983           if (xj.lt.0) xj=xj+boxxsize
15984           yj=mod(yj,boxysize)
15985           if (yj.lt.0) yj=yj+boxysize
15986           zj=mod(zj,boxzsize)
15987           if (zj.lt.0) zj=zj+boxzsize
15988       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15989       xj_safe=xj
15990       yj_safe=yj
15991       zj_safe=zj
15992       subchap=0
15993       do xshift=-1,1
15994       do yshift=-1,1
15995       do zshift=-1,1
15996           xj=xj_safe+xshift*boxxsize
15997           yj=yj_safe+yshift*boxysize
15998           zj=zj_safe+zshift*boxzsize
15999           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16000           if(dist_temp.lt.dist_init) then
16001             dist_init=dist_temp
16002             xj_temp=xj
16003             yj_temp=yj
16004             zj_temp=zj
16005             subchap=1
16006           endif
16007        enddo
16008        enddo
16009        enddo
16010        if (subchap.eq.1) then
16011           xj=xj_temp-xi
16012           yj=yj_temp-yi
16013           zj=zj_temp-zi
16014        else
16015           xj=xj_safe-xi
16016           yj=yj_safe-yi
16017           zj=zj_safe-zi
16018        endif
16019           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16020
16021           rij=dsqrt(1.0d0/rrij)
16022             sss_ele_cut=sscale_ele(rij)
16023             sss_ele_grad=sscagrad_ele(rij)
16024 !            print *,sss_ele_cut,sss_ele_grad,&
16025 !            (rij),r_cut_ele,rlamb_ele
16026             if (sss_ele_cut.le.0.0) cycle
16027           sss=sscale((rij/rscp(itypj,iteli)))
16028           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16029           if (sss.lt.1.0d0) then
16030
16031             fac=rrij**expon2
16032             e1=fac*fac*aad(itypj,iteli)
16033             e2=fac*bad(itypj,iteli)
16034             if (iabs(j-i) .le. 2) then
16035               e1=scal14*e1
16036               e2=scal14*e2
16037               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16038             endif
16039             evdwij=e1+e2
16040             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16041             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16042                 'evdw2',i,j,sss,evdwij
16043 !
16044 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16045 !
16046             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16047             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16048             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16049             ggg(1)=xj*fac
16050             ggg(2)=yj*fac
16051             ggg(3)=zj*fac
16052 ! Uncomment following three lines for SC-p interactions
16053 !           do k=1,3
16054 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16055 !           enddo
16056 ! Uncomment following line for SC-p interactions
16057 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16058             do k=1,3
16059               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16060               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16061             enddo
16062           endif
16063         enddo
16064
16065         enddo ! iint
16066       enddo ! i
16067       do i=1,nct
16068         do j=1,3
16069           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16070           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16071           gradx_scp(j,i)=expon*gradx_scp(j,i)
16072         enddo
16073       enddo
16074 !******************************************************************************
16075 !
16076 !                              N O T E !!!
16077 !
16078 ! To save time the factor EXPON has been extracted from ALL components
16079 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16080 ! use!
16081 !
16082 !******************************************************************************
16083       return
16084       end subroutine escp_long
16085 !-----------------------------------------------------------------------------
16086       subroutine escp_short(evdw2,evdw2_14)
16087 !
16088 ! This subroutine calculates the excluded-volume interaction energy between
16089 ! peptide-group centers and side chains and its gradient in virtual-bond and
16090 ! side-chain vectors.
16091 !
16092 !      implicit real*8 (a-h,o-z)
16093 !      include 'DIMENSIONS'
16094 !      include 'COMMON.GEO'
16095 !      include 'COMMON.VAR'
16096 !      include 'COMMON.LOCAL'
16097 !      include 'COMMON.CHAIN'
16098 !      include 'COMMON.DERIV'
16099 !      include 'COMMON.INTERACT'
16100 !      include 'COMMON.FFIELD'
16101 !      include 'COMMON.IOUNITS'
16102 !      include 'COMMON.CONTROL'
16103       real(kind=8),dimension(3) :: ggg
16104 !el local variables
16105       integer :: i,iint,j,k,iteli,itypj,subchap
16106       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16107       real(kind=8) :: evdw2,evdw2_14,evdwij
16108       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16109                     dist_temp, dist_init
16110
16111       evdw2=0.0D0
16112       evdw2_14=0.0d0
16113 !d    print '(a)','Enter ESCP'
16114 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16115       do i=iatscp_s,iatscp_e
16116         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16117         iteli=itel(i)
16118         xi=0.5D0*(c(1,i)+c(1,i+1))
16119         yi=0.5D0*(c(2,i)+c(2,i+1))
16120         zi=0.5D0*(c(3,i)+c(3,i+1))
16121           xi=mod(xi,boxxsize)
16122           if (xi.lt.0) xi=xi+boxxsize
16123           yi=mod(yi,boxysize)
16124           if (yi.lt.0) yi=yi+boxysize
16125           zi=mod(zi,boxzsize)
16126           if (zi.lt.0) zi=zi+boxzsize
16127
16128         do iint=1,nscp_gr(i)
16129
16130         do j=iscpstart(i,iint),iscpend(i,iint)
16131           itypj=itype(j,1)
16132           if (itypj.eq.ntyp1) cycle
16133 ! Uncomment following three lines for SC-p interactions
16134 !         xj=c(1,nres+j)-xi
16135 !         yj=c(2,nres+j)-yi
16136 !         zj=c(3,nres+j)-zi
16137 ! Uncomment following three lines for Ca-p interactions
16138 !          xj=c(1,j)-xi
16139 !          yj=c(2,j)-yi
16140 !          zj=c(3,j)-zi
16141           xj=c(1,j)
16142           yj=c(2,j)
16143           zj=c(3,j)
16144           xj=mod(xj,boxxsize)
16145           if (xj.lt.0) xj=xj+boxxsize
16146           yj=mod(yj,boxysize)
16147           if (yj.lt.0) yj=yj+boxysize
16148           zj=mod(zj,boxzsize)
16149           if (zj.lt.0) zj=zj+boxzsize
16150       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16151       xj_safe=xj
16152       yj_safe=yj
16153       zj_safe=zj
16154       subchap=0
16155       do xshift=-1,1
16156       do yshift=-1,1
16157       do zshift=-1,1
16158           xj=xj_safe+xshift*boxxsize
16159           yj=yj_safe+yshift*boxysize
16160           zj=zj_safe+zshift*boxzsize
16161           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16162           if(dist_temp.lt.dist_init) then
16163             dist_init=dist_temp
16164             xj_temp=xj
16165             yj_temp=yj
16166             zj_temp=zj
16167             subchap=1
16168           endif
16169        enddo
16170        enddo
16171        enddo
16172        if (subchap.eq.1) then
16173           xj=xj_temp-xi
16174           yj=yj_temp-yi
16175           zj=zj_temp-zi
16176        else
16177           xj=xj_safe-xi
16178           yj=yj_safe-yi
16179           zj=zj_safe-zi
16180        endif
16181
16182           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16183           rij=dsqrt(1.0d0/rrij)
16184             sss_ele_cut=sscale_ele(rij)
16185             sss_ele_grad=sscagrad_ele(rij)
16186 !            print *,sss_ele_cut,sss_ele_grad,&
16187 !            (rij),r_cut_ele,rlamb_ele
16188             if (sss_ele_cut.le.0.0) cycle
16189           sss=sscale(rij/rscp(itypj,iteli))
16190           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16191           if (sss.gt.0.0d0) then
16192
16193             fac=rrij**expon2
16194             e1=fac*fac*aad(itypj,iteli)
16195             e2=fac*bad(itypj,iteli)
16196             if (iabs(j-i) .le. 2) then
16197               e1=scal14*e1
16198               e2=scal14*e2
16199               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16200             endif
16201             evdwij=e1+e2
16202             evdw2=evdw2+evdwij*sss*sss_ele_cut
16203             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16204                 'evdw2',i,j,sss,evdwij
16205 !
16206 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16207 !
16208             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16209             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16210             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16211
16212             ggg(1)=xj*fac
16213             ggg(2)=yj*fac
16214             ggg(3)=zj*fac
16215 ! Uncomment following three lines for SC-p interactions
16216 !           do k=1,3
16217 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16218 !           enddo
16219 ! Uncomment following line for SC-p interactions
16220 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16221             do k=1,3
16222               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16223               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16224             enddo
16225           endif
16226         enddo
16227
16228         enddo ! iint
16229       enddo ! i
16230       do i=1,nct
16231         do j=1,3
16232           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16233           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16234           gradx_scp(j,i)=expon*gradx_scp(j,i)
16235         enddo
16236       enddo
16237 !******************************************************************************
16238 !
16239 !                              N O T E !!!
16240 !
16241 ! To save time the factor EXPON has been extracted from ALL components
16242 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16243 ! use!
16244 !
16245 !******************************************************************************
16246       return
16247       end subroutine escp_short
16248 !-----------------------------------------------------------------------------
16249 ! energy_p_new-sep_barrier.F
16250 !-----------------------------------------------------------------------------
16251       subroutine sc_grad_scale(scalfac)
16252 !      implicit real*8 (a-h,o-z)
16253       use calc_data
16254 !      include 'DIMENSIONS'
16255 !      include 'COMMON.CHAIN'
16256 !      include 'COMMON.DERIV'
16257 !      include 'COMMON.CALC'
16258 !      include 'COMMON.IOUNITS'
16259       real(kind=8),dimension(3) :: dcosom1,dcosom2
16260       real(kind=8) :: scalfac
16261 !el local variables
16262 !      integer :: i,j,k,l
16263
16264       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16265       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16266       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16267            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16268 ! diagnostics only
16269 !      eom1=0.0d0
16270 !      eom2=0.0d0
16271 !      eom12=evdwij*eps1_om12
16272 ! end diagnostics
16273 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16274 !     &  " sigder",sigder
16275 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16276 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16277       do k=1,3
16278         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16279         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16280       enddo
16281       do k=1,3
16282         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16283          *sss_ele_cut
16284       enddo
16285 !      write (iout,*) "gg",(gg(k),k=1,3)
16286       do k=1,3
16287         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16288                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16289                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16290                  *sss_ele_cut
16291         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16292                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16293                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16294          *sss_ele_cut
16295 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16296 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16297 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16298 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16299       enddo
16300 !
16301 ! Calculate the components of the gradient in DC and X
16302 !
16303       do l=1,3
16304         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16305         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16306       enddo
16307       return
16308       end subroutine sc_grad_scale
16309 !-----------------------------------------------------------------------------
16310 ! energy_split-sep.F
16311 !-----------------------------------------------------------------------------
16312       subroutine etotal_long(energia)
16313 !
16314 ! Compute the long-range slow-varying contributions to the energy
16315 !
16316 !      implicit real*8 (a-h,o-z)
16317 !      include 'DIMENSIONS'
16318       use MD_data, only: totT,usampl,eq_time
16319 #ifndef ISNAN
16320       external proc_proc
16321 #ifdef WINPGI
16322 !MS$ATTRIBUTES C ::  proc_proc
16323 #endif
16324 #endif
16325 #ifdef MPI
16326       include "mpif.h"
16327       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16328 #endif
16329 !      include 'COMMON.SETUP'
16330 !      include 'COMMON.IOUNITS'
16331 !      include 'COMMON.FFIELD'
16332 !      include 'COMMON.DERIV'
16333 !      include 'COMMON.INTERACT'
16334 !      include 'COMMON.SBRIDGE'
16335 !      include 'COMMON.CHAIN'
16336 !      include 'COMMON.VAR'
16337 !      include 'COMMON.LOCAL'
16338 !      include 'COMMON.MD'
16339       real(kind=8),dimension(0:n_ene) :: energia
16340 !el local variables
16341       integer :: i,n_corr,n_corr1,ierror,ierr
16342       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16343                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16344                   ecorr,ecorr5,ecorr6,eturn6,time00
16345 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16346 !elwrite(iout,*)"in etotal long"
16347
16348       if (modecalc.eq.12.or.modecalc.eq.14) then
16349 #ifdef MPI
16350 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16351 #else
16352         call int_from_cart1(.false.)
16353 #endif
16354       endif
16355 !elwrite(iout,*)"in etotal long"
16356
16357 #ifdef MPI
16358 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16359 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16360       call flush(iout)
16361       if (nfgtasks.gt.1) then
16362         time00=MPI_Wtime()
16363 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16364         if (fg_rank.eq.0) then
16365           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16366 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16367 !          call flush(iout)
16368 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16369 ! FG slaves as WEIGHTS array.
16370           weights_(1)=wsc
16371           weights_(2)=wscp
16372           weights_(3)=welec
16373           weights_(4)=wcorr
16374           weights_(5)=wcorr5
16375           weights_(6)=wcorr6
16376           weights_(7)=wel_loc
16377           weights_(8)=wturn3
16378           weights_(9)=wturn4
16379           weights_(10)=wturn6
16380           weights_(11)=wang
16381           weights_(12)=wscloc
16382           weights_(13)=wtor
16383           weights_(14)=wtor_d
16384           weights_(15)=wstrain
16385           weights_(16)=wvdwpp
16386           weights_(17)=wbond
16387           weights_(18)=scal14
16388           weights_(21)=wsccor
16389 ! FG Master broadcasts the WEIGHTS_ array
16390           call MPI_Bcast(weights_(1),n_ene,&
16391               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16392         else
16393 ! FG slaves receive the WEIGHTS array
16394           call MPI_Bcast(weights(1),n_ene,&
16395               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16396           wsc=weights(1)
16397           wscp=weights(2)
16398           welec=weights(3)
16399           wcorr=weights(4)
16400           wcorr5=weights(5)
16401           wcorr6=weights(6)
16402           wel_loc=weights(7)
16403           wturn3=weights(8)
16404           wturn4=weights(9)
16405           wturn6=weights(10)
16406           wang=weights(11)
16407           wscloc=weights(12)
16408           wtor=weights(13)
16409           wtor_d=weights(14)
16410           wstrain=weights(15)
16411           wvdwpp=weights(16)
16412           wbond=weights(17)
16413           scal14=weights(18)
16414           wsccor=weights(21)
16415         endif
16416         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16417           king,FG_COMM,IERR)
16418          time_Bcast=time_Bcast+MPI_Wtime()-time00
16419          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16420 !        call chainbuild_cart
16421 !        call int_from_cart1(.false.)
16422       endif
16423 !      write (iout,*) 'Processor',myrank,
16424 !     &  ' calling etotal_short ipot=',ipot
16425 !      call flush(iout)
16426 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16427 #endif
16428 !d    print *,'nnt=',nnt,' nct=',nct
16429 !
16430 !elwrite(iout,*)"in etotal long"
16431 ! Compute the side-chain and electrostatic interaction energy
16432 !
16433       goto (101,102,103,104,105,106) ipot
16434 ! Lennard-Jones potential.
16435   101 call elj_long(evdw)
16436 !d    print '(a)','Exit ELJ'
16437       goto 107
16438 ! Lennard-Jones-Kihara potential (shifted).
16439   102 call eljk_long(evdw)
16440       goto 107
16441 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16442   103 call ebp_long(evdw)
16443       goto 107
16444 ! Gay-Berne potential (shifted LJ, angular dependence).
16445   104 call egb_long(evdw)
16446       goto 107
16447 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16448   105 call egbv_long(evdw)
16449       goto 107
16450 ! Soft-sphere potential
16451   106 call e_softsphere(evdw)
16452 !
16453 ! Calculate electrostatic (H-bonding) energy of the main chain.
16454 !
16455   107 continue
16456       call vec_and_deriv
16457       if (ipot.lt.6) then
16458 #ifdef SPLITELE
16459          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16460              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16461              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16462              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16463 #else
16464          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16465              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16466              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16467              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16468 #endif
16469            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16470          else
16471             ees=0
16472             evdw1=0
16473             eel_loc=0
16474             eello_turn3=0
16475             eello_turn4=0
16476          endif
16477       else
16478 !        write (iout,*) "Soft-spheer ELEC potential"
16479         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16480          eello_turn4)
16481       endif
16482 !
16483 ! Calculate excluded-volume interaction energy between peptide groups
16484 ! and side chains.
16485 !
16486       if (ipot.lt.6) then
16487        if(wscp.gt.0d0) then
16488         call escp_long(evdw2,evdw2_14)
16489        else
16490         evdw2=0
16491         evdw2_14=0
16492        endif
16493       else
16494         call escp_soft_sphere(evdw2,evdw2_14)
16495       endif
16496 !
16497 ! 12/1/95 Multi-body terms
16498 !
16499       n_corr=0
16500       n_corr1=0
16501       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16502           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16503          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16504 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16505 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16506       else
16507          ecorr=0.0d0
16508          ecorr5=0.0d0
16509          ecorr6=0.0d0
16510          eturn6=0.0d0
16511       endif
16512       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16513          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16514       endif
16515 !
16516 ! If performing constraint dynamics, call the constraint energy
16517 !  after the equilibration time
16518       if(usampl.and.totT.gt.eq_time) then
16519          call EconstrQ
16520          call Econstr_back
16521       else
16522          Uconst=0.0d0
16523          Uconst_back=0.0d0
16524       endif
16525 !
16526 ! Sum the energies
16527 !
16528       do i=1,n_ene
16529         energia(i)=0.0d0
16530       enddo
16531       energia(1)=evdw
16532 #ifdef SCP14
16533       energia(2)=evdw2-evdw2_14
16534       energia(18)=evdw2_14
16535 #else
16536       energia(2)=evdw2
16537       energia(18)=0.0d0
16538 #endif
16539 #ifdef SPLITELE
16540       energia(3)=ees
16541       energia(16)=evdw1
16542 #else
16543       energia(3)=ees+evdw1
16544       energia(16)=0.0d0
16545 #endif
16546       energia(4)=ecorr
16547       energia(5)=ecorr5
16548       energia(6)=ecorr6
16549       energia(7)=eel_loc
16550       energia(8)=eello_turn3
16551       energia(9)=eello_turn4
16552       energia(10)=eturn6
16553       energia(20)=Uconst+Uconst_back
16554       call sum_energy(energia,.true.)
16555 !      write (iout,*) "Exit ETOTAL_LONG"
16556       call flush(iout)
16557       return
16558       end subroutine etotal_long
16559 !-----------------------------------------------------------------------------
16560       subroutine etotal_short(energia)
16561 !
16562 ! Compute the short-range fast-varying contributions to the energy
16563 !
16564 !      implicit real*8 (a-h,o-z)
16565 !      include 'DIMENSIONS'
16566 #ifndef ISNAN
16567       external proc_proc
16568 #ifdef WINPGI
16569 !MS$ATTRIBUTES C ::  proc_proc
16570 #endif
16571 #endif
16572 #ifdef MPI
16573       include "mpif.h"
16574       integer :: ierror,ierr
16575       real(kind=8),dimension(n_ene) :: weights_
16576       real(kind=8) :: time00
16577 #endif
16578 !      include 'COMMON.SETUP'
16579 !      include 'COMMON.IOUNITS'
16580 !      include 'COMMON.FFIELD'
16581 !      include 'COMMON.DERIV'
16582 !      include 'COMMON.INTERACT'
16583 !      include 'COMMON.SBRIDGE'
16584 !      include 'COMMON.CHAIN'
16585 !      include 'COMMON.VAR'
16586 !      include 'COMMON.LOCAL'
16587       real(kind=8),dimension(0:n_ene) :: energia
16588 !el local variables
16589       integer :: i,nres6
16590       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16591       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16592       nres6=6*nres
16593
16594 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16595 !      call flush(iout)
16596       if (modecalc.eq.12.or.modecalc.eq.14) then
16597 #ifdef MPI
16598         if (fg_rank.eq.0) call int_from_cart1(.false.)
16599 #else
16600         call int_from_cart1(.false.)
16601 #endif
16602       endif
16603 #ifdef MPI
16604 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16605 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16606 !      call flush(iout)
16607       if (nfgtasks.gt.1) then
16608         time00=MPI_Wtime()
16609 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16610         if (fg_rank.eq.0) then
16611           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16612 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16613 !          call flush(iout)
16614 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16615 ! FG slaves as WEIGHTS array.
16616           weights_(1)=wsc
16617           weights_(2)=wscp
16618           weights_(3)=welec
16619           weights_(4)=wcorr
16620           weights_(5)=wcorr5
16621           weights_(6)=wcorr6
16622           weights_(7)=wel_loc
16623           weights_(8)=wturn3
16624           weights_(9)=wturn4
16625           weights_(10)=wturn6
16626           weights_(11)=wang
16627           weights_(12)=wscloc
16628           weights_(13)=wtor
16629           weights_(14)=wtor_d
16630           weights_(15)=wstrain
16631           weights_(16)=wvdwpp
16632           weights_(17)=wbond
16633           weights_(18)=scal14
16634           weights_(21)=wsccor
16635 ! FG Master broadcasts the WEIGHTS_ array
16636           call MPI_Bcast(weights_(1),n_ene,&
16637               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16638         else
16639 ! FG slaves receive the WEIGHTS array
16640           call MPI_Bcast(weights(1),n_ene,&
16641               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16642           wsc=weights(1)
16643           wscp=weights(2)
16644           welec=weights(3)
16645           wcorr=weights(4)
16646           wcorr5=weights(5)
16647           wcorr6=weights(6)
16648           wel_loc=weights(7)
16649           wturn3=weights(8)
16650           wturn4=weights(9)
16651           wturn6=weights(10)
16652           wang=weights(11)
16653           wscloc=weights(12)
16654           wtor=weights(13)
16655           wtor_d=weights(14)
16656           wstrain=weights(15)
16657           wvdwpp=weights(16)
16658           wbond=weights(17)
16659           scal14=weights(18)
16660           wsccor=weights(21)
16661         endif
16662 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16663         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16664           king,FG_COMM,IERR)
16665 !        write (iout,*) "Processor",myrank," BROADCAST c"
16666         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16667           king,FG_COMM,IERR)
16668 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16669         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16670           king,FG_COMM,IERR)
16671 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16672         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16673           king,FG_COMM,IERR)
16674 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16675         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16676           king,FG_COMM,IERR)
16677 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16678         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16679           king,FG_COMM,IERR)
16680 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16681         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16682           king,FG_COMM,IERR)
16683 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16684         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16685           king,FG_COMM,IERR)
16686 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16687         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16688           king,FG_COMM,IERR)
16689          time_Bcast=time_Bcast+MPI_Wtime()-time00
16690 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16691       endif
16692 !      write (iout,*) 'Processor',myrank,
16693 !     &  ' calling etotal_short ipot=',ipot
16694 !      call flush(iout)
16695 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16696 #endif
16697 !      call int_from_cart1(.false.)
16698 !
16699 ! Compute the side-chain and electrostatic interaction energy
16700 !
16701       goto (101,102,103,104,105,106) ipot
16702 ! Lennard-Jones potential.
16703   101 call elj_short(evdw)
16704 !d    print '(a)','Exit ELJ'
16705       goto 107
16706 ! Lennard-Jones-Kihara potential (shifted).
16707   102 call eljk_short(evdw)
16708       goto 107
16709 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16710   103 call ebp_short(evdw)
16711       goto 107
16712 ! Gay-Berne potential (shifted LJ, angular dependence).
16713   104 call egb_short(evdw)
16714       goto 107
16715 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16716   105 call egbv_short(evdw)
16717       goto 107
16718 ! Soft-sphere potential - already dealt with in the long-range part
16719   106 evdw=0.0d0
16720 !  106 call e_softsphere_short(evdw)
16721 !
16722 ! Calculate electrostatic (H-bonding) energy of the main chain.
16723 !
16724   107 continue
16725 !
16726 ! Calculate the short-range part of Evdwpp
16727 !
16728       call evdwpp_short(evdw1)
16729 !
16730 ! Calculate the short-range part of ESCp
16731 !
16732       if (ipot.lt.6) then
16733         call escp_short(evdw2,evdw2_14)
16734       endif
16735 !
16736 ! Calculate the bond-stretching energy
16737 !
16738       call ebond(estr)
16739 !
16740 ! Calculate the disulfide-bridge and other energy and the contributions
16741 ! from other distance constraints.
16742       call edis(ehpb)
16743 !
16744 ! Calculate the virtual-bond-angle energy.
16745 !
16746 ! Calculate the SC local energy.
16747 !
16748       call vec_and_deriv
16749       call esc(escloc)
16750 !
16751       if (wang.gt.0d0) then
16752        if (tor_mode.eq.0) then
16753          call ebend(ebe)
16754        else
16755 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16756 !C energy function
16757          call ebend_kcc(ebe)
16758        endif
16759       else
16760         ebe=0.0d0
16761       endif
16762       ethetacnstr=0.0d0
16763       if (with_theta_constr) call etheta_constr(ethetacnstr)
16764
16765 !       write(iout,*) "in etotal afer ebe",ipot
16766
16767 !      print *,"Processor",myrank," computed UB"
16768 !
16769 ! Calculate the SC local energy.
16770 !
16771       call esc(escloc)
16772 !elwrite(iout,*) "in etotal afer esc",ipot
16773 !      print *,"Processor",myrank," computed USC"
16774 !
16775 ! Calculate the virtual-bond torsional energy.
16776 !
16777 !d    print *,'nterm=',nterm
16778 !      if (wtor.gt.0) then
16779 !       call etor(etors,edihcnstr)
16780 !      else
16781 !       etors=0
16782 !       edihcnstr=0
16783 !      endif
16784       if (wtor.gt.0.0d0) then
16785          if (tor_mode.eq.0) then
16786            call etor(etors)
16787          else
16788 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16789 !C energy function
16790            call etor_kcc(etors)
16791          endif
16792       else
16793         etors=0.0d0
16794       endif
16795       edihcnstr=0.0d0
16796       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16797
16798 ! Calculate the virtual-bond torsional energy.
16799 !
16800 !
16801 ! 6/23/01 Calculate double-torsional energy
16802 !
16803       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16804       call etor_d(etors_d)
16805       endif
16806 !
16807 ! 21/5/07 Calculate local sicdechain correlation energy
16808 !
16809       if (wsccor.gt.0.0d0) then
16810         call eback_sc_corr(esccor)
16811       else
16812         esccor=0.0d0
16813       endif
16814 !
16815 ! Put energy components into an array
16816 !
16817       do i=1,n_ene
16818         energia(i)=0.0d0
16819       enddo
16820       energia(1)=evdw
16821 #ifdef SCP14
16822       energia(2)=evdw2-evdw2_14
16823       energia(18)=evdw2_14
16824 #else
16825       energia(2)=evdw2
16826       energia(18)=0.0d0
16827 #endif
16828 #ifdef SPLITELE
16829       energia(16)=evdw1
16830 #else
16831       energia(3)=evdw1
16832 #endif
16833       energia(11)=ebe
16834       energia(12)=escloc
16835       energia(13)=etors
16836       energia(14)=etors_d
16837       energia(15)=ehpb
16838       energia(17)=estr
16839       energia(19)=edihcnstr
16840       energia(21)=esccor
16841 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16842       call flush(iout)
16843       call sum_energy(energia,.true.)
16844 !      write (iout,*) "Exit ETOTAL_SHORT"
16845       call flush(iout)
16846       return
16847       end subroutine etotal_short
16848 !-----------------------------------------------------------------------------
16849 ! gnmr1.f
16850 !-----------------------------------------------------------------------------
16851       real(kind=8) function gnmr1(y,ymin,ymax)
16852 !      implicit none
16853       real(kind=8) :: y,ymin,ymax
16854       real(kind=8) :: wykl=4.0d0
16855       if (y.lt.ymin) then
16856         gnmr1=(ymin-y)**wykl/wykl
16857       else if (y.gt.ymax) then
16858         gnmr1=(y-ymax)**wykl/wykl
16859       else
16860         gnmr1=0.0d0
16861       endif
16862       return
16863       end function gnmr1
16864 !-----------------------------------------------------------------------------
16865       real(kind=8) function gnmr1prim(y,ymin,ymax)
16866 !      implicit none
16867       real(kind=8) :: y,ymin,ymax
16868       real(kind=8) :: wykl=4.0d0
16869       if (y.lt.ymin) then
16870         gnmr1prim=-(ymin-y)**(wykl-1)
16871       else if (y.gt.ymax) then
16872         gnmr1prim=(y-ymax)**(wykl-1)
16873       else
16874         gnmr1prim=0.0d0
16875       endif
16876       return
16877       end function gnmr1prim
16878 !----------------------------------------------------------------------------
16879       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16880       real(kind=8) y,ymin,ymax,sigma
16881       real(kind=8) wykl /4.0d0/
16882       if (y.lt.ymin) then
16883         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16884       else if (y.gt.ymax) then
16885         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16886       else
16887         rlornmr1=0.0d0
16888       endif
16889       return
16890       end function rlornmr1
16891 !------------------------------------------------------------------------------
16892       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16893       real(kind=8) y,ymin,ymax,sigma
16894       real(kind=8) wykl /4.0d0/
16895       if (y.lt.ymin) then
16896         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16897         ((ymin-y)**wykl+sigma**wykl)**2
16898       else if (y.gt.ymax) then
16899         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16900         ((y-ymax)**wykl+sigma**wykl)**2
16901       else
16902         rlornmr1prim=0.0d0
16903       endif
16904       return
16905       end function rlornmr1prim
16906
16907       real(kind=8) function harmonic(y,ymax)
16908 !      implicit none
16909       real(kind=8) :: y,ymax
16910       real(kind=8) :: wykl=2.0d0
16911       harmonic=(y-ymax)**wykl
16912       return
16913       end function harmonic
16914 !-----------------------------------------------------------------------------
16915       real(kind=8) function harmonicprim(y,ymax)
16916       real(kind=8) :: y,ymin,ymax
16917       real(kind=8) :: wykl=2.0d0
16918       harmonicprim=(y-ymax)*wykl
16919       return
16920       end function harmonicprim
16921 !-----------------------------------------------------------------------------
16922 ! gradient_p.F
16923 !-----------------------------------------------------------------------------
16924       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16925
16926       use io_base, only:intout,briefout
16927 !      implicit real*8 (a-h,o-z)
16928 !      include 'DIMENSIONS'
16929 !      include 'COMMON.CHAIN'
16930 !      include 'COMMON.DERIV'
16931 !      include 'COMMON.VAR'
16932 !      include 'COMMON.INTERACT'
16933 !      include 'COMMON.FFIELD'
16934 !      include 'COMMON.MD'
16935 !      include 'COMMON.IOUNITS'
16936       real(kind=8),external :: ufparm
16937       integer :: uiparm(1)
16938       real(kind=8) :: urparm(1)
16939       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16940       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16941       integer :: n,nf,ind,ind1,i,k,j
16942 !
16943 ! This subroutine calculates total internal coordinate gradient.
16944 ! Depending on the number of function evaluations, either whole energy
16945 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16946 ! internal coordinates are reevaluated or only the cartesian-in-internal
16947 ! coordinate derivatives are evaluated. The subroutine was designed to work
16948 ! with SUMSL.
16949 !
16950 !
16951       icg=mod(nf,2)+1
16952
16953 !d      print *,'grad',nf,icg
16954       if (nf-nfl+1) 20,30,40
16955    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16956 !    write (iout,*) 'grad 20'
16957       if (nf.eq.0) return
16958       goto 40
16959    30 call var_to_geom(n,x)
16960       call chainbuild
16961 !    write (iout,*) 'grad 30'
16962 !
16963 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16964 !
16965    40 call cartder
16966 !     write (iout,*) 'grad 40'
16967 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16968 !
16969 ! Convert the Cartesian gradient into internal-coordinate gradient.
16970 !
16971       ind=0
16972       ind1=0
16973       do i=1,nres-2
16974       gthetai=0.0D0
16975       gphii=0.0D0
16976       do j=i+1,nres-1
16977           ind=ind+1
16978 !         ind=indmat(i,j)
16979 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16980         do k=1,3
16981             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16982           enddo
16983         do k=1,3
16984           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16985           enddo
16986         enddo
16987       do j=i+1,nres-1
16988           ind1=ind1+1
16989 !         ind1=indmat(i,j)
16990 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16991         do k=1,3
16992           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16993           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16994           enddo
16995         enddo
16996       if (i.gt.1) g(i-1)=gphii
16997       if (n.gt.nphi) g(nphi+i)=gthetai
16998       enddo
16999       if (n.le.nphi+ntheta) goto 10
17000       do i=2,nres-1
17001       if (itype(i,1).ne.10) then
17002           galphai=0.0D0
17003         gomegai=0.0D0
17004         do k=1,3
17005           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17006           enddo
17007         do k=1,3
17008           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17009           enddo
17010           g(ialph(i,1))=galphai
17011         g(ialph(i,1)+nside)=gomegai
17012         endif
17013       enddo
17014 !
17015 ! Add the components corresponding to local energy terms.
17016 !
17017    10 continue
17018       do i=1,nvar
17019 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17020         g(i)=g(i)+gloc(i,icg)
17021       enddo
17022 ! Uncomment following three lines for diagnostics.
17023 !d    call intout
17024 !elwrite(iout,*) "in gradient after calling intout"
17025 !d    call briefout(0,0.0d0)
17026 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17027       return
17028       end subroutine gradient
17029 !-----------------------------------------------------------------------------
17030       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17031
17032       use comm_chu
17033 !      implicit real*8 (a-h,o-z)
17034 !      include 'DIMENSIONS'
17035 !      include 'COMMON.DERIV'
17036 !      include 'COMMON.IOUNITS'
17037 !      include 'COMMON.GEO'
17038       integer :: n,nf
17039 !el      integer :: jjj
17040 !el      common /chuju/ jjj
17041       real(kind=8) :: energia(0:n_ene)
17042       integer :: uiparm(1)
17043       real(kind=8) :: urparm(1)
17044       real(kind=8) :: f
17045       real(kind=8),external :: ufparm
17046       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17047 !     if (jjj.gt.0) then
17048 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17049 !     endif
17050       nfl=nf
17051       icg=mod(nf,2)+1
17052 !d      print *,'func',nf,nfl,icg
17053       call var_to_geom(n,x)
17054       call zerograd
17055       call chainbuild
17056 !d    write (iout,*) 'ETOTAL called from FUNC'
17057       call etotal(energia)
17058       call sum_gradient
17059       f=energia(0)
17060 !     if (jjj.gt.0) then
17061 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17062 !       write (iout,*) 'f=',etot
17063 !       jjj=0
17064 !     endif
17065       return
17066       end subroutine func
17067 !-----------------------------------------------------------------------------
17068       subroutine cartgrad
17069 !      implicit real*8 (a-h,o-z)
17070 !      include 'DIMENSIONS'
17071       use energy_data
17072       use MD_data, only: totT,usampl,eq_time
17073 #ifdef MPI
17074       include 'mpif.h'
17075 #endif
17076 !      include 'COMMON.CHAIN'
17077 !      include 'COMMON.DERIV'
17078 !      include 'COMMON.VAR'
17079 !      include 'COMMON.INTERACT'
17080 !      include 'COMMON.FFIELD'
17081 !      include 'COMMON.MD'
17082 !      include 'COMMON.IOUNITS'
17083 !      include 'COMMON.TIME1'
17084 !
17085       integer :: i,j
17086
17087 ! This subrouting calculates total Cartesian coordinate gradient.
17088 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17089 !
17090 !#define DEBUG
17091 #ifdef TIMING
17092       time00=MPI_Wtime()
17093 #endif
17094       icg=1
17095       call sum_gradient
17096 #ifdef TIMING
17097 #endif
17098 !#define DEBUG
17099 !el      write (iout,*) "After sum_gradient"
17100 #ifdef DEBUG
17101 !el      write (iout,*) "After sum_gradient"
17102       do i=1,nres-1
17103         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17104         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17105       enddo
17106 #endif
17107 !#undef DEBUG
17108 ! If performing constraint dynamics, add the gradients of the constraint energy
17109       if(usampl.and.totT.gt.eq_time) then
17110          do i=1,nct
17111            do j=1,3
17112              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17113              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17114            enddo
17115          enddo
17116          do i=1,nres-3
17117            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17118          enddo
17119          do i=1,nres-2
17120            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17121          enddo
17122       endif
17123 !elwrite (iout,*) "After sum_gradient"
17124 #ifdef TIMING
17125       time01=MPI_Wtime()
17126 #endif
17127       call intcartderiv
17128 !elwrite (iout,*) "After sum_gradient"
17129 #ifdef TIMING
17130       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17131 #endif
17132 !     call checkintcartgrad
17133 !     write(iout,*) 'calling int_to_cart'
17134 !#define DEBUG
17135 #ifdef DEBUG
17136       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17137 #endif
17138       do i=0,nct
17139         do j=1,3
17140           gcart(j,i)=gradc(j,i,icg)
17141           gxcart(j,i)=gradx(j,i,icg)
17142 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17143         enddo
17144 #ifdef DEBUG
17145         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17146           (gxcart(j,i),j=1,3),gloc(i,icg)
17147 #endif
17148       enddo
17149 #ifdef TIMING
17150       time01=MPI_Wtime()
17151 #endif
17152 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17153       call int_to_cart
17154 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17155
17156 #ifdef TIMING
17157             time_inttocart=time_inttocart+MPI_Wtime()-time01
17158 #endif
17159 #ifdef DEBUG
17160             write (iout,*) "gcart and gxcart after int_to_cart"
17161             do i=0,nres-1
17162             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17163                 (gxcart(j,i),j=1,3)
17164             enddo
17165 #endif
17166 !#undef DEBUG
17167 #ifdef CARGRAD
17168 #ifdef DEBUG
17169             write (iout,*) "CARGRAD"
17170 #endif
17171             do i=nres,0,-1
17172             do j=1,3
17173               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17174       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17175             enddo
17176       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17177       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17178             enddo
17179       ! Correction: dummy residues
17180             if (nnt.gt.1) then
17181               do j=1,3
17182       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17183                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17184               enddo
17185             endif
17186             if (nct.lt.nres) then
17187               do j=1,3
17188       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17189                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17190               enddo
17191             endif
17192 #endif
17193 #ifdef TIMING
17194             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17195 #endif
17196 !#undef DEBUG
17197             return
17198             end subroutine cartgrad
17199       !-----------------------------------------------------------------------------
17200             subroutine zerograd
17201       !      implicit real*8 (a-h,o-z)
17202       !      include 'DIMENSIONS'
17203       !      include 'COMMON.DERIV'
17204       !      include 'COMMON.CHAIN'
17205       !      include 'COMMON.VAR'
17206       !      include 'COMMON.MD'
17207       !      include 'COMMON.SCCOR'
17208       !
17209       !el local variables
17210             integer :: i,j,intertyp,k
17211       ! Initialize Cartesian-coordinate gradient
17212       !
17213       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17214       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17215
17216       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17217       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17218       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17219       !      allocate(gradcorr_long(3,nres))
17220       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17221       !      allocate(gcorr6_turn_long(3,nres))
17222       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17223
17224       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17225
17226       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17227       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17228
17229       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17230       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17231
17232       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17233       !      allocate(gscloc(3,nres)) !(3,maxres)
17234       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17235
17236
17237
17238       !      common /deriv_scloc/
17239       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17240       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17241       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17242       !      common /mpgrad/
17243       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17244
17245
17246
17247       !          gradc(j,i,icg)=0.0d0
17248       !          gradx(j,i,icg)=0.0d0
17249
17250       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17251       !elwrite(iout,*) "icg",icg
17252             do i=-1,nres
17253             do j=1,3
17254               gvdwx(j,i)=0.0D0
17255               gradx_scp(j,i)=0.0D0
17256               gvdwc(j,i)=0.0D0
17257               gvdwc_scp(j,i)=0.0D0
17258               gvdwc_scpp(j,i)=0.0d0
17259               gelc(j,i)=0.0D0
17260               gelc_long(j,i)=0.0D0
17261               gradb(j,i)=0.0d0
17262               gradbx(j,i)=0.0d0
17263               gvdwpp(j,i)=0.0d0
17264               gel_loc(j,i)=0.0d0
17265               gel_loc_long(j,i)=0.0d0
17266               ghpbc(j,i)=0.0D0
17267               ghpbx(j,i)=0.0D0
17268               gcorr3_turn(j,i)=0.0d0
17269               gcorr4_turn(j,i)=0.0d0
17270               gradcorr(j,i)=0.0d0
17271               gradcorr_long(j,i)=0.0d0
17272               gradcorr5_long(j,i)=0.0d0
17273               gradcorr6_long(j,i)=0.0d0
17274               gcorr6_turn_long(j,i)=0.0d0
17275               gradcorr5(j,i)=0.0d0
17276               gradcorr6(j,i)=0.0d0
17277               gcorr6_turn(j,i)=0.0d0
17278               gsccorc(j,i)=0.0d0
17279               gsccorx(j,i)=0.0d0
17280               gradc(j,i,icg)=0.0d0
17281               gradx(j,i,icg)=0.0d0
17282               gscloc(j,i)=0.0d0
17283               gsclocx(j,i)=0.0d0
17284               gliptran(j,i)=0.0d0
17285               gliptranx(j,i)=0.0d0
17286               gliptranc(j,i)=0.0d0
17287               gshieldx(j,i)=0.0d0
17288               gshieldc(j,i)=0.0d0
17289               gshieldc_loc(j,i)=0.0d0
17290               gshieldx_ec(j,i)=0.0d0
17291               gshieldc_ec(j,i)=0.0d0
17292               gshieldc_loc_ec(j,i)=0.0d0
17293               gshieldx_t3(j,i)=0.0d0
17294               gshieldc_t3(j,i)=0.0d0
17295               gshieldc_loc_t3(j,i)=0.0d0
17296               gshieldx_t4(j,i)=0.0d0
17297               gshieldc_t4(j,i)=0.0d0
17298               gshieldc_loc_t4(j,i)=0.0d0
17299               gshieldx_ll(j,i)=0.0d0
17300               gshieldc_ll(j,i)=0.0d0
17301               gshieldc_loc_ll(j,i)=0.0d0
17302               gg_tube(j,i)=0.0d0
17303               gg_tube_sc(j,i)=0.0d0
17304               gradafm(j,i)=0.0d0
17305               gradb_nucl(j,i)=0.0d0
17306               gradbx_nucl(j,i)=0.0d0
17307               gvdwpp_nucl(j,i)=0.0d0
17308               gvdwpp(j,i)=0.0d0
17309               gelpp(j,i)=0.0d0
17310               gvdwpsb(j,i)=0.0d0
17311               gvdwpsb1(j,i)=0.0d0
17312               gvdwsbc(j,i)=0.0d0
17313               gvdwsbx(j,i)=0.0d0
17314               gelsbc(j,i)=0.0d0
17315               gradcorr_nucl(j,i)=0.0d0
17316               gradcorr3_nucl(j,i)=0.0d0
17317               gradxorr_nucl(j,i)=0.0d0
17318               gradxorr3_nucl(j,i)=0.0d0
17319               gelsbx(j,i)=0.0d0
17320               gsbloc(j,i)=0.0d0
17321               gsblocx(j,i)=0.0d0
17322               gradpepcat(j,i)=0.0d0
17323               gradpepcatx(j,i)=0.0d0
17324               gradcatcat(j,i)=0.0d0
17325               gvdwx_scbase(j,i)=0.0d0
17326               gvdwc_scbase(j,i)=0.0d0
17327               gvdwx_pepbase(j,i)=0.0d0
17328               gvdwc_pepbase(j,i)=0.0d0
17329               gvdwx_scpho(j,i)=0.0d0
17330               gvdwc_scpho(j,i)=0.0d0
17331               gvdwc_peppho(j,i)=0.0d0
17332             enddo
17333              enddo
17334             do i=0,nres
17335             do j=1,3
17336               do intertyp=1,3
17337                gloc_sc(intertyp,i,icg)=0.0d0
17338               enddo
17339             enddo
17340             enddo
17341             do i=1,nres
17342              do j=1,maxcontsshi
17343              shield_list(j,i)=0
17344             do k=1,3
17345       !C           print *,i,j,k
17346                grad_shield_side(k,j,i)=0.0d0
17347                grad_shield_loc(k,j,i)=0.0d0
17348              enddo
17349              enddo
17350              ishield_list(i)=0
17351             enddo
17352
17353       !
17354       ! Initialize the gradient of local energy terms.
17355       !
17356       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17357       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17358       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17359       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17360       !      allocate(gel_loc_turn3(nres))
17361       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17362       !      allocate(gsccor_loc(nres))      !(maxres)
17363
17364             do i=1,4*nres
17365             gloc(i,icg)=0.0D0
17366             enddo
17367             do i=1,nres
17368             gel_loc_loc(i)=0.0d0
17369             gcorr_loc(i)=0.0d0
17370             g_corr5_loc(i)=0.0d0
17371             g_corr6_loc(i)=0.0d0
17372             gel_loc_turn3(i)=0.0d0
17373             gel_loc_turn4(i)=0.0d0
17374             gel_loc_turn6(i)=0.0d0
17375             gsccor_loc(i)=0.0d0
17376             enddo
17377       ! initialize gcart and gxcart
17378       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17379             do i=0,nres
17380             do j=1,3
17381               gcart(j,i)=0.0d0
17382               gxcart(j,i)=0.0d0
17383             enddo
17384             enddo
17385             return
17386             end subroutine zerograd
17387       !-----------------------------------------------------------------------------
17388             real(kind=8) function fdum()
17389             fdum=0.0D0
17390             return
17391             end function fdum
17392       !-----------------------------------------------------------------------------
17393       ! intcartderiv.F
17394       !-----------------------------------------------------------------------------
17395             subroutine intcartderiv
17396       !      implicit real*8 (a-h,o-z)
17397       !      include 'DIMENSIONS'
17398 #ifdef MPI
17399             include 'mpif.h'
17400 #endif
17401       !      include 'COMMON.SETUP'
17402       !      include 'COMMON.CHAIN'
17403       !      include 'COMMON.VAR'
17404       !      include 'COMMON.GEO'
17405       !      include 'COMMON.INTERACT'
17406       !      include 'COMMON.DERIV'
17407       !      include 'COMMON.IOUNITS'
17408       !      include 'COMMON.LOCAL'
17409       !      include 'COMMON.SCCOR'
17410             real(kind=8) :: pi4,pi34
17411             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17412             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17413                       dcosomega,dsinomega !(3,3,maxres)
17414             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17415
17416             integer :: i,j,k
17417             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17418                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17419                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17420                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17421             integer :: nres2
17422             nres2=2*nres
17423
17424       !el from module energy-------------
17425       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17426       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17427       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17428
17429       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17430       !el      allocate(dsintau(3,3,3,0:nres2))
17431       !el      allocate(dtauangle(3,3,3,0:nres2))
17432       !el      allocate(domicron(3,2,2,0:nres2))
17433       !el      allocate(dcosomicron(3,2,2,0:nres2))
17434
17435
17436
17437 #if defined(MPI) && defined(PARINTDER)
17438             if (nfgtasks.gt.1 .and. me.eq.king) &
17439             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17440 #endif
17441             pi4 = 0.5d0*pipol
17442             pi34 = 3*pi4
17443
17444       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17445       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17446
17447       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17448             do i=1,nres
17449             do j=1,3
17450               dtheta(j,1,i)=0.0d0
17451               dtheta(j,2,i)=0.0d0
17452               dphi(j,1,i)=0.0d0
17453               dphi(j,2,i)=0.0d0
17454               dphi(j,3,i)=0.0d0
17455             enddo
17456             enddo
17457       ! Derivatives of theta's
17458 #if defined(MPI) && defined(PARINTDER)
17459       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17460             do i=max0(ithet_start-1,3),ithet_end
17461 #else
17462             do i=3,nres
17463 #endif
17464             cost=dcos(theta(i))
17465             sint=sqrt(1-cost*cost)
17466             do j=1,3
17467               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17468               vbld(i-1)
17469               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17470               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17471               vbld(i)
17472               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17473             enddo
17474             enddo
17475 #if defined(MPI) && defined(PARINTDER)
17476       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17477             do i=max0(ithet_start-1,3),ithet_end
17478 #else
17479             do i=3,nres
17480 #endif
17481             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17482             cost1=dcos(omicron(1,i))
17483             sint1=sqrt(1-cost1*cost1)
17484             cost2=dcos(omicron(2,i))
17485             sint2=sqrt(1-cost2*cost2)
17486              do j=1,3
17487       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17488               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17489               cost1*dc_norm(j,i-2))/ &
17490               vbld(i-1)
17491               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17492               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17493               +cost1*(dc_norm(j,i-1+nres)))/ &
17494               vbld(i-1+nres)
17495               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17496       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17497       !C Looks messy but better than if in loop
17498               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17499               +cost2*dc_norm(j,i-1))/ &
17500               vbld(i)
17501               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17502               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17503                +cost2*(-dc_norm(j,i-1+nres)))/ &
17504               vbld(i-1+nres)
17505       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17506               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17507             enddo
17508              endif
17509             enddo
17510       !elwrite(iout,*) "after vbld write"
17511       ! Derivatives of phi:
17512       ! If phi is 0 or 180 degrees, then the formulas
17513       ! have to be derived by power series expansion of the
17514       ! conventional formulas around 0 and 180.
17515 #ifdef PARINTDER
17516             do i=iphi1_start,iphi1_end
17517 #else
17518             do i=4,nres
17519 #endif
17520       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17521       ! the conventional case
17522             sint=dsin(theta(i))
17523             sint1=dsin(theta(i-1))
17524             sing=dsin(phi(i))
17525             cost=dcos(theta(i))
17526             cost1=dcos(theta(i-1))
17527             cosg=dcos(phi(i))
17528             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17529             fac0=1.0d0/(sint1*sint)
17530             fac1=cost*fac0
17531             fac2=cost1*fac0
17532             fac3=cosg*cost1/(sint1*sint1)
17533             fac4=cosg*cost/(sint*sint)
17534       !    Obtaining the gamma derivatives from sine derivative
17535              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17536                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17537                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17538              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17539              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17540              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17541              do j=1,3
17542                 ctgt=cost/sint
17543                 ctgt1=cost1/sint1
17544                 cosg_inv=1.0d0/cosg
17545                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17546                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17547                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17548                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17549                 dsinphi(j,2,i)= &
17550                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17551                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17552                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17553                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17554                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17555       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17556                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17557                 endif
17558       ! Bug fixed 3/24/05 (AL)
17559              enddo
17560       !   Obtaining the gamma derivatives from cosine derivative
17561             else
17562                do j=1,3
17563                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17564                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17565                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17566                dc_norm(j,i-3))/vbld(i-2)
17567                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17568                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17569                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17570                dcostheta(j,1,i)
17571                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17572                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17573                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17574                dc_norm(j,i-1))/vbld(i)
17575                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17576 !#define DEBUG
17577 #ifdef DEBUG
17578                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17579 #endif
17580 !#undef DEBUG
17581                endif
17582              enddo
17583             endif
17584             enddo
17585       !alculate derivative of Tauangle
17586 #ifdef PARINTDER
17587             do i=itau_start,itau_end
17588 #else
17589             do i=3,nres
17590       !elwrite(iout,*) " vecpr",i,nres
17591 #endif
17592              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17593       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17594       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17595       !c dtauangle(j,intertyp,dervityp,residue number)
17596       !c INTERTYP=1 SC...Ca...Ca..Ca
17597       ! the conventional case
17598             sint=dsin(theta(i))
17599             sint1=dsin(omicron(2,i-1))
17600             sing=dsin(tauangle(1,i))
17601             cost=dcos(theta(i))
17602             cost1=dcos(omicron(2,i-1))
17603             cosg=dcos(tauangle(1,i))
17604       !elwrite(iout,*) " vecpr5",i,nres
17605             do j=1,3
17606       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17607       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17608             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17609       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17610             enddo
17611             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17612             fac0=1.0d0/(sint1*sint)
17613             fac1=cost*fac0
17614             fac2=cost1*fac0
17615             fac3=cosg*cost1/(sint1*sint1)
17616             fac4=cosg*cost/(sint*sint)
17617       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17618       !    Obtaining the gamma derivatives from sine derivative
17619              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17620                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17621                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17622              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17623              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17624              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17625             do j=1,3
17626                 ctgt=cost/sint
17627                 ctgt1=cost1/sint1
17628                 cosg_inv=1.0d0/cosg
17629                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17630              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17631              *vbld_inv(i-2+nres)
17632                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17633                 dsintau(j,1,2,i)= &
17634                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17635                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17636       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17637                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17638       ! Bug fixed 3/24/05 (AL)
17639                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17640                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17641       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17642                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17643              enddo
17644       !   Obtaining the gamma derivatives from cosine derivative
17645             else
17646                do j=1,3
17647                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17648                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17649                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17650                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17651                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17652                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17653                dcostheta(j,1,i)
17654                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17655                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17656                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17657                dc_norm(j,i-1))/vbld(i)
17658                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17659       !         write (iout,*) "else",i
17660              enddo
17661             endif
17662       !        do k=1,3
17663       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17664       !        enddo
17665             enddo
17666       !C Second case Ca...Ca...Ca...SC
17667 #ifdef PARINTDER
17668             do i=itau_start,itau_end
17669 #else
17670             do i=4,nres
17671 #endif
17672              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17673               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17674       ! the conventional case
17675             sint=dsin(omicron(1,i))
17676             sint1=dsin(theta(i-1))
17677             sing=dsin(tauangle(2,i))
17678             cost=dcos(omicron(1,i))
17679             cost1=dcos(theta(i-1))
17680             cosg=dcos(tauangle(2,i))
17681       !        do j=1,3
17682       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17683       !        enddo
17684             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17685             fac0=1.0d0/(sint1*sint)
17686             fac1=cost*fac0
17687             fac2=cost1*fac0
17688             fac3=cosg*cost1/(sint1*sint1)
17689             fac4=cosg*cost/(sint*sint)
17690       !    Obtaining the gamma derivatives from sine derivative
17691              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17692                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17693                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17694              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17695              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17696              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17697             do j=1,3
17698                 ctgt=cost/sint
17699                 ctgt1=cost1/sint1
17700                 cosg_inv=1.0d0/cosg
17701                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17702                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17703       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17704       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17705                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17706                 dsintau(j,2,2,i)= &
17707                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17708                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17709       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17710       !     & sing*ctgt*domicron(j,1,2,i),
17711       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17712                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17713       ! Bug fixed 3/24/05 (AL)
17714                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17715                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17716       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17717                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17718              enddo
17719       !   Obtaining the gamma derivatives from cosine derivative
17720             else
17721                do j=1,3
17722                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17723                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17724                dc_norm(j,i-3))/vbld(i-2)
17725                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17726                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17727                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17728                dcosomicron(j,1,1,i)
17729                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17730                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17731                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17732                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17733                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17734       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17735              enddo
17736             endif
17737             enddo
17738
17739       !CC third case SC...Ca...Ca...SC
17740 #ifdef PARINTDER
17741
17742             do i=itau_start,itau_end
17743 #else
17744             do i=3,nres
17745 #endif
17746       ! the conventional case
17747             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17748             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17749             sint=dsin(omicron(1,i))
17750             sint1=dsin(omicron(2,i-1))
17751             sing=dsin(tauangle(3,i))
17752             cost=dcos(omicron(1,i))
17753             cost1=dcos(omicron(2,i-1))
17754             cosg=dcos(tauangle(3,i))
17755             do j=1,3
17756             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17757       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17758             enddo
17759             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17760             fac0=1.0d0/(sint1*sint)
17761             fac1=cost*fac0
17762             fac2=cost1*fac0
17763             fac3=cosg*cost1/(sint1*sint1)
17764             fac4=cosg*cost/(sint*sint)
17765       !    Obtaining the gamma derivatives from sine derivative
17766              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17767                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17768                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17769              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17770              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17771              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17772             do j=1,3
17773                 ctgt=cost/sint
17774                 ctgt1=cost1/sint1
17775                 cosg_inv=1.0d0/cosg
17776                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17777                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17778                   *vbld_inv(i-2+nres)
17779                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17780                 dsintau(j,3,2,i)= &
17781                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17782                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17783                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17784       ! Bug fixed 3/24/05 (AL)
17785                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17786                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17787                   *vbld_inv(i-1+nres)
17788       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17789                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17790              enddo
17791       !   Obtaining the gamma derivatives from cosine derivative
17792             else
17793                do j=1,3
17794                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17795                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17796                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17797                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17798                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17799                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17800                dcosomicron(j,1,1,i)
17801                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17802                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17803                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17804                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17805                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17806       !          write(iout,*) "else",i
17807              enddo
17808             endif
17809             enddo
17810
17811 #ifdef CRYST_SC
17812       !   Derivatives of side-chain angles alpha and omega
17813 #if defined(MPI) && defined(PARINTDER)
17814             do i=ibond_start,ibond_end
17815 #else
17816             do i=2,nres-1
17817 #endif
17818               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17819                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17820                  fac6=fac5/vbld(i)
17821                  fac7=fac5*fac5
17822                  fac8=fac5/vbld(i+1)
17823                  fac9=fac5/vbld(i+nres)
17824                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17825                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17826                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17827                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17828                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17829                  sina=sqrt(1-cosa*cosa)
17830                  sino=dsin(omeg(i))
17831       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17832                  do j=1,3
17833                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17834                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17835                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17836                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17837                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17838                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17839                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17840                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17841                   vbld(i+nres))
17842                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17843                 enddo
17844       ! obtaining the derivatives of omega from sines
17845                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17846                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17847                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17848                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17849                    dsin(theta(i+1)))
17850                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17851                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17852                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17853                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17854                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17855                    coso_inv=1.0d0/dcos(omeg(i))
17856                    do j=1,3
17857                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17858                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17859                    (sino*dc_norm(j,i-1))/vbld(i)
17860                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17861                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17862                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17863                    -sino*dc_norm(j,i)/vbld(i+1)
17864                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17865                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17866                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17867                    vbld(i+nres)
17868                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17869                   enddo
17870                else
17871       !   obtaining the derivatives of omega from cosines
17872                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17873                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17874                  fac12=fac10*sina
17875                  fac13=fac12*fac12
17876                  fac14=sina*sina
17877                  do j=1,3
17878                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17879                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17880                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17881                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17882                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17883                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17884                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17885                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17886                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17887                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17888                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17889                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17890                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17891                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17892                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17893                 enddo
17894               endif
17895              else
17896                do j=1,3
17897                  do k=1,3
17898                    dalpha(k,j,i)=0.0d0
17899                    domega(k,j,i)=0.0d0
17900                  enddo
17901                enddo
17902              endif
17903              enddo
17904 #endif
17905 #if defined(MPI) && defined(PARINTDER)
17906             if (nfgtasks.gt.1) then
17907 #ifdef DEBUG
17908       !d      write (iout,*) "Gather dtheta"
17909       !d      call flush(iout)
17910             write (iout,*) "dtheta before gather"
17911             do i=1,nres
17912             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17913             enddo
17914 #endif
17915             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17916             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17917             king,FG_COMM,IERROR)
17918 !#define DEBUG
17919 #ifdef DEBUG
17920       !d      write (iout,*) "Gather dphi"
17921       !d      call flush(iout)
17922             write (iout,*) "dphi before gather"
17923             do i=1,nres
17924             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17925             enddo
17926 #endif
17927 !#undef DEBUG
17928             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17929             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17930             king,FG_COMM,IERROR)
17931       !d      write (iout,*) "Gather dalpha"
17932       !d      call flush(iout)
17933 #ifdef CRYST_SC
17934             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17935             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17936             king,FG_COMM,IERROR)
17937       !d      write (iout,*) "Gather domega"
17938       !d      call flush(iout)
17939             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17940             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17941             king,FG_COMM,IERROR)
17942 #endif
17943             endif
17944 #endif
17945 !#define DEBUG
17946 #ifdef DEBUG
17947             write (iout,*) "dtheta after gather"
17948             do i=1,nres
17949             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17950             enddo
17951             write (iout,*) "dphi after gather"
17952             do i=1,nres
17953             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17954             enddo
17955             write (iout,*) "dalpha after gather"
17956             do i=1,nres
17957             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17958             enddo
17959             write (iout,*) "domega after gather"
17960             do i=1,nres
17961             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17962             enddo
17963 #endif
17964 !#undef DEBUG
17965             return
17966             end subroutine intcartderiv
17967       !-----------------------------------------------------------------------------
17968             subroutine checkintcartgrad
17969       !      implicit real*8 (a-h,o-z)
17970       !      include 'DIMENSIONS'
17971 #ifdef MPI
17972             include 'mpif.h'
17973 #endif
17974       !      include 'COMMON.CHAIN'
17975       !      include 'COMMON.VAR'
17976       !      include 'COMMON.GEO'
17977       !      include 'COMMON.INTERACT'
17978       !      include 'COMMON.DERIV'
17979       !      include 'COMMON.IOUNITS'
17980       !      include 'COMMON.SETUP'
17981             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17982             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17983             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17984             real(kind=8),dimension(3) :: dc_norm_s
17985             real(kind=8) :: aincr=1.0d-5
17986             integer :: i,j
17987             real(kind=8) :: dcji
17988             do i=1,nres
17989             phi_s(i)=phi(i)
17990             theta_s(i)=theta(i)
17991             alph_s(i)=alph(i)
17992             omeg_s(i)=omeg(i)
17993             enddo
17994       ! Check theta gradient
17995             write (iout,*) &
17996              "Analytical (upper) and numerical (lower) gradient of theta"
17997             write (iout,*)
17998             do i=3,nres
17999             do j=1,3
18000               dcji=dc(j,i-2)
18001               dc(j,i-2)=dcji+aincr
18002               call chainbuild_cart
18003               call int_from_cart1(.false.)
18004           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18005           dc(j,i-2)=dcji
18006           dcji=dc(j,i-1)
18007           dc(j,i-1)=dc(j,i-1)+aincr
18008           call chainbuild_cart
18009           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18010           dc(j,i-1)=dcji
18011         enddo
18012 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18013 !el          (dtheta(j,2,i),j=1,3)
18014 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18015 !el          (dthetanum(j,2,i),j=1,3)
18016 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18017 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18018 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18019 !el        write (iout,*)
18020       enddo
18021 ! Check gamma gradient
18022       write (iout,*) &
18023        "Analytical (upper) and numerical (lower) gradient of gamma"
18024       do i=4,nres
18025         do j=1,3
18026           dcji=dc(j,i-3)
18027           dc(j,i-3)=dcji+aincr
18028           call chainbuild_cart
18029           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18030               dc(j,i-3)=dcji
18031           dcji=dc(j,i-2)
18032           dc(j,i-2)=dcji+aincr
18033           call chainbuild_cart
18034           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18035           dc(j,i-2)=dcji
18036           dcji=dc(j,i-1)
18037           dc(j,i-1)=dc(j,i-1)+aincr
18038           call chainbuild_cart
18039           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18040           dc(j,i-1)=dcji
18041         enddo
18042 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18043 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18044 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18045 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18046 !el        write (iout,'(5x,3(3f10.5,5x))') &
18047 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18048 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18049 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18050 !el        write (iout,*)
18051       enddo
18052 ! Check alpha gradient
18053       write (iout,*) &
18054        "Analytical (upper) and numerical (lower) gradient of alpha"
18055       do i=2,nres-1
18056        if(itype(i,1).ne.10) then
18057                  do j=1,3
18058                   dcji=dc(j,i-1)
18059                    dc(j,i-1)=dcji+aincr
18060               call chainbuild_cart
18061               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18062                  /aincr
18063                   dc(j,i-1)=dcji
18064               dcji=dc(j,i)
18065               dc(j,i)=dcji+aincr
18066               call chainbuild_cart
18067               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18068                  /aincr
18069               dc(j,i)=dcji
18070               dcji=dc(j,i+nres)
18071               dc(j,i+nres)=dc(j,i+nres)+aincr
18072               call chainbuild_cart
18073               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18074                  /aincr
18075              dc(j,i+nres)=dcji
18076             enddo
18077           endif
18078 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18079 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18080 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18081 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18082 !el        write (iout,'(5x,3(3f10.5,5x))') &
18083 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18084 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18085 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18086 !el        write (iout,*)
18087       enddo
18088 !     Check omega gradient
18089       write (iout,*) &
18090        "Analytical (upper) and numerical (lower) gradient of omega"
18091       do i=2,nres-1
18092        if(itype(i,1).ne.10) then
18093                  do j=1,3
18094                   dcji=dc(j,i-1)
18095                    dc(j,i-1)=dcji+aincr
18096               call chainbuild_cart
18097               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18098                  /aincr
18099                   dc(j,i-1)=dcji
18100               dcji=dc(j,i)
18101               dc(j,i)=dcji+aincr
18102               call chainbuild_cart
18103               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18104                  /aincr
18105               dc(j,i)=dcji
18106               dcji=dc(j,i+nres)
18107               dc(j,i+nres)=dc(j,i+nres)+aincr
18108               call chainbuild_cart
18109               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18110                  /aincr
18111              dc(j,i+nres)=dcji
18112             enddo
18113           endif
18114 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18115 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18116 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18117 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18118 !el        write (iout,'(5x,3(3f10.5,5x))') &
18119 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18120 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18121 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18122 !el        write (iout,*)
18123       enddo
18124       return
18125       end subroutine checkintcartgrad
18126 !-----------------------------------------------------------------------------
18127 ! q_measure.F
18128 !-----------------------------------------------------------------------------
18129       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18130 !      implicit real*8 (a-h,o-z)
18131 !      include 'DIMENSIONS'
18132 !      include 'COMMON.IOUNITS'
18133 !      include 'COMMON.CHAIN'
18134 !      include 'COMMON.INTERACT'
18135 !      include 'COMMON.VAR'
18136       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18137       integer :: kkk,nsep=3
18138       real(kind=8) :: qm      !dist,
18139       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18140       logical :: lprn=.false.
18141       logical :: flag
18142 !      real(kind=8) :: sigm,x
18143
18144 !el      sigm(x)=0.25d0*x     ! local function
18145       qqmax=1.0d10
18146       do kkk=1,nperm
18147       qq = 0.0d0
18148       nl=0
18149        if(flag) then
18150         do il=seg1+nsep,seg2
18151           do jl=seg1,il-nsep
18152             nl=nl+1
18153             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18154                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18155                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18156             dij=dist(il,jl)
18157             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18158             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18159               nl=nl+1
18160               d0ijCM=dsqrt( &
18161                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18162                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18163                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18164               dijCM=dist(il+nres,jl+nres)
18165               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18166             endif
18167             qq = qq+qqij+qqijCM
18168           enddo
18169         enddo
18170         qq = qq/nl
18171       else
18172       do il=seg1,seg2
18173         if((seg3-il).lt.3) then
18174              secseg=il+3
18175         else
18176              secseg=seg3
18177         endif
18178           do jl=secseg,seg4
18179             nl=nl+1
18180             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18181                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18182                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18183             dij=dist(il,jl)
18184             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18185             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18186               nl=nl+1
18187               d0ijCM=dsqrt( &
18188                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18189                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18190                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18191               dijCM=dist(il+nres,jl+nres)
18192               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18193             endif
18194             qq = qq+qqij+qqijCM
18195           enddo
18196         enddo
18197       qq = qq/nl
18198       endif
18199       if (qqmax.le.qq) qqmax=qq
18200       enddo
18201       qwolynes=1.0d0-qqmax
18202       return
18203       end function qwolynes
18204 !-----------------------------------------------------------------------------
18205       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18206 !      implicit real*8 (a-h,o-z)
18207 !      include 'DIMENSIONS'
18208 !      include 'COMMON.IOUNITS'
18209 !      include 'COMMON.CHAIN'
18210 !      include 'COMMON.INTERACT'
18211 !      include 'COMMON.VAR'
18212 !      include 'COMMON.MD'
18213       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18214       integer :: nsep=3, kkk
18215 !el      real(kind=8) :: dist
18216       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18217       logical :: lprn=.false.
18218       logical :: flag
18219       real(kind=8) :: sim,dd0,fac,ddqij
18220 !el      sigm(x)=0.25d0*x           ! local function
18221       do kkk=1,nperm
18222       do i=0,nres
18223         do j=1,3
18224           dqwol(j,i)=0.0d0
18225           dxqwol(j,i)=0.0d0
18226         enddo
18227       enddo
18228       nl=0
18229        if(flag) then
18230         do il=seg1+nsep,seg2
18231           do jl=seg1,il-nsep
18232             nl=nl+1
18233             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18234                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18235                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18236             dij=dist(il,jl)
18237             sim = 1.0d0/sigm(d0ij)
18238             sim = sim*sim
18239             dd0 = dij-d0ij
18240             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18241           do k=1,3
18242               ddqij = (c(k,il)-c(k,jl))*fac
18243               dqwol(k,il)=dqwol(k,il)+ddqij
18244               dqwol(k,jl)=dqwol(k,jl)-ddqij
18245             enddo
18246
18247             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18248               nl=nl+1
18249               d0ijCM=dsqrt( &
18250                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18251                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18252                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18253               dijCM=dist(il+nres,jl+nres)
18254               sim = 1.0d0/sigm(d0ijCM)
18255               sim = sim*sim
18256               dd0=dijCM-d0ijCM
18257               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18258               do k=1,3
18259                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18260                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18261                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18262               enddo
18263             endif
18264           enddo
18265         enddo
18266        else
18267         do il=seg1,seg2
18268         if((seg3-il).lt.3) then
18269              secseg=il+3
18270         else
18271              secseg=seg3
18272         endif
18273           do jl=secseg,seg4
18274             nl=nl+1
18275             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18276                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18277                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18278             dij=dist(il,jl)
18279             sim = 1.0d0/sigm(d0ij)
18280             sim = sim*sim
18281             dd0 = dij-d0ij
18282             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18283             do k=1,3
18284               ddqij = (c(k,il)-c(k,jl))*fac
18285               dqwol(k,il)=dqwol(k,il)+ddqij
18286               dqwol(k,jl)=dqwol(k,jl)-ddqij
18287             enddo
18288             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18289               nl=nl+1
18290               d0ijCM=dsqrt( &
18291                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18292                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18293                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18294               dijCM=dist(il+nres,jl+nres)
18295               sim = 1.0d0/sigm(d0ijCM)
18296               sim=sim*sim
18297               dd0 = dijCM-d0ijCM
18298               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18299               do k=1,3
18300                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18301                dxqwol(k,il)=dxqwol(k,il)+ddqij
18302                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18303               enddo
18304             endif
18305           enddo
18306         enddo
18307       endif
18308       enddo
18309        do i=0,nres
18310          do j=1,3
18311            dqwol(j,i)=dqwol(j,i)/nl
18312            dxqwol(j,i)=dxqwol(j,i)/nl
18313          enddo
18314        enddo
18315       return
18316       end subroutine qwolynes_prim
18317 !-----------------------------------------------------------------------------
18318       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18319 !      implicit real*8 (a-h,o-z)
18320 !      include 'DIMENSIONS'
18321 !      include 'COMMON.IOUNITS'
18322 !      include 'COMMON.CHAIN'
18323 !      include 'COMMON.INTERACT'
18324 !      include 'COMMON.VAR'
18325       integer :: seg1,seg2,seg3,seg4
18326       logical :: flag
18327       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18328       real(kind=8),dimension(3,0:2*nres) :: cdummy
18329       real(kind=8) :: q1,q2
18330       real(kind=8) :: delta=1.0d-10
18331       integer :: i,j
18332
18333       do i=0,nres
18334         do j=1,3
18335           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18336           cdummy(j,i)=c(j,i)
18337           c(j,i)=c(j,i)+delta
18338           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18339           qwolan(j,i)=(q2-q1)/delta
18340           c(j,i)=cdummy(j,i)
18341         enddo
18342       enddo
18343       do i=0,nres
18344         do j=1,3
18345           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18346           cdummy(j,i+nres)=c(j,i+nres)
18347           c(j,i+nres)=c(j,i+nres)+delta
18348           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18349           qwolxan(j,i)=(q2-q1)/delta
18350           c(j,i+nres)=cdummy(j,i+nres)
18351         enddo
18352       enddo
18353 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18354 !      do i=0,nct
18355 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18356 !      enddo
18357 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18358 !      do i=0,nct
18359 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18360 !      enddo
18361       return
18362       end subroutine qwol_num
18363 !-----------------------------------------------------------------------------
18364       subroutine EconstrQ
18365 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18366 !      implicit real*8 (a-h,o-z)
18367 !      include 'DIMENSIONS'
18368 !      include 'COMMON.CONTROL'
18369 !      include 'COMMON.VAR'
18370 !      include 'COMMON.MD'
18371       use MD_data
18372 !#ifndef LANG0
18373 !      include 'COMMON.LANGEVIN'
18374 !#else
18375 !      include 'COMMON.LANGEVIN.lang0'
18376 !#endif
18377 !      include 'COMMON.CHAIN'
18378 !      include 'COMMON.DERIV'
18379 !      include 'COMMON.GEO'
18380 !      include 'COMMON.LOCAL'
18381 !      include 'COMMON.INTERACT'
18382 !      include 'COMMON.IOUNITS'
18383 !      include 'COMMON.NAMES'
18384 !      include 'COMMON.TIME1'
18385       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18386       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18387                    duconst,duxconst
18388       integer :: kstart,kend,lstart,lend,idummy
18389       real(kind=8) :: delta=1.0d-7
18390       integer :: i,j,k,ii
18391       do i=0,nres
18392          do j=1,3
18393             duconst(j,i)=0.0d0
18394             dudconst(j,i)=0.0d0
18395             duxconst(j,i)=0.0d0
18396             dudxconst(j,i)=0.0d0
18397          enddo
18398       enddo
18399       Uconst=0.0d0
18400       do i=1,nfrag
18401          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18402            idummy,idummy)
18403          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18404 ! Calculating the derivatives of Constraint energy with respect to Q
18405          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18406            qinfrag(i,iset))
18407 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18408 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18409 !         hmnum=(hm2-hm1)/delta
18410 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18411 !     &   qinfrag(i,iset))
18412 !         write(iout,*) "harmonicnum frag", hmnum
18413 ! Calculating the derivatives of Q with respect to cartesian coordinates
18414          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18415           idummy,idummy)
18416 !         write(iout,*) "dqwol "
18417 !         do ii=1,nres
18418 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18419 !         enddo
18420 !         write(iout,*) "dxqwol "
18421 !         do ii=1,nres
18422 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18423 !         enddo
18424 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18425 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18426 !     &  ,idummy,idummy)
18427 !  The gradients of Uconst in Cs
18428          do ii=0,nres
18429             do j=1,3
18430                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18431                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18432             enddo
18433          enddo
18434       enddo
18435       do i=1,npair
18436          kstart=ifrag(1,ipair(1,i,iset),iset)
18437          kend=ifrag(2,ipair(1,i,iset),iset)
18438          lstart=ifrag(1,ipair(2,i,iset),iset)
18439          lend=ifrag(2,ipair(2,i,iset),iset)
18440          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18441          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18442 !  Calculating dU/dQ
18443          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18444 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18445 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18446 !         hmnum=(hm2-hm1)/delta
18447 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18448 !     &   qinpair(i,iset))
18449 !         write(iout,*) "harmonicnum pair ", hmnum
18450 ! Calculating dQ/dXi
18451          call qwolynes_prim(kstart,kend,.false.,&
18452           lstart,lend)
18453 !         write(iout,*) "dqwol "
18454 !         do ii=1,nres
18455 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18456 !         enddo
18457 !         write(iout,*) "dxqwol "
18458 !         do ii=1,nres
18459 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18460 !        enddo
18461 ! Calculating numerical gradients
18462 !        call qwol_num(kstart,kend,.false.
18463 !     &  ,lstart,lend)
18464 ! The gradients of Uconst in Cs
18465          do ii=0,nres
18466             do j=1,3
18467                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18468                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18469             enddo
18470          enddo
18471       enddo
18472 !      write(iout,*) "Uconst inside subroutine ", Uconst
18473 ! Transforming the gradients from Cs to dCs for the backbone
18474       do i=0,nres
18475          do j=i+1,nres
18476            do k=1,3
18477              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18478            enddo
18479          enddo
18480       enddo
18481 !  Transforming the gradients from Cs to dCs for the side chains
18482       do i=1,nres
18483          do j=1,3
18484            dudxconst(j,i)=duxconst(j,i)
18485          enddo
18486       enddo
18487 !      write(iout,*) "dU/ddc backbone "
18488 !       do ii=0,nres
18489 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18490 !      enddo
18491 !      write(iout,*) "dU/ddX side chain "
18492 !      do ii=1,nres
18493 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18494 !      enddo
18495 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18496 !      call dEconstrQ_num
18497       return
18498       end subroutine EconstrQ
18499 !-----------------------------------------------------------------------------
18500       subroutine dEconstrQ_num
18501 ! Calculating numerical dUconst/ddc and dUconst/ddx
18502 !      implicit real*8 (a-h,o-z)
18503 !      include 'DIMENSIONS'
18504 !      include 'COMMON.CONTROL'
18505 !      include 'COMMON.VAR'
18506 !      include 'COMMON.MD'
18507       use MD_data
18508 !#ifndef LANG0
18509 !      include 'COMMON.LANGEVIN'
18510 !#else
18511 !      include 'COMMON.LANGEVIN.lang0'
18512 !#endif
18513 !      include 'COMMON.CHAIN'
18514 !      include 'COMMON.DERIV'
18515 !      include 'COMMON.GEO'
18516 !      include 'COMMON.LOCAL'
18517 !      include 'COMMON.INTERACT'
18518 !      include 'COMMON.IOUNITS'
18519 !      include 'COMMON.NAMES'
18520 !      include 'COMMON.TIME1'
18521       real(kind=8) :: uzap1,uzap2
18522       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18523       integer :: kstart,kend,lstart,lend,idummy
18524       real(kind=8) :: delta=1.0d-7
18525 !el local variables
18526       integer :: i,ii,j
18527 !     real(kind=8) ::
18528 !     For the backbone
18529       do i=0,nres-1
18530          do j=1,3
18531             dUcartan(j,i)=0.0d0
18532             cdummy(j,i)=dc(j,i)
18533             dc(j,i)=dc(j,i)+delta
18534             call chainbuild_cart
18535           uzap2=0.0d0
18536             do ii=1,nfrag
18537              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18538                 idummy,idummy)
18539                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18540                 qinfrag(ii,iset))
18541             enddo
18542             do ii=1,npair
18543                kstart=ifrag(1,ipair(1,ii,iset),iset)
18544                kend=ifrag(2,ipair(1,ii,iset),iset)
18545                lstart=ifrag(1,ipair(2,ii,iset),iset)
18546                lend=ifrag(2,ipair(2,ii,iset),iset)
18547                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18548                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18549                  qinpair(ii,iset))
18550             enddo
18551             dc(j,i)=cdummy(j,i)
18552             call chainbuild_cart
18553             uzap1=0.0d0
18554              do ii=1,nfrag
18555              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18556                 idummy,idummy)
18557                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18558                 qinfrag(ii,iset))
18559             enddo
18560             do ii=1,npair
18561                kstart=ifrag(1,ipair(1,ii,iset),iset)
18562                kend=ifrag(2,ipair(1,ii,iset),iset)
18563                lstart=ifrag(1,ipair(2,ii,iset),iset)
18564                lend=ifrag(2,ipair(2,ii,iset),iset)
18565                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18566                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18567                 qinpair(ii,iset))
18568             enddo
18569             ducartan(j,i)=(uzap2-uzap1)/(delta)
18570          enddo
18571       enddo
18572 ! Calculating numerical gradients for dU/ddx
18573       do i=0,nres-1
18574          duxcartan(j,i)=0.0d0
18575          do j=1,3
18576             cdummy(j,i)=dc(j,i+nres)
18577             dc(j,i+nres)=dc(j,i+nres)+delta
18578             call chainbuild_cart
18579           uzap2=0.0d0
18580             do ii=1,nfrag
18581              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18582                 idummy,idummy)
18583                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18584                 qinfrag(ii,iset))
18585             enddo
18586             do ii=1,npair
18587                kstart=ifrag(1,ipair(1,ii,iset),iset)
18588                kend=ifrag(2,ipair(1,ii,iset),iset)
18589                lstart=ifrag(1,ipair(2,ii,iset),iset)
18590                lend=ifrag(2,ipair(2,ii,iset),iset)
18591                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18592                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18593                 qinpair(ii,iset))
18594             enddo
18595             dc(j,i+nres)=cdummy(j,i)
18596             call chainbuild_cart
18597             uzap1=0.0d0
18598              do ii=1,nfrag
18599                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18600                 ifrag(2,ii,iset),.true.,idummy,idummy)
18601                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18602                 qinfrag(ii,iset))
18603             enddo
18604             do ii=1,npair
18605                kstart=ifrag(1,ipair(1,ii,iset),iset)
18606                kend=ifrag(2,ipair(1,ii,iset),iset)
18607                lstart=ifrag(1,ipair(2,ii,iset),iset)
18608                lend=ifrag(2,ipair(2,ii,iset),iset)
18609                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18610                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18611                 qinpair(ii,iset))
18612             enddo
18613             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18614          enddo
18615       enddo
18616       write(iout,*) "Numerical dUconst/ddc backbone "
18617       do ii=0,nres
18618         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18619       enddo
18620 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18621 !      do ii=1,nres
18622 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18623 !      enddo
18624       return
18625       end subroutine dEconstrQ_num
18626 !-----------------------------------------------------------------------------
18627 ! ssMD.F
18628 !-----------------------------------------------------------------------------
18629       subroutine check_energies
18630
18631 !      use random, only: ran_number
18632
18633 !      implicit none
18634 !     Includes
18635 !      include 'DIMENSIONS'
18636 !      include 'COMMON.CHAIN'
18637 !      include 'COMMON.VAR'
18638 !      include 'COMMON.IOUNITS'
18639 !      include 'COMMON.SBRIDGE'
18640 !      include 'COMMON.LOCAL'
18641 !      include 'COMMON.GEO'
18642
18643 !     External functions
18644 !EL      double precision ran_number
18645 !EL      external ran_number
18646
18647 !     Local variables
18648       integer :: i,j,k,l,lmax,p,pmax
18649       real(kind=8) :: rmin,rmax
18650       real(kind=8) :: eij
18651
18652       real(kind=8) :: d
18653       real(kind=8) :: wi,rij,tj,pj
18654 !      return
18655
18656       i=5
18657       j=14
18658
18659       d=dsc(1)
18660       rmin=2.0D0
18661       rmax=12.0D0
18662
18663       lmax=10000
18664       pmax=1
18665
18666       do k=1,3
18667         c(k,i)=0.0D0
18668         c(k,j)=0.0D0
18669         c(k,nres+i)=0.0D0
18670         c(k,nres+j)=0.0D0
18671       enddo
18672
18673       do l=1,lmax
18674
18675 !t        wi=ran_number(0.0D0,pi)
18676 !        wi=ran_number(0.0D0,pi/6.0D0)
18677 !        wi=0.0D0
18678 !t        tj=ran_number(0.0D0,pi)
18679 !t        pj=ran_number(0.0D0,pi)
18680 !        pj=ran_number(0.0D0,pi/6.0D0)
18681 !        pj=0.0D0
18682
18683         do p=1,pmax
18684 !t           rij=ran_number(rmin,rmax)
18685
18686            c(1,j)=d*sin(pj)*cos(tj)
18687            c(2,j)=d*sin(pj)*sin(tj)
18688            c(3,j)=d*cos(pj)
18689
18690            c(3,nres+i)=-rij
18691
18692            c(1,i)=d*sin(wi)
18693            c(3,i)=-rij-d*cos(wi)
18694
18695            do k=1,3
18696               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18697               dc_norm(k,nres+i)=dc(k,nres+i)/d
18698               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18699               dc_norm(k,nres+j)=dc(k,nres+j)/d
18700            enddo
18701
18702            call dyn_ssbond_ene(i,j,eij)
18703         enddo
18704       enddo
18705       call exit(1)
18706       return
18707       end subroutine check_energies
18708 !-----------------------------------------------------------------------------
18709       subroutine dyn_ssbond_ene(resi,resj,eij)
18710 !      implicit none
18711 !      Includes
18712       use calc_data
18713       use comm_sschecks
18714 !      include 'DIMENSIONS'
18715 !      include 'COMMON.SBRIDGE'
18716 !      include 'COMMON.CHAIN'
18717 !      include 'COMMON.DERIV'
18718 !      include 'COMMON.LOCAL'
18719 !      include 'COMMON.INTERACT'
18720 !      include 'COMMON.VAR'
18721 !      include 'COMMON.IOUNITS'
18722 !      include 'COMMON.CALC'
18723 #ifndef CLUST
18724 #ifndef WHAM
18725        use MD_data
18726 !      include 'COMMON.MD'
18727 !      use MD, only: totT,t_bath
18728 #endif
18729 #endif
18730 !     External functions
18731 !EL      double precision h_base
18732 !EL      external h_base
18733
18734 !     Input arguments
18735       integer :: resi,resj
18736
18737 !     Output arguments
18738       real(kind=8) :: eij
18739
18740 !     Local variables
18741       logical :: havebond
18742       integer itypi,itypj
18743       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18744       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18745       real(kind=8),dimension(3) :: dcosom1,dcosom2
18746       real(kind=8) :: ed
18747       real(kind=8) :: pom1,pom2
18748       real(kind=8) :: ljA,ljB,ljXs
18749       real(kind=8),dimension(1:3) :: d_ljB
18750       real(kind=8) :: ssA,ssB,ssC,ssXs
18751       real(kind=8) :: ssxm,ljxm,ssm,ljm
18752       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18753       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18754       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18755 !-------FIRST METHOD
18756       real(kind=8) :: xm
18757       real(kind=8),dimension(1:3) :: d_xm
18758 !-------END FIRST METHOD
18759 !-------SECOND METHOD
18760 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18761 !-------END SECOND METHOD
18762
18763 !-------TESTING CODE
18764 !el      logical :: checkstop,transgrad
18765 !el      common /sschecks/ checkstop,transgrad
18766
18767       integer :: icheck,nicheck,jcheck,njcheck
18768       real(kind=8),dimension(-1:1) :: echeck
18769       real(kind=8) :: deps,ssx0,ljx0
18770 !-------END TESTING CODE
18771
18772       eij=0.0d0
18773       i=resi
18774       j=resj
18775
18776 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18777 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18778
18779       itypi=itype(i,1)
18780       dxi=dc_norm(1,nres+i)
18781       dyi=dc_norm(2,nres+i)
18782       dzi=dc_norm(3,nres+i)
18783       dsci_inv=vbld_inv(i+nres)
18784
18785       itypj=itype(j,1)
18786       xj=c(1,nres+j)-c(1,nres+i)
18787       yj=c(2,nres+j)-c(2,nres+i)
18788       zj=c(3,nres+j)-c(3,nres+i)
18789       dxj=dc_norm(1,nres+j)
18790       dyj=dc_norm(2,nres+j)
18791       dzj=dc_norm(3,nres+j)
18792       dscj_inv=vbld_inv(j+nres)
18793
18794       chi1=chi(itypi,itypj)
18795       chi2=chi(itypj,itypi)
18796       chi12=chi1*chi2
18797       chip1=chip(itypi)
18798       chip2=chip(itypj)
18799       chip12=chip1*chip2
18800       alf1=alp(itypi)
18801       alf2=alp(itypj)
18802       alf12=0.5D0*(alf1+alf2)
18803
18804       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18805       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18806 !     The following are set in sc_angular
18807 !      erij(1)=xj*rij
18808 !      erij(2)=yj*rij
18809 !      erij(3)=zj*rij
18810 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18811 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18812 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18813       call sc_angular
18814       rij=1.0D0/rij  ! Reset this so it makes sense
18815
18816       sig0ij=sigma(itypi,itypj)
18817       sig=sig0ij*dsqrt(1.0D0/sigsq)
18818
18819       ljXs=sig-sig0ij
18820       ljA=eps1*eps2rt**2*eps3rt**2
18821       ljB=ljA*bb_aq(itypi,itypj)
18822       ljA=ljA*aa_aq(itypi,itypj)
18823       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18824
18825       ssXs=d0cm
18826       deltat1=1.0d0-om1
18827       deltat2=1.0d0+om2
18828       deltat12=om2-om1+2.0d0
18829       cosphi=om12-om1*om2
18830       ssA=akcm
18831       ssB=akct*deltat12
18832       ssC=ss_depth &
18833            +akth*(deltat1*deltat1+deltat2*deltat2) &
18834            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18835       ssxm=ssXs-0.5D0*ssB/ssA
18836
18837 !-------TESTING CODE
18838 !$$$c     Some extra output
18839 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18840 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18841 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18842 !$$$      if (ssx0.gt.0.0d0) then
18843 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18844 !$$$      else
18845 !$$$        ssx0=ssxm
18846 !$$$      endif
18847 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18848 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18849 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18850 !$$$      return
18851 !-------END TESTING CODE
18852
18853 !-------TESTING CODE
18854 !     Stop and plot energy and derivative as a function of distance
18855       if (checkstop) then
18856         ssm=ssC-0.25D0*ssB*ssB/ssA
18857         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18858         if (ssm.lt.ljm .and. &
18859              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18860           nicheck=1000
18861           njcheck=1
18862           deps=0.5d-7
18863         else
18864           checkstop=.false.
18865         endif
18866       endif
18867       if (.not.checkstop) then
18868         nicheck=0
18869         njcheck=-1
18870       endif
18871
18872       do icheck=0,nicheck
18873       do jcheck=-1,njcheck
18874       if (checkstop) rij=(ssxm-1.0d0)+ &
18875              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18876 !-------END TESTING CODE
18877
18878       if (rij.gt.ljxm) then
18879         havebond=.false.
18880         ljd=rij-ljXs
18881         fac=(1.0D0/ljd)**expon
18882         e1=fac*fac*aa_aq(itypi,itypj)
18883         e2=fac*bb_aq(itypi,itypj)
18884         eij=eps1*eps2rt*eps3rt*(e1+e2)
18885         eps2der=eij*eps3rt
18886         eps3der=eij*eps2rt
18887         eij=eij*eps2rt*eps3rt
18888
18889         sigder=-sig/sigsq
18890         e1=e1*eps1*eps2rt**2*eps3rt**2
18891         ed=-expon*(e1+eij)/ljd
18892         sigder=ed*sigder
18893         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18894         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18895         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18896              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18897       else if (rij.lt.ssxm) then
18898         havebond=.true.
18899         ssd=rij-ssXs
18900         eij=ssA*ssd*ssd+ssB*ssd+ssC
18901
18902         ed=2*akcm*ssd+akct*deltat12
18903         pom1=akct*ssd
18904         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18905         eom1=-2*akth*deltat1-pom1-om2*pom2
18906         eom2= 2*akth*deltat2+pom1-om1*pom2
18907         eom12=pom2
18908       else
18909         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18910
18911         d_ssxm(1)=0.5D0*akct/ssA
18912         d_ssxm(2)=-d_ssxm(1)
18913         d_ssxm(3)=0.0D0
18914
18915         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18916         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18917         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18918         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18919
18920 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18921         xm=0.5d0*(ssxm+ljxm)
18922         do k=1,3
18923           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18924         enddo
18925         if (rij.lt.xm) then
18926           havebond=.true.
18927           ssm=ssC-0.25D0*ssB*ssB/ssA
18928           d_ssm(1)=0.5D0*akct*ssB/ssA
18929           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18930           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18931           d_ssm(3)=omega
18932           f1=(rij-xm)/(ssxm-xm)
18933           f2=(rij-ssxm)/(xm-ssxm)
18934           h1=h_base(f1,hd1)
18935           h2=h_base(f2,hd2)
18936           eij=ssm*h1+Ht*h2
18937           delta_inv=1.0d0/(xm-ssxm)
18938           deltasq_inv=delta_inv*delta_inv
18939           fac=ssm*hd1-Ht*hd2
18940           fac1=deltasq_inv*fac*(xm-rij)
18941           fac2=deltasq_inv*fac*(rij-ssxm)
18942           ed=delta_inv*(Ht*hd2-ssm*hd1)
18943           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18944           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18945           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18946         else
18947           havebond=.false.
18948           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18949           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18950           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18951           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18952                alf12/eps3rt)
18953           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18954           f1=(rij-ljxm)/(xm-ljxm)
18955           f2=(rij-xm)/(ljxm-xm)
18956           h1=h_base(f1,hd1)
18957           h2=h_base(f2,hd2)
18958           eij=Ht*h1+ljm*h2
18959           delta_inv=1.0d0/(ljxm-xm)
18960           deltasq_inv=delta_inv*delta_inv
18961           fac=Ht*hd1-ljm*hd2
18962           fac1=deltasq_inv*fac*(ljxm-rij)
18963           fac2=deltasq_inv*fac*(rij-xm)
18964           ed=delta_inv*(ljm*hd2-Ht*hd1)
18965           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18966           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18967           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18968         endif
18969 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18970
18971 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18972 !$$$        ssd=rij-ssXs
18973 !$$$        ljd=rij-ljXs
18974 !$$$        fac1=rij-ljxm
18975 !$$$        fac2=rij-ssxm
18976 !$$$
18977 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18978 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18979 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18980 !$$$
18981 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18982 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18983 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18984 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18985 !$$$        d_ssm(3)=omega
18986 !$$$
18987 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18988 !$$$        do k=1,3
18989 !$$$          d_ljm(k)=ljm*d_ljB(k)
18990 !$$$        enddo
18991 !$$$        ljm=ljm*ljB
18992 !$$$
18993 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18994 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18995 !$$$        d_ss(2)=akct*ssd
18996 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18997 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18998 !$$$        d_ss(3)=omega
18999 !$$$
19000 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19001 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19002 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19003 !$$$        do k=1,3
19004 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19005 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19006 !$$$        enddo
19007 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19008 !$$$
19009 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19010 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19011 !$$$        h1=h_base(f1,hd1)
19012 !$$$        h2=h_base(f2,hd2)
19013 !$$$        eij=ss*h1+ljf*h2
19014 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19015 !$$$        deltasq_inv=delta_inv*delta_inv
19016 !$$$        fac=ljf*hd2-ss*hd1
19017 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19018 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19019 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19020 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19021 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19022 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19023 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19024 !$$$
19025 !$$$        havebond=.false.
19026 !$$$        if (ed.gt.0.0d0) havebond=.true.
19027 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19028
19029       endif
19030
19031       if (havebond) then
19032 !#ifndef CLUST
19033 !#ifndef WHAM
19034 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19035 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19036 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19037 !        endif
19038 !#endif
19039 !#endif
19040         dyn_ssbond_ij(i,j)=eij
19041       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19042         dyn_ssbond_ij(i,j)=1.0d300
19043 !#ifndef CLUST
19044 !#ifndef WHAM
19045 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19046 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19047 !#endif
19048 !#endif
19049       endif
19050
19051 !-------TESTING CODE
19052 !el      if (checkstop) then
19053         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19054              "CHECKSTOP",rij,eij,ed
19055         echeck(jcheck)=eij
19056 !el      endif
19057       enddo
19058       if (checkstop) then
19059         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19060       endif
19061       enddo
19062       if (checkstop) then
19063         transgrad=.true.
19064         checkstop=.false.
19065       endif
19066 !-------END TESTING CODE
19067
19068       do k=1,3
19069         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19070         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19071       enddo
19072       do k=1,3
19073         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19074       enddo
19075       do k=1,3
19076         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19077              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19078              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19079         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19080              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19081              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19082       enddo
19083 !grad      do k=i,j-1
19084 !grad        do l=1,3
19085 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19086 !grad        enddo
19087 !grad      enddo
19088
19089       do l=1,3
19090         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19091         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19092       enddo
19093
19094       return
19095       end subroutine dyn_ssbond_ene
19096 !--------------------------------------------------------------------------
19097          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19098 !      implicit none
19099 !      Includes
19100       use calc_data
19101       use comm_sschecks
19102 !      include 'DIMENSIONS'
19103 !      include 'COMMON.SBRIDGE'
19104 !      include 'COMMON.CHAIN'
19105 !      include 'COMMON.DERIV'
19106 !      include 'COMMON.LOCAL'
19107 !      include 'COMMON.INTERACT'
19108 !      include 'COMMON.VAR'
19109 !      include 'COMMON.IOUNITS'
19110 !      include 'COMMON.CALC'
19111 #ifndef CLUST
19112 #ifndef WHAM
19113        use MD_data
19114 !      include 'COMMON.MD'
19115 !      use MD, only: totT,t_bath
19116 #endif
19117 #endif
19118       double precision h_base
19119       external h_base
19120
19121 !c     Input arguments
19122       integer resi,resj,resk,m,itypi,itypj,itypk
19123
19124 !c     Output arguments
19125       double precision eij,eij1,eij2,eij3
19126
19127 !c     Local variables
19128       logical havebond
19129 !c      integer itypi,itypj,k,l
19130       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19131       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19132       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19133       double precision sig0ij,ljd,sig,fac,e1,e2
19134       double precision dcosom1(3),dcosom2(3),ed
19135       double precision pom1,pom2
19136       double precision ljA,ljB,ljXs
19137       double precision d_ljB(1:3)
19138       double precision ssA,ssB,ssC,ssXs
19139       double precision ssxm,ljxm,ssm,ljm
19140       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19141       eij=0.0
19142       if (dtriss.eq.0) return
19143       i=resi
19144       j=resj
19145       k=resk
19146 !C      write(iout,*) resi,resj,resk
19147       itypi=itype(i,1)
19148       dxi=dc_norm(1,nres+i)
19149       dyi=dc_norm(2,nres+i)
19150       dzi=dc_norm(3,nres+i)
19151       dsci_inv=vbld_inv(i+nres)
19152       xi=c(1,nres+i)
19153       yi=c(2,nres+i)
19154       zi=c(3,nres+i)
19155       itypj=itype(j,1)
19156       xj=c(1,nres+j)
19157       yj=c(2,nres+j)
19158       zj=c(3,nres+j)
19159
19160       dxj=dc_norm(1,nres+j)
19161       dyj=dc_norm(2,nres+j)
19162       dzj=dc_norm(3,nres+j)
19163       dscj_inv=vbld_inv(j+nres)
19164       itypk=itype(k,1)
19165       xk=c(1,nres+k)
19166       yk=c(2,nres+k)
19167       zk=c(3,nres+k)
19168
19169       dxk=dc_norm(1,nres+k)
19170       dyk=dc_norm(2,nres+k)
19171       dzk=dc_norm(3,nres+k)
19172       dscj_inv=vbld_inv(k+nres)
19173       xij=xj-xi
19174       xik=xk-xi
19175       xjk=xk-xj
19176       yij=yj-yi
19177       yik=yk-yi
19178       yjk=yk-yj
19179       zij=zj-zi
19180       zik=zk-zi
19181       zjk=zk-zj
19182       rrij=(xij*xij+yij*yij+zij*zij)
19183       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19184       rrik=(xik*xik+yik*yik+zik*zik)
19185       rik=dsqrt(rrik)
19186       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19187       rjk=dsqrt(rrjk)
19188 !C there are three combination of distances for each trisulfide bonds
19189 !C The first case the ith atom is the center
19190 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19191 !C distance y is second distance the a,b,c,d are parameters derived for
19192 !C this problem d parameter was set as a penalty currenlty set to 1.
19193       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19194       eij1=0.0d0
19195       else
19196       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19197       endif
19198 !C second case jth atom is center
19199       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19200       eij2=0.0d0
19201       else
19202       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19203       endif
19204 !C the third case kth atom is the center
19205       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19206       eij3=0.0d0
19207       else
19208       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19209       endif
19210 !C      eij2=0.0
19211 !C      eij3=0.0
19212 !C      eij1=0.0
19213       eij=eij1+eij2+eij3
19214 !C      write(iout,*)i,j,k,eij
19215 !C The energy penalty calculated now time for the gradient part
19216 !C derivative over rij
19217       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19218       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19219             gg(1)=xij*fac/rij
19220             gg(2)=yij*fac/rij
19221             gg(3)=zij*fac/rij
19222       do m=1,3
19223         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19224         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19225       enddo
19226
19227       do l=1,3
19228         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19229         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19230       enddo
19231 !C now derivative over rik
19232       fac=-eij1**2/dtriss* &
19233       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19234       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19235             gg(1)=xik*fac/rik
19236             gg(2)=yik*fac/rik
19237             gg(3)=zik*fac/rik
19238       do m=1,3
19239         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19240         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19241       enddo
19242       do l=1,3
19243         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19244         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19245       enddo
19246 !C now derivative over rjk
19247       fac=-eij2**2/dtriss* &
19248       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19249       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19250             gg(1)=xjk*fac/rjk
19251             gg(2)=yjk*fac/rjk
19252             gg(3)=zjk*fac/rjk
19253       do m=1,3
19254         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19255         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19256       enddo
19257       do l=1,3
19258         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19259         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19260       enddo
19261       return
19262       end subroutine triple_ssbond_ene
19263
19264
19265
19266 !-----------------------------------------------------------------------------
19267       real(kind=8) function h_base(x,deriv)
19268 !     A smooth function going 0->1 in range [0,1]
19269 !     It should NOT be called outside range [0,1], it will not work there.
19270       implicit none
19271
19272 !     Input arguments
19273       real(kind=8) :: x
19274
19275 !     Output arguments
19276       real(kind=8) :: deriv
19277
19278 !     Local variables
19279       real(kind=8) :: xsq
19280
19281
19282 !     Two parabolas put together.  First derivative zero at extrema
19283 !$$$      if (x.lt.0.5D0) then
19284 !$$$        h_base=2.0D0*x*x
19285 !$$$        deriv=4.0D0*x
19286 !$$$      else
19287 !$$$        deriv=1.0D0-x
19288 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19289 !$$$        deriv=4.0D0*deriv
19290 !$$$      endif
19291
19292 !     Third degree polynomial.  First derivative zero at extrema
19293       h_base=x*x*(3.0d0-2.0d0*x)
19294       deriv=6.0d0*x*(1.0d0-x)
19295
19296 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19297 !$$$      xsq=x*x
19298 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19299 !$$$      deriv=x-1.0d0
19300 !$$$      deriv=deriv*deriv
19301 !$$$      deriv=30.0d0*xsq*deriv
19302
19303       return
19304       end function h_base
19305 !-----------------------------------------------------------------------------
19306       subroutine dyn_set_nss
19307 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19308 !      implicit none
19309       use MD_data, only: totT,t_bath
19310 !     Includes
19311 !      include 'DIMENSIONS'
19312 #ifdef MPI
19313       include "mpif.h"
19314 #endif
19315 !      include 'COMMON.SBRIDGE'
19316 !      include 'COMMON.CHAIN'
19317 !      include 'COMMON.IOUNITS'
19318 !      include 'COMMON.SETUP'
19319 !      include 'COMMON.MD'
19320 !     Local variables
19321       real(kind=8) :: emin
19322       integer :: i,j,imin,ierr
19323       integer :: diff,allnss,newnss
19324       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19325                 newihpb,newjhpb
19326       logical :: found
19327       integer,dimension(0:nfgtasks) :: i_newnss
19328       integer,dimension(0:nfgtasks) :: displ
19329       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19330       integer :: g_newnss
19331
19332       allnss=0
19333       do i=1,nres-1
19334         do j=i+1,nres
19335           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19336             allnss=allnss+1
19337             allflag(allnss)=0
19338             allihpb(allnss)=i
19339             alljhpb(allnss)=j
19340           endif
19341         enddo
19342       enddo
19343
19344 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19345
19346  1    emin=1.0d300
19347       do i=1,allnss
19348         if (allflag(i).eq.0 .and. &
19349              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19350           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19351           imin=i
19352         endif
19353       enddo
19354       if (emin.lt.1.0d300) then
19355         allflag(imin)=1
19356         do i=1,allnss
19357           if (allflag(i).eq.0 .and. &
19358                (allihpb(i).eq.allihpb(imin) .or. &
19359                alljhpb(i).eq.allihpb(imin) .or. &
19360                allihpb(i).eq.alljhpb(imin) .or. &
19361                alljhpb(i).eq.alljhpb(imin))) then
19362             allflag(i)=-1
19363           endif
19364         enddo
19365         goto 1
19366       endif
19367
19368 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19369
19370       newnss=0
19371       do i=1,allnss
19372         if (allflag(i).eq.1) then
19373           newnss=newnss+1
19374           newihpb(newnss)=allihpb(i)
19375           newjhpb(newnss)=alljhpb(i)
19376         endif
19377       enddo
19378
19379 #ifdef MPI
19380       if (nfgtasks.gt.1)then
19381
19382         call MPI_Reduce(newnss,g_newnss,1,&
19383           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19384         call MPI_Gather(newnss,1,MPI_INTEGER,&
19385                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19386         displ(0)=0
19387         do i=1,nfgtasks-1,1
19388           displ(i)=i_newnss(i-1)+displ(i-1)
19389         enddo
19390         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19391                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19392                          king,FG_COMM,IERR)
19393         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19394                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19395                          king,FG_COMM,IERR)
19396         if(fg_rank.eq.0) then
19397 !         print *,'g_newnss',g_newnss
19398 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19399 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19400          newnss=g_newnss
19401          do i=1,newnss
19402           newihpb(i)=g_newihpb(i)
19403           newjhpb(i)=g_newjhpb(i)
19404          enddo
19405         endif
19406       endif
19407 #endif
19408
19409       diff=newnss-nss
19410
19411 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19412 !       print *,newnss,nss,maxdim
19413       do i=1,nss
19414         found=.false.
19415 !        print *,newnss
19416         do j=1,newnss
19417 !!          print *,j
19418           if (idssb(i).eq.newihpb(j) .and. &
19419                jdssb(i).eq.newjhpb(j)) found=.true.
19420         enddo
19421 #ifndef CLUST
19422 #ifndef WHAM
19423 !        write(iout,*) "found",found,i,j
19424         if (.not.found.and.fg_rank.eq.0) &
19425             write(iout,'(a15,f12.2,f8.1,2i5)') &
19426              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19427 #endif
19428 #endif
19429       enddo
19430
19431       do i=1,newnss
19432         found=.false.
19433         do j=1,nss
19434 !          print *,i,j
19435           if (newihpb(i).eq.idssb(j) .and. &
19436                newjhpb(i).eq.jdssb(j)) found=.true.
19437         enddo
19438 #ifndef CLUST
19439 #ifndef WHAM
19440 !        write(iout,*) "found",found,i,j
19441         if (.not.found.and.fg_rank.eq.0) &
19442             write(iout,'(a15,f12.2,f8.1,2i5)') &
19443              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19444 #endif
19445 #endif
19446       enddo
19447
19448       nss=newnss
19449       do i=1,nss
19450         idssb(i)=newihpb(i)
19451         jdssb(i)=newjhpb(i)
19452       enddo
19453
19454       return
19455       end subroutine dyn_set_nss
19456 ! Lipid transfer energy function
19457       subroutine Eliptransfer(eliptran)
19458 !C this is done by Adasko
19459 !C      print *,"wchodze"
19460 !C structure of box:
19461 !C      water
19462 !C--bordliptop-- buffore starts
19463 !C--bufliptop--- here true lipid starts
19464 !C      lipid
19465 !C--buflipbot--- lipid ends buffore starts
19466 !C--bordlipbot--buffore ends
19467       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19468       integer :: i
19469       eliptran=0.0
19470 !      print *, "I am in eliptran"
19471       do i=ilip_start,ilip_end
19472 !C       do i=1,1
19473         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19474          cycle
19475
19476         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19477         if (positi.le.0.0) positi=positi+boxzsize
19478 !C        print *,i
19479 !C first for peptide groups
19480 !c for each residue check if it is in lipid or lipid water border area
19481        if ((positi.gt.bordlipbot)  &
19482       .and.(positi.lt.bordliptop)) then
19483 !C the energy transfer exist
19484         if (positi.lt.buflipbot) then
19485 !C what fraction I am in
19486          fracinbuf=1.0d0-      &
19487              ((positi-bordlipbot)/lipbufthick)
19488 !C lipbufthick is thickenes of lipid buffore
19489          sslip=sscalelip(fracinbuf)
19490          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19491          eliptran=eliptran+sslip*pepliptran
19492          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19493          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19494 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19495
19496 !C        print *,"doing sccale for lower part"
19497 !C         print *,i,sslip,fracinbuf,ssgradlip
19498         elseif (positi.gt.bufliptop) then
19499          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19500          sslip=sscalelip(fracinbuf)
19501          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19502          eliptran=eliptran+sslip*pepliptran
19503          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19504          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19505 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19506 !C          print *, "doing sscalefor top part"
19507 !C         print *,i,sslip,fracinbuf,ssgradlip
19508         else
19509          eliptran=eliptran+pepliptran
19510 !C         print *,"I am in true lipid"
19511         endif
19512 !C       else
19513 !C       eliptran=elpitran+0.0 ! I am in water
19514        endif
19515        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19516        enddo
19517 ! here starts the side chain transfer
19518        do i=ilip_start,ilip_end
19519         if (itype(i,1).eq.ntyp1) cycle
19520         positi=(mod(c(3,i+nres),boxzsize))
19521         if (positi.le.0) positi=positi+boxzsize
19522 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19523 !c for each residue check if it is in lipid or lipid water border area
19524 !C       respos=mod(c(3,i+nres),boxzsize)
19525 !C       print *,positi,bordlipbot,buflipbot
19526        if ((positi.gt.bordlipbot) &
19527        .and.(positi.lt.bordliptop)) then
19528 !C the energy transfer exist
19529         if (positi.lt.buflipbot) then
19530          fracinbuf=1.0d0-   &
19531            ((positi-bordlipbot)/lipbufthick)
19532 !C lipbufthick is thickenes of lipid buffore
19533          sslip=sscalelip(fracinbuf)
19534          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19535          eliptran=eliptran+sslip*liptranene(itype(i,1))
19536          gliptranx(3,i)=gliptranx(3,i) &
19537       +ssgradlip*liptranene(itype(i,1))
19538          gliptranc(3,i-1)= gliptranc(3,i-1) &
19539       +ssgradlip*liptranene(itype(i,1))
19540 !C         print *,"doing sccale for lower part"
19541         elseif (positi.gt.bufliptop) then
19542          fracinbuf=1.0d0-  &
19543       ((bordliptop-positi)/lipbufthick)
19544          sslip=sscalelip(fracinbuf)
19545          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19546          eliptran=eliptran+sslip*liptranene(itype(i,1))
19547          gliptranx(3,i)=gliptranx(3,i)  &
19548        +ssgradlip*liptranene(itype(i,1))
19549          gliptranc(3,i-1)= gliptranc(3,i-1) &
19550       +ssgradlip*liptranene(itype(i,1))
19551 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19552         else
19553          eliptran=eliptran+liptranene(itype(i,1))
19554 !C         print *,"I am in true lipid"
19555         endif
19556         endif ! if in lipid or buffor
19557 !C       else
19558 !C       eliptran=elpitran+0.0 ! I am in water
19559         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19560        enddo
19561        return
19562        end  subroutine Eliptransfer
19563 !----------------------------------NANO FUNCTIONS
19564 !C-----------------------------------------------------------------------
19565 !C-----------------------------------------------------------
19566 !C This subroutine is to mimic the histone like structure but as well can be
19567 !C utilizet to nanostructures (infinit) small modification has to be used to
19568 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19569 !C gradient has to be modified at the ends
19570 !C The energy function is Kihara potential
19571 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19572 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19573 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19574 !C simple Kihara potential
19575       subroutine calctube(Etube)
19576       real(kind=8),dimension(3) :: vectube
19577       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19578        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19579        sc_aa_tube,sc_bb_tube
19580       integer :: i,j,iti
19581       Etube=0.0d0
19582       do i=itube_start,itube_end
19583         enetube(i)=0.0d0
19584         enetube(i+nres)=0.0d0
19585       enddo
19586 !C first we calculate the distance from tube center
19587 !C for UNRES
19588        do i=itube_start,itube_end
19589 !C lets ommit dummy atoms for now
19590        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19591 !C now calculate distance from center of tube and direction vectors
19592       xmin=boxxsize
19593       ymin=boxysize
19594 ! Find minimum distance in periodic box
19595         do j=-1,1
19596          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19597          vectube(1)=vectube(1)+boxxsize*j
19598          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19599          vectube(2)=vectube(2)+boxysize*j
19600          xminact=abs(vectube(1)-tubecenter(1))
19601          yminact=abs(vectube(2)-tubecenter(2))
19602            if (xmin.gt.xminact) then
19603             xmin=xminact
19604             xtemp=vectube(1)
19605            endif
19606            if (ymin.gt.yminact) then
19607              ymin=yminact
19608              ytemp=vectube(2)
19609             endif
19610          enddo
19611       vectube(1)=xtemp
19612       vectube(2)=ytemp
19613       vectube(1)=vectube(1)-tubecenter(1)
19614       vectube(2)=vectube(2)-tubecenter(2)
19615
19616 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19617 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19618
19619 !C as the tube is infinity we do not calculate the Z-vector use of Z
19620 !C as chosen axis
19621       vectube(3)=0.0d0
19622 !C now calculte the distance
19623        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19624 !C now normalize vector
19625       vectube(1)=vectube(1)/tub_r
19626       vectube(2)=vectube(2)/tub_r
19627 !C calculte rdiffrence between r and r0
19628       rdiff=tub_r-tubeR0
19629 !C and its 6 power
19630       rdiff6=rdiff**6.0d0
19631 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19632        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19633 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19634 !C       print *,rdiff,rdiff6,pep_aa_tube
19635 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19636 !C now we calculate gradient
19637        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19638             6.0d0*pep_bb_tube)/rdiff6/rdiff
19639 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19640 !C     &rdiff,fac
19641 !C now direction of gg_tube vector
19642         do j=1,3
19643         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19644         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19645         enddo
19646         enddo
19647 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19648 !C        print *,gg_tube(1,0),"TU"
19649
19650
19651        do i=itube_start,itube_end
19652 !C Lets not jump over memory as we use many times iti
19653          iti=itype(i,1)
19654 !C lets ommit dummy atoms for now
19655          if ((iti.eq.ntyp1)  &
19656 !C in UNRES uncomment the line below as GLY has no side-chain...
19657 !C      .or.(iti.eq.10)
19658         ) cycle
19659       xmin=boxxsize
19660       ymin=boxysize
19661         do j=-1,1
19662          vectube(1)=mod((c(1,i+nres)),boxxsize)
19663          vectube(1)=vectube(1)+boxxsize*j
19664          vectube(2)=mod((c(2,i+nres)),boxysize)
19665          vectube(2)=vectube(2)+boxysize*j
19666
19667          xminact=abs(vectube(1)-tubecenter(1))
19668          yminact=abs(vectube(2)-tubecenter(2))
19669            if (xmin.gt.xminact) then
19670             xmin=xminact
19671             xtemp=vectube(1)
19672            endif
19673            if (ymin.gt.yminact) then
19674              ymin=yminact
19675              ytemp=vectube(2)
19676             endif
19677          enddo
19678       vectube(1)=xtemp
19679       vectube(2)=ytemp
19680 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19681 !C     &     tubecenter(2)
19682       vectube(1)=vectube(1)-tubecenter(1)
19683       vectube(2)=vectube(2)-tubecenter(2)
19684
19685 !C as the tube is infinity we do not calculate the Z-vector use of Z
19686 !C as chosen axis
19687       vectube(3)=0.0d0
19688 !C now calculte the distance
19689        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19690 !C now normalize vector
19691       vectube(1)=vectube(1)/tub_r
19692       vectube(2)=vectube(2)/tub_r
19693
19694 !C calculte rdiffrence between r and r0
19695       rdiff=tub_r-tubeR0
19696 !C and its 6 power
19697       rdiff6=rdiff**6.0d0
19698 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19699        sc_aa_tube=sc_aa_tube_par(iti)
19700        sc_bb_tube=sc_bb_tube_par(iti)
19701        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19702        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19703              6.0d0*sc_bb_tube/rdiff6/rdiff
19704 !C now direction of gg_tube vector
19705          do j=1,3
19706           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19707           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19708          enddo
19709         enddo
19710         do i=itube_start,itube_end
19711           Etube=Etube+enetube(i)+enetube(i+nres)
19712         enddo
19713 !C        print *,"ETUBE", etube
19714         return
19715         end subroutine calctube
19716 !C TO DO 1) add to total energy
19717 !C       2) add to gradient summation
19718 !C       3) add reading parameters (AND of course oppening of PARAM file)
19719 !C       4) add reading the center of tube
19720 !C       5) add COMMONs
19721 !C       6) add to zerograd
19722 !C       7) allocate matrices
19723
19724
19725 !C-----------------------------------------------------------------------
19726 !C-----------------------------------------------------------
19727 !C This subroutine is to mimic the histone like structure but as well can be
19728 !C utilizet to nanostructures (infinit) small modification has to be used to
19729 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19730 !C gradient has to be modified at the ends
19731 !C The energy function is Kihara potential
19732 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19733 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19734 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19735 !C simple Kihara potential
19736       subroutine calctube2(Etube)
19737             real(kind=8),dimension(3) :: vectube
19738       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19739        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19740        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19741       integer:: i,j,iti
19742       Etube=0.0d0
19743       do i=itube_start,itube_end
19744         enetube(i)=0.0d0
19745         enetube(i+nres)=0.0d0
19746       enddo
19747 !C first we calculate the distance from tube center
19748 !C first sugare-phosphate group for NARES this would be peptide group
19749 !C for UNRES
19750        do i=itube_start,itube_end
19751 !C lets ommit dummy atoms for now
19752
19753        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19754 !C now calculate distance from center of tube and direction vectors
19755 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19756 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19757 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19758 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19759       xmin=boxxsize
19760       ymin=boxysize
19761         do j=-1,1
19762          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19763          vectube(1)=vectube(1)+boxxsize*j
19764          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19765          vectube(2)=vectube(2)+boxysize*j
19766
19767          xminact=abs(vectube(1)-tubecenter(1))
19768          yminact=abs(vectube(2)-tubecenter(2))
19769            if (xmin.gt.xminact) then
19770             xmin=xminact
19771             xtemp=vectube(1)
19772            endif
19773            if (ymin.gt.yminact) then
19774              ymin=yminact
19775              ytemp=vectube(2)
19776             endif
19777          enddo
19778       vectube(1)=xtemp
19779       vectube(2)=ytemp
19780       vectube(1)=vectube(1)-tubecenter(1)
19781       vectube(2)=vectube(2)-tubecenter(2)
19782
19783 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19784 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19785
19786 !C as the tube is infinity we do not calculate the Z-vector use of Z
19787 !C as chosen axis
19788       vectube(3)=0.0d0
19789 !C now calculte the distance
19790        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19791 !C now normalize vector
19792       vectube(1)=vectube(1)/tub_r
19793       vectube(2)=vectube(2)/tub_r
19794 !C calculte rdiffrence between r and r0
19795       rdiff=tub_r-tubeR0
19796 !C and its 6 power
19797       rdiff6=rdiff**6.0d0
19798 !C THIS FRAGMENT MAKES TUBE FINITE
19799         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19800         if (positi.le.0) positi=positi+boxzsize
19801 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19802 !c for each residue check if it is in lipid or lipid water border area
19803 !C       respos=mod(c(3,i+nres),boxzsize)
19804 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19805        if ((positi.gt.bordtubebot)  &
19806         .and.(positi.lt.bordtubetop)) then
19807 !C the energy transfer exist
19808         if (positi.lt.buftubebot) then
19809          fracinbuf=1.0d0-  &
19810            ((positi-bordtubebot)/tubebufthick)
19811 !C lipbufthick is thickenes of lipid buffore
19812          sstube=sscalelip(fracinbuf)
19813          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19814 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19815          enetube(i)=enetube(i)+sstube*tubetranenepep
19816 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19817 !C     &+ssgradtube*tubetranene(itype(i,1))
19818 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19819 !C     &+ssgradtube*tubetranene(itype(i,1))
19820 !C         print *,"doing sccale for lower part"
19821         elseif (positi.gt.buftubetop) then
19822          fracinbuf=1.0d0-  &
19823         ((bordtubetop-positi)/tubebufthick)
19824          sstube=sscalelip(fracinbuf)
19825          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19826          enetube(i)=enetube(i)+sstube*tubetranenepep
19827 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19828 !C     &+ssgradtube*tubetranene(itype(i,1))
19829 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19830 !C     &+ssgradtube*tubetranene(itype(i,1))
19831 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19832         else
19833          sstube=1.0d0
19834          ssgradtube=0.0d0
19835          enetube(i)=enetube(i)+sstube*tubetranenepep
19836 !C         print *,"I am in true lipid"
19837         endif
19838         else
19839 !C          sstube=0.0d0
19840 !C          ssgradtube=0.0d0
19841         cycle
19842         endif ! if in lipid or buffor
19843
19844 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19845        enetube(i)=enetube(i)+sstube* &
19846         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19847 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19848 !C       print *,rdiff,rdiff6,pep_aa_tube
19849 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19850 !C now we calculate gradient
19851        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19852              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19853 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19854 !C     &rdiff,fac
19855
19856 !C now direction of gg_tube vector
19857        do j=1,3
19858         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19859         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19860         enddo
19861          gg_tube(3,i)=gg_tube(3,i)  &
19862        +ssgradtube*enetube(i)/sstube/2.0d0
19863          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19864        +ssgradtube*enetube(i)/sstube/2.0d0
19865
19866         enddo
19867 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19868 !C        print *,gg_tube(1,0),"TU"
19869         do i=itube_start,itube_end
19870 !C Lets not jump over memory as we use many times iti
19871          iti=itype(i,1)
19872 !C lets ommit dummy atoms for now
19873          if ((iti.eq.ntyp1) &
19874 !!C in UNRES uncomment the line below as GLY has no side-chain...
19875            .or.(iti.eq.10) &
19876           ) cycle
19877           vectube(1)=c(1,i+nres)
19878           vectube(1)=mod(vectube(1),boxxsize)
19879           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19880           vectube(2)=c(2,i+nres)
19881           vectube(2)=mod(vectube(2),boxysize)
19882           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19883
19884       vectube(1)=vectube(1)-tubecenter(1)
19885       vectube(2)=vectube(2)-tubecenter(2)
19886 !C THIS FRAGMENT MAKES TUBE FINITE
19887         positi=(mod(c(3,i+nres),boxzsize))
19888         if (positi.le.0) positi=positi+boxzsize
19889 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19890 !c for each residue check if it is in lipid or lipid water border area
19891 !C       respos=mod(c(3,i+nres),boxzsize)
19892 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19893
19894        if ((positi.gt.bordtubebot)  &
19895         .and.(positi.lt.bordtubetop)) then
19896 !C the energy transfer exist
19897         if (positi.lt.buftubebot) then
19898          fracinbuf=1.0d0- &
19899             ((positi-bordtubebot)/tubebufthick)
19900 !C lipbufthick is thickenes of lipid buffore
19901          sstube=sscalelip(fracinbuf)
19902          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19903 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19904          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19905 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19906 !C     &+ssgradtube*tubetranene(itype(i,1))
19907 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19908 !C     &+ssgradtube*tubetranene(itype(i,1))
19909 !C         print *,"doing sccale for lower part"
19910         elseif (positi.gt.buftubetop) then
19911          fracinbuf=1.0d0- &
19912         ((bordtubetop-positi)/tubebufthick)
19913
19914          sstube=sscalelip(fracinbuf)
19915          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19916          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19917 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19918 !C     &+ssgradtube*tubetranene(itype(i,1))
19919 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19920 !C     &+ssgradtube*tubetranene(itype(i,1))
19921 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19922         else
19923          sstube=1.0d0
19924          ssgradtube=0.0d0
19925          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19926 !C         print *,"I am in true lipid"
19927         endif
19928         else
19929 !C          sstube=0.0d0
19930 !C          ssgradtube=0.0d0
19931         cycle
19932         endif ! if in lipid or buffor
19933 !CEND OF FINITE FRAGMENT
19934 !C as the tube is infinity we do not calculate the Z-vector use of Z
19935 !C as chosen axis
19936       vectube(3)=0.0d0
19937 !C now calculte the distance
19938        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19939 !C now normalize vector
19940       vectube(1)=vectube(1)/tub_r
19941       vectube(2)=vectube(2)/tub_r
19942 !C calculte rdiffrence between r and r0
19943       rdiff=tub_r-tubeR0
19944 !C and its 6 power
19945       rdiff6=rdiff**6.0d0
19946 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19947        sc_aa_tube=sc_aa_tube_par(iti)
19948        sc_bb_tube=sc_bb_tube_par(iti)
19949        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19950                        *sstube+enetube(i+nres)
19951 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19952 !C now we calculate gradient
19953        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19954             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19955 !C now direction of gg_tube vector
19956          do j=1,3
19957           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19958           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19959          enddo
19960          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19961        +ssgradtube*enetube(i+nres)/sstube
19962          gg_tube(3,i-1)= gg_tube(3,i-1) &
19963        +ssgradtube*enetube(i+nres)/sstube
19964
19965         enddo
19966         do i=itube_start,itube_end
19967           Etube=Etube+enetube(i)+enetube(i+nres)
19968         enddo
19969 !C        print *,"ETUBE", etube
19970         return
19971         end subroutine calctube2
19972 !=====================================================================================================================================
19973       subroutine calcnano(Etube)
19974       real(kind=8),dimension(3) :: vectube
19975
19976       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19977        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19978        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19979        integer:: i,j,iti,r
19980
19981       Etube=0.0d0
19982 !      print *,itube_start,itube_end,"poczatek"
19983       do i=itube_start,itube_end
19984         enetube(i)=0.0d0
19985         enetube(i+nres)=0.0d0
19986       enddo
19987 !C first we calculate the distance from tube center
19988 !C first sugare-phosphate group for NARES this would be peptide group
19989 !C for UNRES
19990        do i=itube_start,itube_end
19991 !C lets ommit dummy atoms for now
19992        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19993 !C now calculate distance from center of tube and direction vectors
19994       xmin=boxxsize
19995       ymin=boxysize
19996       zmin=boxzsize
19997
19998         do j=-1,1
19999          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20000          vectube(1)=vectube(1)+boxxsize*j
20001          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20002          vectube(2)=vectube(2)+boxysize*j
20003          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20004          vectube(3)=vectube(3)+boxzsize*j
20005
20006
20007          xminact=dabs(vectube(1)-tubecenter(1))
20008          yminact=dabs(vectube(2)-tubecenter(2))
20009          zminact=dabs(vectube(3)-tubecenter(3))
20010
20011            if (xmin.gt.xminact) then
20012             xmin=xminact
20013             xtemp=vectube(1)
20014            endif
20015            if (ymin.gt.yminact) then
20016              ymin=yminact
20017              ytemp=vectube(2)
20018             endif
20019            if (zmin.gt.zminact) then
20020              zmin=zminact
20021              ztemp=vectube(3)
20022             endif
20023          enddo
20024       vectube(1)=xtemp
20025       vectube(2)=ytemp
20026       vectube(3)=ztemp
20027
20028       vectube(1)=vectube(1)-tubecenter(1)
20029       vectube(2)=vectube(2)-tubecenter(2)
20030       vectube(3)=vectube(3)-tubecenter(3)
20031
20032 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20033 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20034 !C as the tube is infinity we do not calculate the Z-vector use of Z
20035 !C as chosen axis
20036 !C      vectube(3)=0.0d0
20037 !C now calculte the distance
20038        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20039 !C now normalize vector
20040       vectube(1)=vectube(1)/tub_r
20041       vectube(2)=vectube(2)/tub_r
20042       vectube(3)=vectube(3)/tub_r
20043 !C calculte rdiffrence between r and r0
20044       rdiff=tub_r-tubeR0
20045 !C and its 6 power
20046       rdiff6=rdiff**6.0d0
20047 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20048        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20049 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20050 !C       print *,rdiff,rdiff6,pep_aa_tube
20051 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20052 !C now we calculate gradient
20053        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20054             6.0d0*pep_bb_tube)/rdiff6/rdiff
20055 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20056 !C     &rdiff,fac
20057          if (acavtubpep.eq.0.0d0) then
20058 !C go to 667
20059          enecavtube(i)=0.0
20060          faccav=0.0
20061          else
20062          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20063          enecavtube(i)=  &
20064         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20065         /denominator
20066          enecavtube(i)=0.0
20067          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20068         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20069         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20070         /denominator**2.0d0
20071 !C         faccav=0.0
20072 !C         fac=fac+faccav
20073 !C 667     continue
20074          endif
20075           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20076         do j=1,3
20077         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20078         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20079         enddo
20080         enddo
20081
20082        do i=itube_start,itube_end
20083         enecavtube(i)=0.0d0
20084 !C Lets not jump over memory as we use many times iti
20085          iti=itype(i,1)
20086 !C lets ommit dummy atoms for now
20087          if ((iti.eq.ntyp1) &
20088 !C in UNRES uncomment the line below as GLY has no side-chain...
20089 !C      .or.(iti.eq.10)
20090          ) cycle
20091       xmin=boxxsize
20092       ymin=boxysize
20093       zmin=boxzsize
20094         do j=-1,1
20095          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20096          vectube(1)=vectube(1)+boxxsize*j
20097          vectube(2)=dmod((c(2,i+nres)),boxysize)
20098          vectube(2)=vectube(2)+boxysize*j
20099          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20100          vectube(3)=vectube(3)+boxzsize*j
20101
20102
20103          xminact=dabs(vectube(1)-tubecenter(1))
20104          yminact=dabs(vectube(2)-tubecenter(2))
20105          zminact=dabs(vectube(3)-tubecenter(3))
20106
20107            if (xmin.gt.xminact) then
20108             xmin=xminact
20109             xtemp=vectube(1)
20110            endif
20111            if (ymin.gt.yminact) then
20112              ymin=yminact
20113              ytemp=vectube(2)
20114             endif
20115            if (zmin.gt.zminact) then
20116              zmin=zminact
20117              ztemp=vectube(3)
20118             endif
20119          enddo
20120       vectube(1)=xtemp
20121       vectube(2)=ytemp
20122       vectube(3)=ztemp
20123
20124 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20125 !C     &     tubecenter(2)
20126       vectube(1)=vectube(1)-tubecenter(1)
20127       vectube(2)=vectube(2)-tubecenter(2)
20128       vectube(3)=vectube(3)-tubecenter(3)
20129 !C now calculte the distance
20130        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20131 !C now normalize vector
20132       vectube(1)=vectube(1)/tub_r
20133       vectube(2)=vectube(2)/tub_r
20134       vectube(3)=vectube(3)/tub_r
20135
20136 !C calculte rdiffrence between r and r0
20137       rdiff=tub_r-tubeR0
20138 !C and its 6 power
20139       rdiff6=rdiff**6.0d0
20140        sc_aa_tube=sc_aa_tube_par(iti)
20141        sc_bb_tube=sc_bb_tube_par(iti)
20142        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20143 !C       enetube(i+nres)=0.0d0
20144 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20145 !C now we calculate gradient
20146        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20147             6.0d0*sc_bb_tube/rdiff6/rdiff
20148 !C       fac=0.0
20149 !C now direction of gg_tube vector
20150 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20151          if (acavtub(iti).eq.0.0d0) then
20152 !C go to 667
20153          enecavtube(i+nres)=0.0d0
20154          faccav=0.0d0
20155          else
20156          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20157          enecavtube(i+nres)=   &
20158         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20159         /denominator
20160 !C         enecavtube(i)=0.0
20161          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20162         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20163         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20164         /denominator**2.0d0
20165 !C         faccav=0.0
20166          fac=fac+faccav
20167 !C 667     continue
20168          endif
20169 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20170 !C     &   enecavtube(i),faccav
20171 !C         print *,"licz=",
20172 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20173 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20174          do j=1,3
20175           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20176           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20177          enddo
20178           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20179         enddo
20180
20181
20182
20183         do i=itube_start,itube_end
20184           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20185          +enecavtube(i+nres)
20186         enddo
20187 !        do i=1,20
20188 !         print *,"begin", i,"a"
20189 !         do r=1,10000
20190 !          rdiff=r/100.0d0
20191 !          rdiff6=rdiff**6.0d0
20192 !          sc_aa_tube=sc_aa_tube_par(i)
20193 !          sc_bb_tube=sc_bb_tube_par(i)
20194 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20195 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20196 !          enecavtube(i)=   &
20197 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20198 !         /denominator
20199
20200 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20201 !         enddo
20202 !         print *,"end",i,"a"
20203 !        enddo
20204 !C        print *,"ETUBE", etube
20205         return
20206         end subroutine calcnano
20207
20208 !===============================================
20209 !--------------------------------------------------------------------------------
20210 !C first for shielding is setting of function of side-chains
20211
20212        subroutine set_shield_fac2
20213        real(kind=8) :: div77_81=0.974996043d0, &
20214         div4_81=0.2222222222d0
20215        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20216          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20217          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20218          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20219 !C the vector between center of side_chain and peptide group
20220        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20221          pept_group,costhet_grad,cosphi_grad_long, &
20222          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20223          sh_frac_dist_grad,pep_side
20224         integer i,j,k
20225 !C      write(2,*) "ivec",ivec_start,ivec_end
20226       do i=1,nres
20227         fac_shield(i)=0.0d0
20228         ishield_list(i)=0
20229         do j=1,3
20230         grad_shield(j,i)=0.0d0
20231         enddo
20232       enddo
20233       do i=ivec_start,ivec_end
20234 !C      do i=1,nres-1
20235 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20236 !      ishield_list(i)=0
20237       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20238 !Cif there two consequtive dummy atoms there is no peptide group between them
20239 !C the line below has to be changed for FGPROC>1
20240       VolumeTotal=0.0
20241       do k=1,nres
20242        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20243        dist_pep_side=0.0
20244        dist_side_calf=0.0
20245        do j=1,3
20246 !C first lets set vector conecting the ithe side-chain with kth side-chain
20247       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20248 !C      pep_side(j)=2.0d0
20249 !C and vector conecting the side-chain with its proper calfa
20250       side_calf(j)=c(j,k+nres)-c(j,k)
20251 !C      side_calf(j)=2.0d0
20252       pept_group(j)=c(j,i)-c(j,i+1)
20253 !C lets have their lenght
20254       dist_pep_side=pep_side(j)**2+dist_pep_side
20255       dist_side_calf=dist_side_calf+side_calf(j)**2
20256       dist_pept_group=dist_pept_group+pept_group(j)**2
20257       enddo
20258        dist_pep_side=sqrt(dist_pep_side)
20259        dist_pept_group=sqrt(dist_pept_group)
20260        dist_side_calf=sqrt(dist_side_calf)
20261       do j=1,3
20262         pep_side_norm(j)=pep_side(j)/dist_pep_side
20263         side_calf_norm(j)=dist_side_calf
20264       enddo
20265 !C now sscale fraction
20266        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20267 !       print *,buff_shield,"buff",sh_frac_dist
20268 !C now sscale
20269         if (sh_frac_dist.le.0.0) cycle
20270 !C        print *,ishield_list(i),i
20271 !C If we reach here it means that this side chain reaches the shielding sphere
20272 !C Lets add him to the list for gradient
20273         ishield_list(i)=ishield_list(i)+1
20274 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20275 !C this list is essential otherwise problem would be O3
20276         shield_list(ishield_list(i),i)=k
20277 !C Lets have the sscale value
20278         if (sh_frac_dist.gt.1.0) then
20279          scale_fac_dist=1.0d0
20280          do j=1,3
20281          sh_frac_dist_grad(j)=0.0d0
20282          enddo
20283         else
20284          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20285                         *(2.0d0*sh_frac_dist-3.0d0)
20286          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20287                        /dist_pep_side/buff_shield*0.5d0
20288          do j=1,3
20289          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20290 !C         sh_frac_dist_grad(j)=0.0d0
20291 !C         scale_fac_dist=1.0d0
20292 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20293 !C     &                    sh_frac_dist_grad(j)
20294          enddo
20295         endif
20296 !C this is what is now we have the distance scaling now volume...
20297       short=short_r_sidechain(itype(k,1))
20298       long=long_r_sidechain(itype(k,1))
20299       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20300       sinthet=short/dist_pep_side*costhet
20301 !      print *,"SORT",short,long,sinthet,costhet
20302 !C now costhet_grad
20303 !C       costhet=0.6d0
20304 !C       sinthet=0.8
20305        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20306 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20307 !C     &             -short/dist_pep_side**2/costhet)
20308 !C       costhet_fac=0.0d0
20309        do j=1,3
20310          costhet_grad(j)=costhet_fac*pep_side(j)
20311        enddo
20312 !C remember for the final gradient multiply costhet_grad(j)
20313 !C for side_chain by factor -2 !
20314 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20315 !C pep_side0pept_group is vector multiplication
20316       pep_side0pept_group=0.0d0
20317       do j=1,3
20318       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20319       enddo
20320       cosalfa=(pep_side0pept_group/ &
20321       (dist_pep_side*dist_side_calf))
20322       fac_alfa_sin=1.0d0-cosalfa**2
20323       fac_alfa_sin=dsqrt(fac_alfa_sin)
20324       rkprim=fac_alfa_sin*(long-short)+short
20325 !C      rkprim=short
20326
20327 !C now costhet_grad
20328        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20329 !C       cosphi=0.6
20330        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20331        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20332            dist_pep_side**2)
20333 !C       sinphi=0.8
20334        do j=1,3
20335          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20336       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20337       *(long-short)/fac_alfa_sin*cosalfa/ &
20338       ((dist_pep_side*dist_side_calf))* &
20339       ((side_calf(j))-cosalfa* &
20340       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20341 !C       cosphi_grad_long(j)=0.0d0
20342         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20343       *(long-short)/fac_alfa_sin*cosalfa &
20344       /((dist_pep_side*dist_side_calf))* &
20345       (pep_side(j)- &
20346       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20347 !C       cosphi_grad_loc(j)=0.0d0
20348        enddo
20349 !C      print *,sinphi,sinthet
20350       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20351                          /VSolvSphere_div
20352 !C     &                    *wshield
20353 !C now the gradient...
20354       do j=1,3
20355       grad_shield(j,i)=grad_shield(j,i) &
20356 !C gradient po skalowaniu
20357                      +(sh_frac_dist_grad(j)*VofOverlap &
20358 !C  gradient po costhet
20359             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20360         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20361             sinphi/sinthet*costhet*costhet_grad(j) &
20362            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20363         )*wshield
20364 !C grad_shield_side is Cbeta sidechain gradient
20365       grad_shield_side(j,ishield_list(i),i)=&
20366              (sh_frac_dist_grad(j)*-2.0d0&
20367              *VofOverlap&
20368             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20369        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20370             sinphi/sinthet*costhet*costhet_grad(j)&
20371            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20372             )*wshield
20373 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20374 !            sinphi/sinthet,&
20375 !           +sinthet/sinphi,"HERE"
20376        grad_shield_loc(j,ishield_list(i),i)=   &
20377             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20378       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20379             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20380              ))&
20381              *wshield
20382 !         print *,grad_shield_loc(j,ishield_list(i),i)
20383       enddo
20384       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20385       enddo
20386       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20387
20388 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20389       enddo
20390       return
20391       end subroutine set_shield_fac2
20392 !----------------------------------------------------------------------------
20393 ! SOUBROUTINE FOR AFM
20394        subroutine AFMvel(Eafmforce)
20395        use MD_data, only:totTafm
20396       real(kind=8),dimension(3) :: diffafm
20397       real(kind=8) :: afmdist,Eafmforce
20398        integer :: i
20399 !C Only for check grad COMMENT if not used for checkgrad
20400 !C      totT=3.0d0
20401 !C--------------------------------------------------------
20402 !C      print *,"wchodze"
20403       afmdist=0.0d0
20404       Eafmforce=0.0d0
20405       do i=1,3
20406       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20407       afmdist=afmdist+diffafm(i)**2
20408       enddo
20409       afmdist=dsqrt(afmdist)
20410 !      totTafm=3.0
20411       Eafmforce=0.5d0*forceAFMconst &
20412       *(distafminit+totTafm*velAFMconst-afmdist)**2
20413 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20414       do i=1,3
20415       gradafm(i,afmend-1)=-forceAFMconst* &
20416        (distafminit+totTafm*velAFMconst-afmdist) &
20417        *diffafm(i)/afmdist
20418       gradafm(i,afmbeg-1)=forceAFMconst* &
20419       (distafminit+totTafm*velAFMconst-afmdist) &
20420       *diffafm(i)/afmdist
20421       enddo
20422 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20423       return
20424       end subroutine AFMvel
20425 !---------------------------------------------------------
20426        subroutine AFMforce(Eafmforce)
20427
20428       real(kind=8),dimension(3) :: diffafm
20429 !      real(kind=8) ::afmdist
20430       real(kind=8) :: afmdist,Eafmforce
20431       integer :: i
20432       afmdist=0.0d0
20433       Eafmforce=0.0d0
20434       do i=1,3
20435       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20436       afmdist=afmdist+diffafm(i)**2
20437       enddo
20438       afmdist=dsqrt(afmdist)
20439 !      print *,afmdist,distafminit
20440       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20441       do i=1,3
20442       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20443       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20444       enddo
20445 !C      print *,'AFM',Eafmforce
20446       return
20447       end subroutine AFMforce
20448
20449 !-----------------------------------------------------------------------------
20450 #ifdef WHAM
20451       subroutine read_ssHist
20452 !      implicit none
20453 !      Includes
20454 !      include 'DIMENSIONS'
20455 !      include "DIMENSIONS.FREE"
20456 !      include 'COMMON.FREE'
20457 !     Local variables
20458       integer :: i,j
20459       character(len=80) :: controlcard
20460
20461       do i=1,dyn_nssHist
20462         call card_concat(controlcard,.true.)
20463         read(controlcard,*) &
20464              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20465       enddo
20466
20467       return
20468       end subroutine read_ssHist
20469 #endif
20470 !-----------------------------------------------------------------------------
20471       integer function indmat(i,j)
20472 !el
20473 ! get the position of the jth ijth fragment of the chain coordinate system
20474 ! in the fromto array.
20475         integer :: i,j
20476
20477         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20478       return
20479       end function indmat
20480 !-----------------------------------------------------------------------------
20481       real(kind=8) function sigm(x)
20482 !el
20483        real(kind=8) :: x
20484         sigm=0.25d0*x
20485       return
20486       end function sigm
20487 !-----------------------------------------------------------------------------
20488 !-----------------------------------------------------------------------------
20489       subroutine alloc_ener_arrays
20490 !EL Allocation of arrays used by module energy
20491       use MD_data, only: mset
20492 !el local variables
20493       integer :: i,j
20494
20495       if(nres.lt.100) then
20496         maxconts=10*nres
20497       elseif(nres.lt.200) then
20498         maxconts=10*nres      ! Max. number of contacts per residue
20499       else
20500         maxconts=10*nres ! (maxconts=maxres/4)
20501       endif
20502       maxcont=12*nres      ! Max. number of SC contacts
20503       maxvar=6*nres      ! Max. number of variables
20504 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20505       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20506 !----------------------
20507 ! arrays in subroutine init_int_table
20508 !el#ifdef MPI
20509 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20510 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20511 !el#endif
20512       allocate(nint_gr(nres))
20513       allocate(nscp_gr(nres))
20514       allocate(ielstart(nres))
20515       allocate(ielend(nres))
20516 !(maxres)
20517       allocate(istart(nres,maxint_gr))
20518       allocate(iend(nres,maxint_gr))
20519 !(maxres,maxint_gr)
20520       allocate(iscpstart(nres,maxint_gr))
20521       allocate(iscpend(nres,maxint_gr))
20522 !(maxres,maxint_gr)
20523       allocate(ielstart_vdw(nres))
20524       allocate(ielend_vdw(nres))
20525 !(maxres)
20526       allocate(nint_gr_nucl(nres))
20527       allocate(nscp_gr_nucl(nres))
20528       allocate(ielstart_nucl(nres))
20529       allocate(ielend_nucl(nres))
20530 !(maxres)
20531       allocate(istart_nucl(nres,maxint_gr))
20532       allocate(iend_nucl(nres,maxint_gr))
20533 !(maxres,maxint_gr)
20534       allocate(iscpstart_nucl(nres,maxint_gr))
20535       allocate(iscpend_nucl(nres,maxint_gr))
20536 !(maxres,maxint_gr)
20537       allocate(ielstart_vdw_nucl(nres))
20538       allocate(ielend_vdw_nucl(nres))
20539
20540       allocate(lentyp(0:nfgtasks-1))
20541 !(0:maxprocs-1)
20542 !----------------------
20543 ! commom.contacts
20544 !      common /contacts/
20545       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20546       allocate(icont(2,maxcont))
20547 !(2,maxcont)
20548 !      common /contacts1/
20549       allocate(num_cont(0:nres+4))
20550 !(maxres)
20551       allocate(jcont(maxconts,nres))
20552 !(maxconts,maxres)
20553       allocate(facont(maxconts,nres))
20554 !(maxconts,maxres)
20555       allocate(gacont(3,maxconts,nres))
20556 !(3,maxconts,maxres)
20557 !      common /contacts_hb/
20558       allocate(gacontp_hb1(3,maxconts,nres))
20559       allocate(gacontp_hb2(3,maxconts,nres))
20560       allocate(gacontp_hb3(3,maxconts,nres))
20561       allocate(gacontm_hb1(3,maxconts,nres))
20562       allocate(gacontm_hb2(3,maxconts,nres))
20563       allocate(gacontm_hb3(3,maxconts,nres))
20564       allocate(gacont_hbr(3,maxconts,nres))
20565       allocate(grij_hb_cont(3,maxconts,nres))
20566 !(3,maxconts,maxres)
20567       allocate(facont_hb(maxconts,nres))
20568
20569       allocate(ees0p(maxconts,nres))
20570       allocate(ees0m(maxconts,nres))
20571       allocate(d_cont(maxconts,nres))
20572       allocate(ees0plist(maxconts,nres))
20573
20574 !(maxconts,maxres)
20575       allocate(num_cont_hb(nres))
20576 !(maxres)
20577       allocate(jcont_hb(maxconts,nres))
20578 !(maxconts,maxres)
20579 !      common /rotat/
20580       allocate(Ug(2,2,nres))
20581       allocate(Ugder(2,2,nres))
20582       allocate(Ug2(2,2,nres))
20583       allocate(Ug2der(2,2,nres))
20584 !(2,2,maxres)
20585       allocate(obrot(2,nres))
20586       allocate(obrot2(2,nres))
20587       allocate(obrot_der(2,nres))
20588       allocate(obrot2_der(2,nres))
20589 !(2,maxres)
20590 !      common /precomp1/
20591       allocate(mu(2,nres))
20592       allocate(muder(2,nres))
20593       allocate(Ub2(2,nres))
20594       Ub2(1,:)=0.0d0
20595       Ub2(2,:)=0.0d0
20596       allocate(Ub2der(2,nres))
20597       allocate(Ctobr(2,nres))
20598       allocate(Ctobrder(2,nres))
20599       allocate(Dtobr2(2,nres))
20600       allocate(Dtobr2der(2,nres))
20601 !(2,maxres)
20602       allocate(EUg(2,2,nres))
20603       allocate(EUgder(2,2,nres))
20604       allocate(CUg(2,2,nres))
20605       allocate(CUgder(2,2,nres))
20606       allocate(DUg(2,2,nres))
20607       allocate(Dugder(2,2,nres))
20608       allocate(DtUg2(2,2,nres))
20609       allocate(DtUg2der(2,2,nres))
20610 !(2,2,maxres)
20611 !      common /precomp2/
20612       allocate(Ug2Db1t(2,nres))
20613       allocate(Ug2Db1tder(2,nres))
20614       allocate(CUgb2(2,nres))
20615       allocate(CUgb2der(2,nres))
20616 !(2,maxres)
20617       allocate(EUgC(2,2,nres))
20618       allocate(EUgCder(2,2,nres))
20619       allocate(EUgD(2,2,nres))
20620       allocate(EUgDder(2,2,nres))
20621       allocate(DtUg2EUg(2,2,nres))
20622       allocate(Ug2DtEUg(2,2,nres))
20623 !(2,2,maxres)
20624       allocate(Ug2DtEUgder(2,2,2,nres))
20625       allocate(DtUg2EUgder(2,2,2,nres))
20626 !(2,2,2,maxres)
20627       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20628       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20629       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20630       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20631
20632       allocate(ctilde(2,2,nres))
20633       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20634       allocate(gtb1(2,nres))
20635       allocate(gtb2(2,nres))
20636       allocate(cc(2,2,nres))
20637       allocate(dd(2,2,nres))
20638       allocate(ee(2,2,nres))
20639       allocate(gtcc(2,2,nres))
20640       allocate(gtdd(2,2,nres))
20641       allocate(gtee(2,2,nres))
20642       allocate(gUb2(2,nres))
20643       allocate(gteUg(2,2,nres))
20644
20645 !      common /rotat_old/
20646       allocate(costab(nres))
20647       allocate(sintab(nres))
20648       allocate(costab2(nres))
20649       allocate(sintab2(nres))
20650 !(maxres)
20651 !      common /dipmat/
20652       allocate(a_chuj(2,2,maxconts,nres))
20653 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20654       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20655 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20656 !      common /contdistrib/
20657       allocate(ncont_sent(nres))
20658       allocate(ncont_recv(nres))
20659
20660       allocate(iat_sent(nres))
20661 !(maxres)
20662       allocate(iint_sent(4,nres,nres))
20663       allocate(iint_sent_local(4,nres,nres))
20664 !(4,maxres,maxres)
20665       allocate(iturn3_sent(4,0:nres+4))
20666       allocate(iturn4_sent(4,0:nres+4))
20667       allocate(iturn3_sent_local(4,nres))
20668       allocate(iturn4_sent_local(4,nres))
20669 !(4,maxres)
20670       allocate(itask_cont_from(0:nfgtasks-1))
20671       allocate(itask_cont_to(0:nfgtasks-1))
20672 !(0:max_fg_procs-1)
20673
20674
20675
20676 !----------------------
20677 ! commom.deriv;
20678 !      common /derivat/
20679       allocate(dcdv(6,maxdim))
20680       allocate(dxdv(6,maxdim))
20681 !(6,maxdim)
20682       allocate(dxds(6,nres))
20683 !(6,maxres)
20684       allocate(gradx(3,-1:nres,0:2))
20685       allocate(gradc(3,-1:nres,0:2))
20686 !(3,maxres,2)
20687       allocate(gvdwx(3,-1:nres))
20688       allocate(gvdwc(3,-1:nres))
20689       allocate(gelc(3,-1:nres))
20690       allocate(gelc_long(3,-1:nres))
20691       allocate(gvdwpp(3,-1:nres))
20692       allocate(gvdwc_scpp(3,-1:nres))
20693       allocate(gradx_scp(3,-1:nres))
20694       allocate(gvdwc_scp(3,-1:nres))
20695       allocate(ghpbx(3,-1:nres))
20696       allocate(ghpbc(3,-1:nres))
20697       allocate(gradcorr(3,-1:nres))
20698       allocate(gradcorr_long(3,-1:nres))
20699       allocate(gradcorr5_long(3,-1:nres))
20700       allocate(gradcorr6_long(3,-1:nres))
20701       allocate(gcorr6_turn_long(3,-1:nres))
20702       allocate(gradxorr(3,-1:nres))
20703       allocate(gradcorr5(3,-1:nres))
20704       allocate(gradcorr6(3,-1:nres))
20705       allocate(gliptran(3,-1:nres))
20706       allocate(gliptranc(3,-1:nres))
20707       allocate(gliptranx(3,-1:nres))
20708       allocate(gshieldx(3,-1:nres))
20709       allocate(gshieldc(3,-1:nres))
20710       allocate(gshieldc_loc(3,-1:nres))
20711       allocate(gshieldx_ec(3,-1:nres))
20712       allocate(gshieldc_ec(3,-1:nres))
20713       allocate(gshieldc_loc_ec(3,-1:nres))
20714       allocate(gshieldx_t3(3,-1:nres))
20715       allocate(gshieldc_t3(3,-1:nres))
20716       allocate(gshieldc_loc_t3(3,-1:nres))
20717       allocate(gshieldx_t4(3,-1:nres))
20718       allocate(gshieldc_t4(3,-1:nres))
20719       allocate(gshieldc_loc_t4(3,-1:nres))
20720       allocate(gshieldx_ll(3,-1:nres))
20721       allocate(gshieldc_ll(3,-1:nres))
20722       allocate(gshieldc_loc_ll(3,-1:nres))
20723       allocate(grad_shield(3,-1:nres))
20724       allocate(gg_tube_sc(3,-1:nres))
20725       allocate(gg_tube(3,-1:nres))
20726       allocate(gradafm(3,-1:nres))
20727       allocate(gradb_nucl(3,-1:nres))
20728       allocate(gradbx_nucl(3,-1:nres))
20729       allocate(gvdwpsb1(3,-1:nres))
20730       allocate(gelpp(3,-1:nres))
20731       allocate(gvdwpsb(3,-1:nres))
20732       allocate(gelsbc(3,-1:nres))
20733       allocate(gelsbx(3,-1:nres))
20734       allocate(gvdwsbx(3,-1:nres))
20735       allocate(gvdwsbc(3,-1:nres))
20736       allocate(gsbloc(3,-1:nres))
20737       allocate(gsblocx(3,-1:nres))
20738       allocate(gradcorr_nucl(3,-1:nres))
20739       allocate(gradxorr_nucl(3,-1:nres))
20740       allocate(gradcorr3_nucl(3,-1:nres))
20741       allocate(gradxorr3_nucl(3,-1:nres))
20742       allocate(gvdwpp_nucl(3,-1:nres))
20743       allocate(gradpepcat(3,-1:nres))
20744       allocate(gradpepcatx(3,-1:nres))
20745       allocate(gradcatcat(3,-1:nres))
20746 !(3,maxres)
20747       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20748       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20749 ! grad for shielding surroing
20750       allocate(gloc(0:maxvar,0:2))
20751       allocate(gloc_x(0:maxvar,2))
20752 !(maxvar,2)
20753       allocate(gel_loc(3,-1:nres))
20754       allocate(gel_loc_long(3,-1:nres))
20755       allocate(gcorr3_turn(3,-1:nres))
20756       allocate(gcorr4_turn(3,-1:nres))
20757       allocate(gcorr6_turn(3,-1:nres))
20758       allocate(gradb(3,-1:nres))
20759       allocate(gradbx(3,-1:nres))
20760 !(3,maxres)
20761       allocate(gel_loc_loc(maxvar))
20762       allocate(gel_loc_turn3(maxvar))
20763       allocate(gel_loc_turn4(maxvar))
20764       allocate(gel_loc_turn6(maxvar))
20765       allocate(gcorr_loc(maxvar))
20766       allocate(g_corr5_loc(maxvar))
20767       allocate(g_corr6_loc(maxvar))
20768 !(maxvar)
20769       allocate(gsccorc(3,-1:nres))
20770       allocate(gsccorx(3,-1:nres))
20771 !(3,maxres)
20772       allocate(gsccor_loc(-1:nres))
20773 !(maxres)
20774       allocate(gvdwx_scbase(3,-1:nres))
20775       allocate(gvdwc_scbase(3,-1:nres))
20776       allocate(gvdwx_pepbase(3,-1:nres))
20777       allocate(gvdwc_pepbase(3,-1:nres))
20778       allocate(gvdwx_scpho(3,-1:nres))
20779       allocate(gvdwc_scpho(3,-1:nres))
20780       allocate(gvdwc_peppho(3,-1:nres))
20781
20782       allocate(dtheta(3,2,-1:nres))
20783 !(3,2,maxres)
20784       allocate(gscloc(3,-1:nres))
20785       allocate(gsclocx(3,-1:nres))
20786 !(3,maxres)
20787       allocate(dphi(3,3,-1:nres))
20788       allocate(dalpha(3,3,-1:nres))
20789       allocate(domega(3,3,-1:nres))
20790 !(3,3,maxres)
20791 !      common /deriv_scloc/
20792       allocate(dXX_C1tab(3,nres))
20793       allocate(dYY_C1tab(3,nres))
20794       allocate(dZZ_C1tab(3,nres))
20795       allocate(dXX_Ctab(3,nres))
20796       allocate(dYY_Ctab(3,nres))
20797       allocate(dZZ_Ctab(3,nres))
20798       allocate(dXX_XYZtab(3,nres))
20799       allocate(dYY_XYZtab(3,nres))
20800       allocate(dZZ_XYZtab(3,nres))
20801 !(3,maxres)
20802 !      common /mpgrad/
20803       allocate(jgrad_start(nres))
20804       allocate(jgrad_end(nres))
20805 !(maxres)
20806 !----------------------
20807
20808 !      common /indices/
20809       allocate(ibond_displ(0:nfgtasks-1))
20810       allocate(ibond_count(0:nfgtasks-1))
20811       allocate(ithet_displ(0:nfgtasks-1))
20812       allocate(ithet_count(0:nfgtasks-1))
20813       allocate(iphi_displ(0:nfgtasks-1))
20814       allocate(iphi_count(0:nfgtasks-1))
20815       allocate(iphi1_displ(0:nfgtasks-1))
20816       allocate(iphi1_count(0:nfgtasks-1))
20817       allocate(ivec_displ(0:nfgtasks-1))
20818       allocate(ivec_count(0:nfgtasks-1))
20819       allocate(iset_displ(0:nfgtasks-1))
20820       allocate(iset_count(0:nfgtasks-1))
20821       allocate(iint_count(0:nfgtasks-1))
20822       allocate(iint_displ(0:nfgtasks-1))
20823 !(0:max_fg_procs-1)
20824 !----------------------
20825 ! common.MD
20826 !      common /mdgrad/
20827       allocate(gcart(3,-1:nres))
20828       allocate(gxcart(3,-1:nres))
20829 !(3,0:MAXRES)
20830       allocate(gradcag(3,-1:nres))
20831       allocate(gradxag(3,-1:nres))
20832 !(3,MAXRES)
20833 !      common /back_constr/
20834 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20835       allocate(dutheta(nres))
20836       allocate(dugamma(nres))
20837 !(maxres)
20838       allocate(duscdiff(3,nres))
20839       allocate(duscdiffx(3,nres))
20840 !(3,maxres)
20841 !el i io:read_fragments
20842 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20843 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20844 !      common /qmeas/
20845 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20846 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20847       allocate(mset(0:nprocs))  !(maxprocs/20)
20848       mset(:)=0
20849 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20850 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20851       allocate(dUdconst(3,0:nres))
20852       allocate(dUdxconst(3,0:nres))
20853       allocate(dqwol(3,0:nres))
20854       allocate(dxqwol(3,0:nres))
20855 !(3,0:MAXRES)
20856 !----------------------
20857 ! common.sbridge
20858 !      common /sbridge/ in io_common: read_bridge
20859 !el    allocate((:),allocatable :: iss      !(maxss)
20860 !      common /links/  in io_common: read_bridge
20861 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20862 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20863 !      common /dyn_ssbond/
20864 ! and side-chain vectors in theta or phi.
20865       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20866 !(maxres,maxres)
20867 !      do i=1,nres
20868 !        do j=i+1,nres
20869       dyn_ssbond_ij(:,:)=1.0d300
20870 !        enddo
20871 !      enddo
20872
20873 !      if (nss.gt.0) then
20874         allocate(idssb(maxdim),jdssb(maxdim))
20875 !        allocate(newihpb(nss),newjhpb(nss))
20876 !(maxdim)
20877 !      endif
20878       allocate(ishield_list(-1:nres))
20879       allocate(shield_list(maxcontsshi,-1:nres))
20880       allocate(dyn_ss_mask(nres))
20881       allocate(fac_shield(-1:nres))
20882       allocate(enetube(nres*2))
20883       allocate(enecavtube(nres*2))
20884
20885 !(maxres)
20886       dyn_ss_mask(:)=.false.
20887 !----------------------
20888 ! common.sccor
20889 ! Parameters of the SCCOR term
20890 !      common/sccor/
20891 !el in io_conf: parmread
20892 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20893 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20894 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20895 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20896 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20897 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20898 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20899 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20900 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20901 !----------------
20902       allocate(gloc_sc(3,0:2*nres,0:10))
20903 !(3,0:maxres2,10)maxres2=2*maxres
20904       allocate(dcostau(3,3,3,2*nres))
20905       allocate(dsintau(3,3,3,2*nres))
20906       allocate(dtauangle(3,3,3,2*nres))
20907       allocate(dcosomicron(3,3,3,2*nres))
20908       allocate(domicron(3,3,3,2*nres))
20909 !(3,3,3,maxres2)maxres2=2*maxres
20910 !----------------------
20911 ! common.var
20912 !      common /restr/
20913       allocate(varall(maxvar))
20914 !(maxvar)(maxvar=6*maxres)
20915       allocate(mask_theta(nres))
20916       allocate(mask_phi(nres))
20917       allocate(mask_side(nres))
20918 !(maxres)
20919 !----------------------
20920 ! common.vectors
20921 !      common /vectors/
20922       allocate(uy(3,nres))
20923       allocate(uz(3,nres))
20924 !(3,maxres)
20925       allocate(uygrad(3,3,2,nres))
20926       allocate(uzgrad(3,3,2,nres))
20927 !(3,3,2,maxres)
20928
20929       return
20930       end subroutine alloc_ener_arrays
20931 !-----------------------------------------------------------------
20932       subroutine ebond_nucl(estr_nucl)
20933 !c
20934 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20935 !c
20936
20937       real(kind=8),dimension(3) :: u,ud
20938       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20939       real(kind=8) :: estr_nucl,diff
20940       integer :: iti,i,j,k,nbi
20941       estr_nucl=0.0d0
20942 !C      print *,"I enter ebond"
20943       if (energy_dec) &
20944       write (iout,*) "ibondp_start,ibondp_end",&
20945        ibondp_nucl_start,ibondp_nucl_end
20946       do i=ibondp_nucl_start,ibondp_nucl_end
20947         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20948          itype(i,2).eq.ntyp1_molec(2)) cycle
20949 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20950 !          do j=1,3
20951 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20952 !     &      *dc(j,i-1)/vbld(i)
20953 !          enddo
20954 !          if (energy_dec) write(iout,*)
20955 !     &       "estr1",i,vbld(i),distchainmax,
20956 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20957
20958           diff = vbld(i)-vbldp0_nucl
20959           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20960           vbldp0_nucl,diff,AKP_nucl*diff*diff
20961           estr_nucl=estr_nucl+diff*diff
20962 !          print *,estr_nucl
20963           do j=1,3
20964             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20965           enddo
20966 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20967       enddo
20968       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20969 !      print *,"partial sum", estr_nucl,AKP_nucl
20970
20971       if (energy_dec) &
20972       write (iout,*) "ibondp_start,ibondp_end",&
20973        ibond_nucl_start,ibond_nucl_end
20974
20975       do i=ibond_nucl_start,ibond_nucl_end
20976 !C        print *, "I am stuck",i
20977         iti=itype(i,2)
20978         if (iti.eq.ntyp1_molec(2)) cycle
20979           nbi=nbondterm_nucl(iti)
20980 !C        print *,iti,nbi
20981           if (nbi.eq.1) then
20982             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20983
20984             if (energy_dec) &
20985            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20986            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20987             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20988 !            print *,estr_nucl
20989             do j=1,3
20990               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20991             enddo
20992           else
20993             do j=1,nbi
20994               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20995               ud(j)=aksc_nucl(j,iti)*diff
20996               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20997             enddo
20998             uprod=u(1)
20999             do j=2,nbi
21000               uprod=uprod*u(j)
21001             enddo
21002             usum=0.0d0
21003             usumsqder=0.0d0
21004             do j=1,nbi
21005               uprod1=1.0d0
21006               uprod2=1.0d0
21007               do k=1,nbi
21008                 if (k.ne.j) then
21009                   uprod1=uprod1*u(k)
21010                   uprod2=uprod2*u(k)*u(k)
21011                 endif
21012               enddo
21013               usum=usum+uprod1
21014               usumsqder=usumsqder+ud(j)*uprod2
21015             enddo
21016             estr_nucl=estr_nucl+uprod/usum
21017             do j=1,3
21018              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21019             enddo
21020         endif
21021       enddo
21022 !C      print *,"I am about to leave ebond"
21023       return
21024       end subroutine ebond_nucl
21025
21026 !-----------------------------------------------------------------------------
21027       subroutine ebend_nucl(etheta_nucl)
21028       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21029       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21030       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21031       logical :: lprn=.false., lprn1=.false.
21032 !el local variables
21033       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21034       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21035       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21036 ! local variables for constrains
21037       real(kind=8) :: difi,thetiii
21038        integer itheta
21039       etheta_nucl=0.0D0
21040 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21041       do i=ithet_nucl_start,ithet_nucl_end
21042         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21043         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21044         (itype(i,2).eq.ntyp1_molec(2))) cycle
21045         dethetai=0.0d0
21046         dephii=0.0d0
21047         dephii1=0.0d0
21048         theti2=0.5d0*theta(i)
21049         ityp2=ithetyp_nucl(itype(i-1,2))
21050         do k=1,nntheterm_nucl
21051           coskt(k)=dcos(k*theti2)
21052           sinkt(k)=dsin(k*theti2)
21053         enddo
21054         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21055 #ifdef OSF
21056           phii=phi(i)
21057           if (phii.ne.phii) phii=150.0
21058 #else
21059           phii=phi(i)
21060 #endif
21061           ityp1=ithetyp_nucl(itype(i-2,2))
21062           do k=1,nsingle_nucl
21063             cosph1(k)=dcos(k*phii)
21064             sinph1(k)=dsin(k*phii)
21065           enddo
21066         else
21067           phii=0.0d0
21068           ityp1=nthetyp_nucl+1
21069           do k=1,nsingle_nucl
21070             cosph1(k)=0.0d0
21071             sinph1(k)=0.0d0
21072           enddo
21073         endif
21074
21075         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21076 #ifdef OSF
21077           phii1=phi(i+1)
21078           if (phii1.ne.phii1) phii1=150.0
21079           phii1=pinorm(phii1)
21080 #else
21081           phii1=phi(i+1)
21082 #endif
21083           ityp3=ithetyp_nucl(itype(i,2))
21084           do k=1,nsingle_nucl
21085             cosph2(k)=dcos(k*phii1)
21086             sinph2(k)=dsin(k*phii1)
21087           enddo
21088         else
21089           phii1=0.0d0
21090           ityp3=nthetyp_nucl+1
21091           do k=1,nsingle_nucl
21092             cosph2(k)=0.0d0
21093             sinph2(k)=0.0d0
21094           enddo
21095         endif
21096         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21097         do k=1,ndouble_nucl
21098           do l=1,k-1
21099             ccl=cosph1(l)*cosph2(k-l)
21100             ssl=sinph1(l)*sinph2(k-l)
21101             scl=sinph1(l)*cosph2(k-l)
21102             csl=cosph1(l)*sinph2(k-l)
21103             cosph1ph2(l,k)=ccl-ssl
21104             cosph1ph2(k,l)=ccl+ssl
21105             sinph1ph2(l,k)=scl+csl
21106             sinph1ph2(k,l)=scl-csl
21107           enddo
21108         enddo
21109         if (lprn) then
21110         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21111          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21112         write (iout,*) "coskt and sinkt",nntheterm_nucl
21113         do k=1,nntheterm_nucl
21114           write (iout,*) k,coskt(k),sinkt(k)
21115         enddo
21116         endif
21117         do k=1,ntheterm_nucl
21118           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21119           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21120            *coskt(k)
21121           if (lprn)&
21122          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21123           " ethetai",ethetai
21124         enddo
21125         if (lprn) then
21126         write (iout,*) "cosph and sinph"
21127         do k=1,nsingle_nucl
21128           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21129         enddo
21130         write (iout,*) "cosph1ph2 and sinph2ph2"
21131         do k=2,ndouble_nucl
21132           do l=1,k-1
21133             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21134               sinph1ph2(l,k),sinph1ph2(k,l)
21135           enddo
21136         enddo
21137         write(iout,*) "ethetai",ethetai
21138         endif
21139         do m=1,ntheterm2_nucl
21140           do k=1,nsingle_nucl
21141             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21142               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21143               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21144               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21145             ethetai=ethetai+sinkt(m)*aux
21146             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21147             dephii=dephii+k*sinkt(m)*(&
21148                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21149                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21150             dephii1=dephii1+k*sinkt(m)*(&
21151                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21152                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21153             if (lprn) &
21154            write (iout,*) "m",m," k",k," bbthet",&
21155               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21156               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21157               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21158               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21159           enddo
21160         enddo
21161         if (lprn) &
21162         write(iout,*) "ethetai",ethetai
21163         do m=1,ntheterm3_nucl
21164           do k=2,ndouble_nucl
21165             do l=1,k-1
21166               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21167                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21168                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21169                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21170               ethetai=ethetai+sinkt(m)*aux
21171               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21172               dephii=dephii+l*sinkt(m)*(&
21173                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21174                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21175                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21176                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21177               dephii1=dephii1+(k-l)*sinkt(m)*( &
21178                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21179                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21180                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21181                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21182               if (lprn) then
21183               write (iout,*) "m",m," k",k," l",l," ffthet", &
21184                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21185                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21186                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21187                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21188               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21189                  cosph1ph2(k,l)*sinkt(m),&
21190                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21191               endif
21192             enddo
21193           enddo
21194         enddo
21195 10      continue
21196         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21197         i,theta(i)*rad2deg,phii*rad2deg, &
21198         phii1*rad2deg,ethetai
21199         etheta_nucl=etheta_nucl+ethetai
21200 !        print *,i,"partial sum",etheta_nucl
21201         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21202         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21203         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21204       enddo
21205       return
21206       end subroutine ebend_nucl
21207 !----------------------------------------------------
21208       subroutine etor_nucl(etors_nucl)
21209 !      implicit real*8 (a-h,o-z)
21210 !      include 'DIMENSIONS'
21211 !      include 'COMMON.VAR'
21212 !      include 'COMMON.GEO'
21213 !      include 'COMMON.LOCAL'
21214 !      include 'COMMON.TORSION'
21215 !      include 'COMMON.INTERACT'
21216 !      include 'COMMON.DERIV'
21217 !      include 'COMMON.CHAIN'
21218 !      include 'COMMON.NAMES'
21219 !      include 'COMMON.IOUNITS'
21220 !      include 'COMMON.FFIELD'
21221 !      include 'COMMON.TORCNSTR'
21222 !      include 'COMMON.CONTROL'
21223       real(kind=8) :: etors_nucl,edihcnstr
21224       logical :: lprn
21225 !el local variables
21226       integer :: i,j,iblock,itori,itori1
21227       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21228                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21229 ! Set lprn=.true. for debugging
21230       lprn=.false.
21231 !     lprn=.true.
21232       etors_nucl=0.0D0
21233 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21234       do i=iphi_nucl_start,iphi_nucl_end
21235         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21236              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21237              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21238         etors_ii=0.0D0
21239         itori=itortyp_nucl(itype(i-2,2))
21240         itori1=itortyp_nucl(itype(i-1,2))
21241         phii=phi(i)
21242 !         print *,i,itori,itori1
21243         gloci=0.0D0
21244 !C Regular cosine and sine terms
21245         do j=1,nterm_nucl(itori,itori1)
21246           v1ij=v1_nucl(j,itori,itori1)
21247           v2ij=v2_nucl(j,itori,itori1)
21248           cosphi=dcos(j*phii)
21249           sinphi=dsin(j*phii)
21250           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21251           if (energy_dec) etors_ii=etors_ii+&
21252                      v1ij*cosphi+v2ij*sinphi
21253           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21254         enddo
21255 !C Lorentz terms
21256 !C                         v1
21257 !C  E = SUM ----------------------------------- - v1
21258 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21259 !C
21260         cosphi=dcos(0.5d0*phii)
21261         sinphi=dsin(0.5d0*phii)
21262         do j=1,nlor_nucl(itori,itori1)
21263           vl1ij=vlor1_nucl(j,itori,itori1)
21264           vl2ij=vlor2_nucl(j,itori,itori1)
21265           vl3ij=vlor3_nucl(j,itori,itori1)
21266           pom=vl2ij*cosphi+vl3ij*sinphi
21267           pom1=1.0d0/(pom*pom+1.0d0)
21268           etors_nucl=etors_nucl+vl1ij*pom1
21269           if (energy_dec) etors_ii=etors_ii+ &
21270                      vl1ij*pom1
21271           pom=-pom*pom1*pom1
21272           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21273         enddo
21274 !C Subtract the constant term
21275         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21276           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21277               'etor',i,etors_ii-v0_nucl(itori,itori1)
21278         if (lprn) &
21279        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21280        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21281        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21282         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21283 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21284       enddo
21285       return
21286       end subroutine etor_nucl
21287 !------------------------------------------------------------
21288       subroutine epp_nucl_sub(evdw1,ees)
21289 !C
21290 !C This subroutine calculates the average interaction energy and its gradient
21291 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21292 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21293 !C The potential depends both on the distance of peptide-group centers and on
21294 !C the orientation of the CA-CA virtual bonds.
21295 !C
21296       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21297       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21298       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21299                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21300                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21301       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21302                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21303       integer xshift,yshift,zshift
21304       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21305       real(kind=8) :: ees,eesij
21306 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21307       real(kind=8) scal_el /0.5d0/
21308       t_eelecij=0.0d0
21309       ees=0.0D0
21310       evdw1=0.0D0
21311       ind=0
21312 !c
21313 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21314 !c
21315 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21316       do i=iatel_s_nucl,iatel_e_nucl
21317         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21318         dxi=dc(1,i)
21319         dyi=dc(2,i)
21320         dzi=dc(3,i)
21321         dx_normi=dc_norm(1,i)
21322         dy_normi=dc_norm(2,i)
21323         dz_normi=dc_norm(3,i)
21324         xmedi=c(1,i)+0.5d0*dxi
21325         ymedi=c(2,i)+0.5d0*dyi
21326         zmedi=c(3,i)+0.5d0*dzi
21327           xmedi=dmod(xmedi,boxxsize)
21328           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21329           ymedi=dmod(ymedi,boxysize)
21330           if (ymedi.lt.0) ymedi=ymedi+boxysize
21331           zmedi=dmod(zmedi,boxzsize)
21332           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21333
21334         do j=ielstart_nucl(i),ielend_nucl(i)
21335           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21336           ind=ind+1
21337           dxj=dc(1,j)
21338           dyj=dc(2,j)
21339           dzj=dc(3,j)
21340 !          xj=c(1,j)+0.5D0*dxj-xmedi
21341 !          yj=c(2,j)+0.5D0*dyj-ymedi
21342 !          zj=c(3,j)+0.5D0*dzj-zmedi
21343           xj=c(1,j)+0.5D0*dxj
21344           yj=c(2,j)+0.5D0*dyj
21345           zj=c(3,j)+0.5D0*dzj
21346           xj=mod(xj,boxxsize)
21347           if (xj.lt.0) xj=xj+boxxsize
21348           yj=mod(yj,boxysize)
21349           if (yj.lt.0) yj=yj+boxysize
21350           zj=mod(zj,boxzsize)
21351           if (zj.lt.0) zj=zj+boxzsize
21352       isubchap=0
21353       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21354       xj_safe=xj
21355       yj_safe=yj
21356       zj_safe=zj
21357       do xshift=-1,1
21358       do yshift=-1,1
21359       do zshift=-1,1
21360           xj=xj_safe+xshift*boxxsize
21361           yj=yj_safe+yshift*boxysize
21362           zj=zj_safe+zshift*boxzsize
21363           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21364           if(dist_temp.lt.dist_init) then
21365             dist_init=dist_temp
21366             xj_temp=xj
21367             yj_temp=yj
21368             zj_temp=zj
21369             isubchap=1
21370           endif
21371        enddo
21372        enddo
21373        enddo
21374        if (isubchap.eq.1) then
21375 !C          print *,i,j
21376           xj=xj_temp-xmedi
21377           yj=yj_temp-ymedi
21378           zj=zj_temp-zmedi
21379        else
21380           xj=xj_safe-xmedi
21381           yj=yj_safe-ymedi
21382           zj=zj_safe-zmedi
21383        endif
21384
21385           rij=xj*xj+yj*yj+zj*zj
21386 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21387           fac=(r0pp**2/rij)**3
21388           ev1=epspp*fac*fac
21389           ev2=epspp*fac
21390           evdw1ij=ev1-2*ev2
21391           fac=(-ev1-evdw1ij)/rij
21392 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21393           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21394           evdw1=evdw1+evdw1ij
21395 !C
21396 !C Calculate contributions to the Cartesian gradient.
21397 !C
21398           ggg(1)=fac*xj
21399           ggg(2)=fac*yj
21400           ggg(3)=fac*zj
21401           do k=1,3
21402             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21403             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21404           enddo
21405 !c phoshate-phosphate electrostatic interactions
21406           rij=dsqrt(rij)
21407           fac=1.0d0/rij
21408           eesij=dexp(-BEES*rij)*fac
21409 !          write (2,*)"fac",fac," eesijpp",eesij
21410           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21411           ees=ees+eesij
21412 !c          fac=-eesij*fac
21413           fac=-(fac+BEES)*eesij*fac
21414           ggg(1)=fac*xj
21415           ggg(2)=fac*yj
21416           ggg(3)=fac*zj
21417 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21418 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21419 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21420           do k=1,3
21421             gelpp(k,i)=gelpp(k,i)-ggg(k)
21422             gelpp(k,j)=gelpp(k,j)+ggg(k)
21423           enddo
21424         enddo ! j
21425       enddo   ! i
21426 !c      ees=332.0d0*ees
21427       ees=AEES*ees
21428       do i=nnt,nct
21429 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21430         do k=1,3
21431           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21432 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21433           gelpp(k,i)=AEES*gelpp(k,i)
21434         enddo
21435 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21436       enddo
21437 !c      write (2,*) "total EES",ees
21438       return
21439       end subroutine epp_nucl_sub
21440 !---------------------------------------------------------------------
21441       subroutine epsb(evdwpsb,eelpsb)
21442 !      use comm_locel
21443 !C
21444 !C This subroutine calculates the excluded-volume interaction energy between
21445 !C peptide-group centers and side chains and its gradient in virtual-bond and
21446 !C side-chain vectors.
21447 !C
21448       real(kind=8),dimension(3):: ggg
21449       integer :: i,iint,j,k,iteli,itypj,subchap
21450       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21451                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21452       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21453                     dist_temp, dist_init
21454       integer xshift,yshift,zshift
21455
21456 !cd    print '(a)','Enter ESCP'
21457 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21458       eelpsb=0.0d0
21459       evdwpsb=0.0d0
21460 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21461       do i=iatscp_s_nucl,iatscp_e_nucl
21462         if (itype(i,2).eq.ntyp1_molec(2) &
21463          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21464         xi=0.5D0*(c(1,i)+c(1,i+1))
21465         yi=0.5D0*(c(2,i)+c(2,i+1))
21466         zi=0.5D0*(c(3,i)+c(3,i+1))
21467           xi=mod(xi,boxxsize)
21468           if (xi.lt.0) xi=xi+boxxsize
21469           yi=mod(yi,boxysize)
21470           if (yi.lt.0) yi=yi+boxysize
21471           zi=mod(zi,boxzsize)
21472           if (zi.lt.0) zi=zi+boxzsize
21473
21474         do iint=1,nscp_gr_nucl(i)
21475
21476         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21477           itypj=itype(j,2)
21478           if (itypj.eq.ntyp1_molec(2)) cycle
21479 !C Uncomment following three lines for SC-p interactions
21480 !c         xj=c(1,nres+j)-xi
21481 !c         yj=c(2,nres+j)-yi
21482 !c         zj=c(3,nres+j)-zi
21483 !C Uncomment following three lines for Ca-p interactions
21484 !          xj=c(1,j)-xi
21485 !          yj=c(2,j)-yi
21486 !          zj=c(3,j)-zi
21487           xj=c(1,j)
21488           yj=c(2,j)
21489           zj=c(3,j)
21490           xj=mod(xj,boxxsize)
21491           if (xj.lt.0) xj=xj+boxxsize
21492           yj=mod(yj,boxysize)
21493           if (yj.lt.0) yj=yj+boxysize
21494           zj=mod(zj,boxzsize)
21495           if (zj.lt.0) zj=zj+boxzsize
21496       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21497       xj_safe=xj
21498       yj_safe=yj
21499       zj_safe=zj
21500       subchap=0
21501       do xshift=-1,1
21502       do yshift=-1,1
21503       do zshift=-1,1
21504           xj=xj_safe+xshift*boxxsize
21505           yj=yj_safe+yshift*boxysize
21506           zj=zj_safe+zshift*boxzsize
21507           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21508           if(dist_temp.lt.dist_init) then
21509             dist_init=dist_temp
21510             xj_temp=xj
21511             yj_temp=yj
21512             zj_temp=zj
21513             subchap=1
21514           endif
21515        enddo
21516        enddo
21517        enddo
21518        if (subchap.eq.1) then
21519           xj=xj_temp-xi
21520           yj=yj_temp-yi
21521           zj=zj_temp-zi
21522        else
21523           xj=xj_safe-xi
21524           yj=yj_safe-yi
21525           zj=zj_safe-zi
21526        endif
21527
21528           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21529           fac=rrij**expon2
21530           e1=fac*fac*aad_nucl(itypj)
21531           e2=fac*bad_nucl(itypj)
21532           if (iabs(j-i) .le. 2) then
21533             e1=scal14*e1
21534             e2=scal14*e2
21535           endif
21536           evdwij=e1+e2
21537           evdwpsb=evdwpsb+evdwij
21538           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21539              'evdw2',i,j,evdwij,"tu4"
21540 !C
21541 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21542 !C
21543           fac=-(evdwij+e1)*rrij
21544           ggg(1)=xj*fac
21545           ggg(2)=yj*fac
21546           ggg(3)=zj*fac
21547           do k=1,3
21548             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21549             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21550           enddo
21551         enddo
21552
21553         enddo ! iint
21554       enddo ! i
21555       do i=1,nct
21556         do j=1,3
21557           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21558           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21559         enddo
21560       enddo
21561       return
21562       end subroutine epsb
21563
21564 !------------------------------------------------------
21565       subroutine esb_gb(evdwsb,eelsb)
21566       use comm_locel
21567       use calc_data_nucl
21568       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21569       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21570       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21571       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21572                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21573       integer :: ii
21574       logical lprn
21575       evdw=0.0D0
21576       eelsb=0.0d0
21577       ecorr=0.0d0
21578       evdwsb=0.0D0
21579       lprn=.false.
21580       ind=0
21581 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21582       do i=iatsc_s_nucl,iatsc_e_nucl
21583         num_conti=0
21584         num_conti2=0
21585         itypi=itype(i,2)
21586 !        PRINT *,"I=",i,itypi
21587         if (itypi.eq.ntyp1_molec(2)) cycle
21588         itypi1=itype(i+1,2)
21589         xi=c(1,nres+i)
21590         yi=c(2,nres+i)
21591         zi=c(3,nres+i)
21592           xi=dmod(xi,boxxsize)
21593           if (xi.lt.0) xi=xi+boxxsize
21594           yi=dmod(yi,boxysize)
21595           if (yi.lt.0) yi=yi+boxysize
21596           zi=dmod(zi,boxzsize)
21597           if (zi.lt.0) zi=zi+boxzsize
21598
21599         dxi=dc_norm(1,nres+i)
21600         dyi=dc_norm(2,nres+i)
21601         dzi=dc_norm(3,nres+i)
21602         dsci_inv=vbld_inv(i+nres)
21603 !C
21604 !C Calculate SC interaction energy.
21605 !C
21606         do iint=1,nint_gr_nucl(i)
21607 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21608           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21609             ind=ind+1
21610 !            print *,"JESTEM"
21611             itypj=itype(j,2)
21612             if (itypj.eq.ntyp1_molec(2)) cycle
21613             dscj_inv=vbld_inv(j+nres)
21614             sig0ij=sigma_nucl(itypi,itypj)
21615             chi1=chi_nucl(itypi,itypj)
21616             chi2=chi_nucl(itypj,itypi)
21617             chi12=chi1*chi2
21618             chip1=chip_nucl(itypi,itypj)
21619             chip2=chip_nucl(itypj,itypi)
21620             chip12=chip1*chip2
21621 !            xj=c(1,nres+j)-xi
21622 !            yj=c(2,nres+j)-yi
21623 !            zj=c(3,nres+j)-zi
21624            xj=c(1,nres+j)
21625            yj=c(2,nres+j)
21626            zj=c(3,nres+j)
21627           xj=dmod(xj,boxxsize)
21628           if (xj.lt.0) xj=xj+boxxsize
21629           yj=dmod(yj,boxysize)
21630           if (yj.lt.0) yj=yj+boxysize
21631           zj=dmod(zj,boxzsize)
21632           if (zj.lt.0) zj=zj+boxzsize
21633       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21634       xj_safe=xj
21635       yj_safe=yj
21636       zj_safe=zj
21637       subchap=0
21638       do xshift=-1,1
21639       do yshift=-1,1
21640       do zshift=-1,1
21641           xj=xj_safe+xshift*boxxsize
21642           yj=yj_safe+yshift*boxysize
21643           zj=zj_safe+zshift*boxzsize
21644           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21645           if(dist_temp.lt.dist_init) then
21646             dist_init=dist_temp
21647             xj_temp=xj
21648             yj_temp=yj
21649             zj_temp=zj
21650             subchap=1
21651           endif
21652        enddo
21653        enddo
21654        enddo
21655        if (subchap.eq.1) then
21656           xj=xj_temp-xi
21657           yj=yj_temp-yi
21658           zj=zj_temp-zi
21659        else
21660           xj=xj_safe-xi
21661           yj=yj_safe-yi
21662           zj=zj_safe-zi
21663        endif
21664
21665             dxj=dc_norm(1,nres+j)
21666             dyj=dc_norm(2,nres+j)
21667             dzj=dc_norm(3,nres+j)
21668             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21669             rij=dsqrt(rrij)
21670 !C Calculate angle-dependent terms of energy and contributions to their
21671 !C derivatives.
21672             erij(1)=xj*rij
21673             erij(2)=yj*rij
21674             erij(3)=zj*rij
21675             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21676             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21677             om12=dxi*dxj+dyi*dyj+dzi*dzj
21678             call sc_angular_nucl
21679             sigsq=1.0D0/sigsq
21680             sig=sig0ij*dsqrt(sigsq)
21681             rij_shift=1.0D0/rij-sig+sig0ij
21682 !            print *,rij_shift,"rij_shift"
21683 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21684 !c     &       " rij_shift",rij_shift
21685             if (rij_shift.le.0.0D0) then
21686               evdw=1.0D20
21687               return
21688             endif
21689             sigder=-sig*sigsq
21690 !c---------------------------------------------------------------
21691             rij_shift=1.0D0/rij_shift
21692             fac=rij_shift**expon
21693             e1=fac*fac*aa_nucl(itypi,itypj)
21694             e2=fac*bb_nucl(itypi,itypj)
21695             evdwij=eps1*eps2rt*(e1+e2)
21696 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21697 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21698             eps2der=evdwij
21699             evdwij=evdwij*eps2rt
21700             evdwsb=evdwsb+evdwij
21701             if (lprn) then
21702             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21703             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21704             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21705              restyp(itypi,2),i,restyp(itypj,2),j, &
21706              epsi,sigm,chi1,chi2,chip1,chip2, &
21707              eps1,eps2rt**2,sig,sig0ij, &
21708              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21709             evdwij
21710             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21711             endif
21712
21713             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21714                              'evdw',i,j,evdwij,"tu3"
21715
21716
21717 !C Calculate gradient components.
21718             e1=e1*eps1*eps2rt**2
21719             fac=-expon*(e1+evdwij)*rij_shift
21720             sigder=fac*sigder
21721             fac=rij*fac
21722 !c            fac=0.0d0
21723 !C Calculate the radial part of the gradient
21724             gg(1)=xj*fac
21725             gg(2)=yj*fac
21726             gg(3)=zj*fac
21727 !C Calculate angular part of the gradient.
21728             call sc_grad_nucl
21729             call eelsbij(eelij,num_conti2)
21730             if (energy_dec .and. &
21731            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21732           write (istat,'(e14.5)') evdwij
21733             eelsb=eelsb+eelij
21734           enddo      ! j
21735         enddo        ! iint
21736         num_cont_hb(i)=num_conti2
21737       enddo          ! i
21738 !c      write (iout,*) "Number of loop steps in EGB:",ind
21739 !cccc      energy_dec=.false.
21740       return
21741       end subroutine esb_gb
21742 !-------------------------------------------------------------------------------
21743       subroutine eelsbij(eesij,num_conti2)
21744       use comm_locel
21745       use calc_data_nucl
21746       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21747       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21748       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21749                     dist_temp, dist_init,rlocshield,fracinbuf
21750       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21751
21752 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21753       real(kind=8) scal_el /0.5d0/
21754       integer :: iteli,itelj,kkk,kkll,m,isubchap
21755       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21756       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21757       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21758                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21759                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21760                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21761                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21762                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21763                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21764                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21765       ind=ind+1
21766       itypi=itype(i,2)
21767       itypj=itype(j,2)
21768 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21769       ael6i=ael6_nucl(itypi,itypj)
21770       ael3i=ael3_nucl(itypi,itypj)
21771       ael63i=ael63_nucl(itypi,itypj)
21772       ael32i=ael32_nucl(itypi,itypj)
21773 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21774 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21775       dxj=dc(1,j+nres)
21776       dyj=dc(2,j+nres)
21777       dzj=dc(3,j+nres)
21778       dx_normi=dc_norm(1,i+nres)
21779       dy_normi=dc_norm(2,i+nres)
21780       dz_normi=dc_norm(3,i+nres)
21781       dx_normj=dc_norm(1,j+nres)
21782       dy_normj=dc_norm(2,j+nres)
21783       dz_normj=dc_norm(3,j+nres)
21784 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21785 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21786 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21787       if (ipot_nucl.ne.2) then
21788         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21789         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21790         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21791       else
21792         cosa=om12
21793         cosb=om1
21794         cosg=om2
21795       endif
21796       r3ij=rij*rrij
21797       r6ij=r3ij*r3ij
21798       fac=cosa-3.0D0*cosb*cosg
21799       facfac=fac*fac
21800       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21801       fac3=ael6i*r6ij
21802       fac4=ael3i*r3ij
21803       fac5=ael63i*r6ij
21804       fac6=ael32i*r6ij
21805 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21806 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21807       el1=fac3*(4.0D0+facfac-fac1)
21808       el2=fac4*fac
21809       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21810       el4=fac6*facfac
21811       eesij=el1+el2+el3+el4
21812 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21813       ees0ij=4.0D0+facfac-fac1
21814
21815       if (energy_dec) then
21816           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21817           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21818            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21819            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21820            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21821           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21822       endif
21823
21824 !C
21825 !C Calculate contributions to the Cartesian gradient.
21826 !C
21827       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21828       fac1=fac
21829 !c      erij(1)=xj*rmij
21830 !c      erij(2)=yj*rmij
21831 !c      erij(3)=zj*rmij
21832 !*
21833 !* Radial derivatives. First process both termini of the fragment (i,j)
21834 !*
21835       ggg(1)=facel*xj
21836       ggg(2)=facel*yj
21837       ggg(3)=facel*zj
21838       do k=1,3
21839         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21840         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21841         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21842         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21843       enddo
21844 !*
21845 !* Angular part
21846 !*
21847       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21848       fac4=-3.0D0*fac4
21849       fac3=-6.0D0*fac3
21850       fac5= 6.0d0*fac5
21851       fac6=-6.0d0*fac6
21852       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21853        fac6*fac1*cosg
21854       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21855        fac6*fac1*cosb
21856       do k=1,3
21857         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21858         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21859       enddo
21860       do k=1,3
21861         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21862       enddo
21863       do k=1,3
21864         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21865              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21866              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21867         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21868              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21869              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21870         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21871         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21872       enddo
21873 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21874        IF ( j.gt.i+1 .and.&
21875           num_conti.le.maxcont) THEN
21876 !C
21877 !C Calculate the contact function. The ith column of the array JCONT will
21878 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21879 !C greater than I). The arrays FACONT and GACONT will contain the values of
21880 !C the contact function and its derivative.
21881         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21882 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21883         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21884 !c        write (2,*) "fcont",fcont
21885         if (fcont.gt.0.0D0) then
21886           num_conti=num_conti+1
21887           num_conti2=num_conti2+1
21888
21889           if (num_conti.gt.maxconts) then
21890             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21891                           ' will skip next contacts for this conf.',maxconts
21892           else
21893             jcont_hb(num_conti,i)=j
21894 !c            write (iout,*) "num_conti",num_conti,
21895 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21896 !C Calculate contact energies
21897             cosa4=4.0D0*cosa
21898             wij=cosa-3.0D0*cosb*cosg
21899             cosbg1=cosb+cosg
21900             cosbg2=cosb-cosg
21901             fac3=dsqrt(-ael6i)*r3ij
21902 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21903             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21904             if (ees0tmp.gt.0) then
21905               ees0pij=dsqrt(ees0tmp)
21906             else
21907               ees0pij=0
21908             endif
21909             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21910             if (ees0tmp.gt.0) then
21911               ees0mij=dsqrt(ees0tmp)
21912             else
21913               ees0mij=0
21914             endif
21915             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21916             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21917 !c            write (iout,*) "i",i," j",j,
21918 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21919             ees0pij1=fac3/ees0pij
21920             ees0mij1=fac3/ees0mij
21921             fac3p=-3.0D0*fac3*rrij
21922             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21923             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21924             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21925             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21926             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21927             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21928             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21929             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21930             ecosap=ecosa1+ecosa2
21931             ecosbp=ecosb1+ecosb2
21932             ecosgp=ecosg1+ecosg2
21933             ecosam=ecosa1-ecosa2
21934             ecosbm=ecosb1-ecosb2
21935             ecosgm=ecosg1-ecosg2
21936 !C End diagnostics
21937             facont_hb(num_conti,i)=fcont
21938             fprimcont=fprimcont/rij
21939             do k=1,3
21940               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21941               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21942             enddo
21943             gggp(1)=gggp(1)+ees0pijp*xj
21944             gggp(2)=gggp(2)+ees0pijp*yj
21945             gggp(3)=gggp(3)+ees0pijp*zj
21946             gggm(1)=gggm(1)+ees0mijp*xj
21947             gggm(2)=gggm(2)+ees0mijp*yj
21948             gggm(3)=gggm(3)+ees0mijp*zj
21949 !C Derivatives due to the contact function
21950             gacont_hbr(1,num_conti,i)=fprimcont*xj
21951             gacont_hbr(2,num_conti,i)=fprimcont*yj
21952             gacont_hbr(3,num_conti,i)=fprimcont*zj
21953             do k=1,3
21954 !c
21955 !c Gradient of the correlation terms
21956 !c
21957               gacontp_hb1(k,num_conti,i)= &
21958              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21959             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21960               gacontp_hb2(k,num_conti,i)= &
21961              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21962             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21963               gacontp_hb3(k,num_conti,i)=gggp(k)
21964               gacontm_hb1(k,num_conti,i)= &
21965              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21966             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21967               gacontm_hb2(k,num_conti,i)= &
21968              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21969             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21970               gacontm_hb3(k,num_conti,i)=gggm(k)
21971             enddo
21972           endif
21973         endif
21974       ENDIF
21975       return
21976       end subroutine eelsbij
21977 !------------------------------------------------------------------
21978       subroutine sc_grad_nucl
21979       use comm_locel
21980       use calc_data_nucl
21981       real(kind=8),dimension(3) :: dcosom1,dcosom2
21982       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21983       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21984       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21985       do k=1,3
21986         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21987         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21988       enddo
21989       do k=1,3
21990         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21991       enddo
21992       do k=1,3
21993         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21994                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21995                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21996         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21997                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21998                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21999       enddo
22000 !C
22001 !C Calculate the components of the gradient in DC and X
22002 !C
22003       do l=1,3
22004         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22005         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22006       enddo
22007       return
22008       end subroutine sc_grad_nucl
22009 !-----------------------------------------------------------------------
22010       subroutine esb(esbloc)
22011 !C Calculate the local energy of a side chain and its derivatives in the
22012 !C corresponding virtual-bond valence angles THETA and the spherical angles
22013 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22014 !C added by Urszula Kozlowska. 07/11/2007
22015 !C
22016       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22017       real(kind=8),dimension(9):: x
22018      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22019       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22020       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22021       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22022        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22023        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22024        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22025        integer::it,nlobit,i,j,k
22026 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22027       delta=0.02d0*pi
22028       esbloc=0.0D0
22029       do i=loc_start_nucl,loc_end_nucl
22030         if (itype(i,2).eq.ntyp1_molec(2)) cycle
22031         costtab(i+1) =dcos(theta(i+1))
22032         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22033         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22034         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22035         cosfac2=0.5d0/(1.0d0+costtab(i+1))
22036         cosfac=dsqrt(cosfac2)
22037         sinfac2=0.5d0/(1.0d0-costtab(i+1))
22038         sinfac=dsqrt(sinfac2)
22039         it=itype(i,2)
22040         if (it.eq.10) goto 1
22041
22042 !c
22043 !C  Compute the axes of tghe local cartesian coordinates system; store in
22044 !c   x_prime, y_prime and z_prime
22045 !c
22046         do j=1,3
22047           x_prime(j) = 0.00
22048           y_prime(j) = 0.00
22049           z_prime(j) = 0.00
22050         enddo
22051 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22052 !C     &   dc_norm(3,i+nres)
22053         do j = 1,3
22054           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22055           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22056         enddo
22057         do j = 1,3
22058           z_prime(j) = -uz(j,i-1)
22059 !           z_prime(j)=0.0
22060         enddo
22061
22062         xx=0.0d0
22063         yy=0.0d0
22064         zz=0.0d0
22065         do j = 1,3
22066           xx = xx + x_prime(j)*dc_norm(j,i+nres)
22067           yy = yy + y_prime(j)*dc_norm(j,i+nres)
22068           zz = zz + z_prime(j)*dc_norm(j,i+nres)
22069         enddo
22070
22071         xxtab(i)=xx
22072         yytab(i)=yy
22073         zztab(i)=zz
22074          it=itype(i,2)
22075         do j = 1,9
22076           x(j) = sc_parmin_nucl(j,it)
22077         enddo
22078 #ifdef CHECK_COORD
22079 !Cc diagnostics - remove later
22080         xx1 = dcos(alph(2))
22081         yy1 = dsin(alph(2))*dcos(omeg(2))
22082         zz1 = -dsin(alph(2))*dsin(omeg(2))
22083         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22084          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22085          xx1,yy1,zz1
22086 !C,"  --- ", xx_w,yy_w,zz_w
22087 !c end diagnostics
22088 #endif
22089         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22090         esbloc = esbloc + sumene
22091         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22092 !        print *,"enecomp",sumene,sumene2
22093 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22094 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22095 #ifdef DEBUG
22096         write (2,*) "x",(x(k),k=1,9)
22097 !C
22098 !C This section to check the numerical derivatives of the energy of ith side
22099 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22100 !C #define DEBUG in the code to turn it on.
22101 !C
22102         write (2,*) "sumene               =",sumene
22103         aincr=1.0d-7
22104         xxsave=xx
22105         xx=xx+aincr
22106         write (2,*) xx,yy,zz
22107         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22108         de_dxx_num=(sumenep-sumene)/aincr
22109         xx=xxsave
22110         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22111         yysave=yy
22112         yy=yy+aincr
22113         write (2,*) xx,yy,zz
22114         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22115         de_dyy_num=(sumenep-sumene)/aincr
22116         yy=yysave
22117         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22118         zzsave=zz
22119         zz=zz+aincr
22120         write (2,*) xx,yy,zz
22121         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22122         de_dzz_num=(sumenep-sumene)/aincr
22123         zz=zzsave
22124         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22125         costsave=cost2tab(i+1)
22126         sintsave=sint2tab(i+1)
22127         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22128         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22129         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22130         de_dt_num=(sumenep-sumene)/aincr
22131         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22132         cost2tab(i+1)=costsave
22133         sint2tab(i+1)=sintsave
22134 !C End of diagnostics section.
22135 #endif
22136 !C
22137 !C Compute the gradient of esc
22138 !C
22139         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22140         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22141         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22142         de_dtt=0.0d0
22143 #ifdef DEBUG
22144         write (2,*) "x",(x(k),k=1,9)
22145         write (2,*) "xx",xx," yy",yy," zz",zz
22146         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22147           " de_zz   ",de_zz," de_tt   ",de_tt
22148         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22149           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22150 #endif
22151 !C
22152        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22153        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22154        cosfac2xx=cosfac2*xx
22155        sinfac2yy=sinfac2*yy
22156        do k = 1,3
22157          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22158            vbld_inv(i+1)
22159          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22160            vbld_inv(i)
22161          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22162          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22163 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22164 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22165 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22166 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22167          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22168          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22169          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22170          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22171          dZZ_Ci1(k)=0.0d0
22172          dZZ_Ci(k)=0.0d0
22173          do j=1,3
22174            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22175            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22176          enddo
22177
22178          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22179          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22180          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22181 !c
22182          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22183          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22184        enddo
22185
22186        do k=1,3
22187          dXX_Ctab(k,i)=dXX_Ci(k)
22188          dXX_C1tab(k,i)=dXX_Ci1(k)
22189          dYY_Ctab(k,i)=dYY_Ci(k)
22190          dYY_C1tab(k,i)=dYY_Ci1(k)
22191          dZZ_Ctab(k,i)=dZZ_Ci(k)
22192          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22193          dXX_XYZtab(k,i)=dXX_XYZ(k)
22194          dYY_XYZtab(k,i)=dYY_XYZ(k)
22195          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22196        enddo
22197        do k = 1,3
22198 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22199 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22200 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22201 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22202 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22203 !c     &    dt_dci(k)
22204 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22205 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22206          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22207          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22208          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22209          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22210          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22211          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22212 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22213        enddo
22214 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22215 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22216
22217 !C to check gradient call subroutine check_grad
22218
22219     1 continue
22220       enddo
22221       return
22222       end subroutine esb
22223 !=-------------------------------------------------------
22224       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22225 !      implicit none
22226       real(kind=8),dimension(9):: x(9)
22227        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22228       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22229       integer i
22230 !c      write (2,*) "enesc"
22231 !c      write (2,*) "x",(x(i),i=1,9)
22232 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22233       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22234         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22235         + x(9)*yy*zz
22236       enesc_nucl=sumene
22237       return
22238       end function enesc_nucl
22239 !-----------------------------------------------------------------------------
22240       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22241 #ifdef MPI
22242       include 'mpif.h'
22243       integer,parameter :: max_cont=2000
22244       integer,parameter:: max_dim=2*(8*3+6)
22245       integer, parameter :: msglen1=max_cont*max_dim
22246       integer,parameter :: msglen2=2*msglen1
22247       integer source,CorrelType,CorrelID,Error
22248       real(kind=8) :: buffer(max_cont,max_dim)
22249       integer status(MPI_STATUS_SIZE)
22250       integer :: ierror,nbytes
22251 #endif
22252       real(kind=8),dimension(3):: gx(3),gx1(3)
22253       real(kind=8) :: time00
22254       logical lprn,ldone
22255       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22256       real(kind=8) ecorr,ecorr3
22257       integer :: n_corr,n_corr1,mm,msglen
22258 !C Set lprn=.true. for debugging
22259       lprn=.false.
22260       n_corr=0
22261       n_corr1=0
22262 #ifdef MPI
22263       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22264
22265       if (nfgtasks.le.1) goto 30
22266       if (lprn) then
22267         write (iout,'(a)') 'Contact function values:'
22268         do i=nnt,nct-1
22269           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22270          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22271          j=1,num_cont_hb(i))
22272         enddo
22273       endif
22274 !C Caution! Following code assumes that electrostatic interactions concerning
22275 !C a given atom are split among at most two processors!
22276       CorrelType=477
22277       CorrelID=fg_rank+1
22278       ldone=.false.
22279       do i=1,max_cont
22280         do j=1,max_dim
22281           buffer(i,j)=0.0D0
22282         enddo
22283       enddo
22284       mm=mod(fg_rank,2)
22285 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22286       if (mm) 20,20,10
22287    10 continue
22288 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22289       if (fg_rank.gt.0) then
22290 !C Send correlation contributions to the preceding processor
22291         msglen=msglen1
22292         nn=num_cont_hb(iatel_s_nucl)
22293         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22294 !c        write (*,*) 'The BUFFER array:'
22295 !c        do i=1,nn
22296 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22297 !c        enddo
22298         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22299           msglen=msglen2
22300           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22301 !C Clear the contacts of the atom passed to the neighboring processor
22302         nn=num_cont_hb(iatel_s_nucl+1)
22303 !c        do i=1,nn
22304 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22305 !c        enddo
22306             num_cont_hb(iatel_s_nucl)=0
22307         endif
22308 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22309 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22310 !cd   & ' msglen=',msglen
22311 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22312 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22313 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22314         time00=MPI_Wtime()
22315         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22316          CorrelType,FG_COMM,IERROR)
22317         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22318 !cd      write (iout,*) 'Processor ',fg_rank,
22319 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22320 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22321 !c        write (*,*) 'Processor ',fg_rank,
22322 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22323 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22324 !c        msglen=msglen1
22325       endif ! (fg_rank.gt.0)
22326       if (ldone) goto 30
22327       ldone=.true.
22328    20 continue
22329 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22330       if (fg_rank.lt.nfgtasks-1) then
22331 !C Receive correlation contributions from the next processor
22332         msglen=msglen1
22333         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22334 !cd      write (iout,*) 'Processor',fg_rank,
22335 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22336 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22337 !c        write (*,*) 'Processor',fg_rank,
22338 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22339 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22340         time00=MPI_Wtime()
22341         nbytes=-1
22342         do while (nbytes.le.0)
22343           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22344           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22345         enddo
22346 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22347         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22348          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22349         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22350 !c        write (*,*) 'Processor',fg_rank,
22351 !c     &' has received correlation contribution from processor',fg_rank+1,
22352 !c     & ' msglen=',msglen,' nbytes=',nbytes
22353 !c        write (*,*) 'The received BUFFER array:'
22354 !c        do i=1,max_cont
22355 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22356 !c        enddo
22357         if (msglen.eq.msglen1) then
22358           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22359         else if (msglen.eq.msglen2)  then
22360           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22361           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22362         else
22363           write (iout,*) &
22364       'ERROR!!!! message length changed while processing correlations.'
22365           write (*,*) &
22366       'ERROR!!!! message length changed while processing correlations.'
22367           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22368         endif ! msglen.eq.msglen1
22369       endif ! fg_rank.lt.nfgtasks-1
22370       if (ldone) goto 30
22371       ldone=.true.
22372       goto 10
22373    30 continue
22374 #endif
22375       if (lprn) then
22376         write (iout,'(a)') 'Contact function values:'
22377         do i=nnt_molec(2),nct_molec(2)-1
22378           write (iout,'(2i3,50(1x,i2,f5.2))') &
22379          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22380          j=1,num_cont_hb(i))
22381         enddo
22382       endif
22383       ecorr=0.0D0
22384       ecorr3=0.0d0
22385 !C Remove the loop below after debugging !!!
22386 !      do i=nnt_molec(2),nct_molec(2)
22387 !        do j=1,3
22388 !          gradcorr_nucl(j,i)=0.0D0
22389 !          gradxorr_nucl(j,i)=0.0D0
22390 !          gradcorr3_nucl(j,i)=0.0D0
22391 !          gradxorr3_nucl(j,i)=0.0D0
22392 !        enddo
22393 !      enddo
22394 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22395 !C Calculate the local-electrostatic correlation terms
22396       do i=iatsc_s_nucl,iatsc_e_nucl
22397         i1=i+1
22398         num_conti=num_cont_hb(i)
22399         num_conti1=num_cont_hb(i+1)
22400 !        print *,i,num_conti,num_conti1
22401         do jj=1,num_conti
22402           j=jcont_hb(jj,i)
22403           do kk=1,num_conti1
22404             j1=jcont_hb(kk,i1)
22405 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22406 !c     &         ' jj=',jj,' kk=',kk
22407             if (j1.eq.j+1 .or. j1.eq.j-1) then
22408 !C
22409 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22410 !C The system gains extra energy.
22411 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22412 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22413 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22414 !C
22415               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22416               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22417                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22418               n_corr=n_corr+1
22419             else if (j1.eq.j) then
22420 !C
22421 !C Contacts I-J and I-(J+1) occur simultaneously.
22422 !C The system loses extra energy.
22423 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22424 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22425 !C Need to implement full formulas 32 from Liwo et al., 1998.
22426 !C
22427 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22428 !c     &         ' jj=',jj,' kk=',kk
22429               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22430             endif
22431           enddo ! kk
22432           do kk=1,num_conti
22433             j1=jcont_hb(kk,i)
22434 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22435 !c     &         ' jj=',jj,' kk=',kk
22436             if (j1.eq.j+1) then
22437 !C Contacts I-J and (I+1)-J occur simultaneously.
22438 !C The system loses extra energy.
22439               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22440             endif ! j1==j+1
22441           enddo ! kk
22442         enddo ! jj
22443       enddo ! i
22444       return
22445       end subroutine multibody_hb_nucl
22446 !-----------------------------------------------------------
22447       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22448 !      implicit real*8 (a-h,o-z)
22449 !      include 'DIMENSIONS'
22450 !      include 'COMMON.IOUNITS'
22451 !      include 'COMMON.DERIV'
22452 !      include 'COMMON.INTERACT'
22453 !      include 'COMMON.CONTACTS'
22454       real(kind=8),dimension(3) :: gx,gx1
22455       logical :: lprn
22456 !el local variables
22457       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22458       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22459                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22460                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22461                    rlocshield
22462
22463       lprn=.false.
22464       eij=facont_hb(jj,i)
22465       ekl=facont_hb(kk,k)
22466       ees0pij=ees0p(jj,i)
22467       ees0pkl=ees0p(kk,k)
22468       ees0mij=ees0m(jj,i)
22469       ees0mkl=ees0m(kk,k)
22470       ekont=eij*ekl
22471       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22472 !      print *,"ehbcorr_nucl",ekont,ees
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_nucl=ecorr_nucl+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         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22491        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22492        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22493         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22494         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22495         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22496         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22497         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22498         coeffmees0mij*gacontm_hb1(ll,kk,k))
22499         gradxorr_nucl(ll,l)=gradxorr_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         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22506         gradcorr_nucl(ll,i)=gradcorr_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         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22511         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22512         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22513         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22514         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22515         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22516       enddo
22517       ehbcorr_nucl=ekont*ees
22518       return
22519       end function ehbcorr_nucl
22520 !-------------------------------------------------------------------------
22521
22522      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22523 !      implicit real*8 (a-h,o-z)
22524 !      include 'DIMENSIONS'
22525 !      include 'COMMON.IOUNITS'
22526 !      include 'COMMON.DERIV'
22527 !      include 'COMMON.INTERACT'
22528 !      include 'COMMON.CONTACTS'
22529       real(kind=8),dimension(3) :: gx,gx1
22530       logical :: lprn
22531 !el local variables
22532       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22533       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22534                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22535                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22536                    rlocshield
22537
22538       lprn=.false.
22539       eij=facont_hb(jj,i)
22540       ekl=facont_hb(kk,k)
22541       ees0pij=ees0p(jj,i)
22542       ees0pkl=ees0p(kk,k)
22543       ees0mij=ees0m(jj,i)
22544       ees0mkl=ees0m(kk,k)
22545       ekont=eij*ekl
22546       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22547 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22548 !C Following 4 lines for diagnostics.
22549 !cd    ees0pkl=0.0D0
22550 !cd    ees0pij=1.0D0
22551 !cd    ees0mkl=0.0D0
22552 !cd    ees0mij=1.0D0
22553 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22554 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22555 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22556 !C Calculate the multi-body contribution to energy.
22557 !      ecorr=ecorr+ekont*ees
22558 !C Calculate multi-body contributions to the gradient.
22559       coeffpees0pij=coeffp*ees0pij
22560       coeffmees0mij=coeffm*ees0mij
22561       coeffpees0pkl=coeffp*ees0pkl
22562       coeffmees0mkl=coeffm*ees0mkl
22563       do ll=1,3
22564         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22565        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22566        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22567         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22568         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22569         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22570         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22571         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22572         coeffmees0mij*gacontm_hb1(ll,kk,k))
22573         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22574         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22575         coeffmees0mij*gacontm_hb2(ll,kk,k))
22576         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22577           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22578           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22579         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22580         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22581         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22582           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22583           coeffmees0mij*gacontm_hb3(ll,kk,k))
22584         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22585         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22586         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22587         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22588         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22589         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22590       enddo
22591       ehbcorr3_nucl=ekont*ees
22592       return
22593       end function ehbcorr3_nucl
22594 #ifdef MPI
22595       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22596       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22597       real(kind=8):: buffer(dimen1,dimen2)
22598       num_kont=num_cont_hb(atom)
22599       do i=1,num_kont
22600         do k=1,8
22601           do j=1,3
22602             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22603           enddo ! j
22604         enddo ! k
22605         buffer(i,indx+25)=facont_hb(i,atom)
22606         buffer(i,indx+26)=ees0p(i,atom)
22607         buffer(i,indx+27)=ees0m(i,atom)
22608         buffer(i,indx+28)=d_cont(i,atom)
22609         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22610       enddo ! i
22611       buffer(1,indx+30)=dfloat(num_kont)
22612       return
22613       end subroutine pack_buffer
22614 !c------------------------------------------------------------------------------
22615       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22616       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22617       real(kind=8):: buffer(dimen1,dimen2)
22618 !      double precision zapas
22619 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22620 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22621 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22622 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22623       num_kont=buffer(1,indx+30)
22624       num_kont_old=num_cont_hb(atom)
22625       num_cont_hb(atom)=num_kont+num_kont_old
22626       do i=1,num_kont
22627         ii=i+num_kont_old
22628         do k=1,8
22629           do j=1,3
22630             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22631           enddo ! j
22632         enddo ! k
22633         facont_hb(ii,atom)=buffer(i,indx+25)
22634         ees0p(ii,atom)=buffer(i,indx+26)
22635         ees0m(ii,atom)=buffer(i,indx+27)
22636         d_cont(i,atom)=buffer(i,indx+28)
22637         jcont_hb(ii,atom)=buffer(i,indx+29)
22638       enddo ! i
22639       return
22640       end subroutine unpack_buffer
22641 !c------------------------------------------------------------------------------
22642 #endif
22643       subroutine ecatcat(ecationcation)
22644         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22645         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22646         r7,r4,ecationcation,k0,rcal
22647         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22648         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22649         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22650         gg,r
22651
22652         ecationcation=0.0d0
22653         if (nres_molec(5).eq.0) return
22654         rcat0=3.472
22655         epscalc=0.05
22656         r06 = rcat0**6
22657         r012 = r06**2
22658         k0 = 332.0*(2.0*2.0)/80.0
22659         itmp=0
22660
22661         do i=1,4
22662         itmp=itmp+nres_molec(i)
22663         enddo
22664 !        write(iout,*) "itmp",itmp
22665         do i=itmp+1,itmp+nres_molec(5)-1
22666
22667         xi=c(1,i)
22668         yi=c(2,i)
22669         zi=c(3,i)
22670
22671           xi=mod(xi,boxxsize)
22672           if (xi.lt.0) xi=xi+boxxsize
22673           yi=mod(yi,boxysize)
22674           if (yi.lt.0) yi=yi+boxysize
22675           zi=mod(zi,boxzsize)
22676           if (zi.lt.0) zi=zi+boxzsize
22677
22678           do j=i+1,itmp+nres_molec(5)
22679 !           print *,i,j,'catcat'
22680            xj=c(1,j)
22681            yj=c(2,j)
22682            zj=c(3,j)
22683           xj=dmod(xj,boxxsize)
22684           if (xj.lt.0) xj=xj+boxxsize
22685           yj=dmod(yj,boxysize)
22686           if (yj.lt.0) yj=yj+boxysize
22687           zj=dmod(zj,boxzsize)
22688           if (zj.lt.0) zj=zj+boxzsize
22689 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22690       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22691       xj_safe=xj
22692       yj_safe=yj
22693       zj_safe=zj
22694       subchap=0
22695       do xshift=-1,1
22696       do yshift=-1,1
22697       do zshift=-1,1
22698           xj=xj_safe+xshift*boxxsize
22699           yj=yj_safe+yshift*boxysize
22700           zj=zj_safe+zshift*boxzsize
22701           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22702           if(dist_temp.lt.dist_init) then
22703             dist_init=dist_temp
22704             xj_temp=xj
22705             yj_temp=yj
22706             zj_temp=zj
22707             subchap=1
22708           endif
22709        enddo
22710        enddo
22711        enddo
22712        if (subchap.eq.1) then
22713           xj=xj_temp-xi
22714           yj=yj_temp-yi
22715           zj=zj_temp-zi
22716        else
22717           xj=xj_safe-xi
22718           yj=yj_safe-yi
22719           zj=zj_safe-zi
22720        endif
22721        rcal =xj**2+yj**2+zj**2
22722         ract=sqrt(rcal)
22723 !        rcat0=3.472
22724 !        epscalc=0.05
22725 !        r06 = rcat0**6
22726 !        r012 = r06**2
22727 !        k0 = 332*(2*2)/80
22728         Evan1cat=epscalc*(r012/rcal**6)
22729         Evan2cat=epscalc*2*(r06/rcal**3)
22730         Eeleccat=k0/ract
22731         r7 = rcal**7
22732         r4 = rcal**4
22733         r(1)=xj
22734         r(2)=yj
22735         r(3)=zj
22736         do k=1,3
22737           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22738           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22739           dEeleccat(k)=-k0*r(k)/ract**3
22740         enddo
22741         do k=1,3
22742           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22743           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22744           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22745         enddo
22746
22747 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22748         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22749        enddo
22750        enddo
22751        return
22752        end subroutine ecatcat
22753 !---------------------------------------------------------------------------
22754 ! new for K+
22755       subroutine ecats_prot_amber(ecations_prot_amber)
22756 !      subroutine ecat_prot2(ecation_prot)
22757       use calc_data
22758       use comm_momo
22759
22760       logical :: lprn
22761 !el local variables
22762       integer :: iint,itypi1,subchap,isel,itmp
22763       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22764       real(kind=8) :: evdw
22765       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22766                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22767                     sslipi,sslipj,faclip,alpha_sco
22768       integer :: ii
22769       real(kind=8) :: fracinbuf
22770       real (kind=8) :: escpho
22771       real (kind=8),dimension(4):: ener
22772       real(kind=8) :: b1,b2,egb
22773       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22774        Lambf,&
22775        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22776        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22777        federmaus,&
22778        d1i,d1j
22779 !       real(kind=8),dimension(3,2)::erhead_tail
22780 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22781       real(kind=8) ::  facd4, adler, Fgb, facd3
22782       integer troll,jj,istate
22783       real (kind=8) :: dcosom1(3),dcosom2(3)
22784
22785       ecations_prot_amber=0.0D0
22786       if (nres_molec(5).eq.0) return
22787       eps_out=80.0d0
22788 !      sss_ele_cut=1.0d0
22789
22790         itmp=0
22791         do i=1,4
22792         itmp=itmp+nres_molec(i)
22793         enddo
22794 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22795         do i=ibond_start,ibond_end
22796
22797 !        print *,"I am in EVDW",i
22798         itypi=iabs(itype(i,1))
22799 !        if (i.ne.47) cycle
22800         if (itypi.eq.ntyp1) cycle
22801         itypi1=iabs(itype(i+1,1))
22802         xi=c(1,nres+i)
22803         yi=c(2,nres+i)
22804         zi=c(3,nres+i)
22805           xi=dmod(xi,boxxsize)
22806           if (xi.lt.0) xi=xi+boxxsize
22807           yi=dmod(yi,boxysize)
22808           if (yi.lt.0) yi=yi+boxysize
22809           zi=dmod(zi,boxzsize)
22810           if (zi.lt.0) zi=zi+boxzsize
22811         dxi=dc_norm(1,nres+i)
22812         dyi=dc_norm(2,nres+i)
22813         dzi=dc_norm(3,nres+i)
22814         dsci_inv=vbld_inv(i+nres)
22815          do j=itmp+1,itmp+nres_molec(5)
22816
22817 ! Calculate SC interaction energy.
22818             itypj=iabs(itype(j,1))
22819             if ((itypj.eq.ntyp1)) cycle
22820              CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22821
22822             dscj_inv=vbld_inv(j+nres)
22823            xj=c(1,j)
22824            yj=c(2,j)
22825            zj=c(3,j)
22826            xj=dmod(xj,boxxsize)
22827            if (xj.lt.0) xj=xj+boxxsize
22828            yj=dmod(yj,boxysize)
22829            if (yj.lt.0) yj=yj+boxysize
22830            zj=dmod(zj,boxzsize)
22831            if (zj.lt.0) zj=zj+boxzsize
22832           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22833           xj_safe=xj
22834           yj_safe=yj
22835           zj_safe=zj
22836           subchap=0
22837
22838           do xshift=-1,1
22839           do yshift=-1,1
22840           do zshift=-1,1
22841           xj=xj_safe+xshift*boxxsize
22842           yj=yj_safe+yshift*boxysize
22843           zj=zj_safe+zshift*boxzsize
22844           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22845           if(dist_temp.lt.dist_init) then
22846             dist_init=dist_temp
22847             xj_temp=xj
22848             yj_temp=yj
22849             zj_temp=zj
22850             subchap=1
22851           endif
22852           enddo
22853           enddo
22854           enddo
22855           if (subchap.eq.1) then
22856           xj=xj_temp-xi
22857           yj=yj_temp-yi
22858           zj=zj_temp-zi
22859           else
22860           xj=xj_safe-xi
22861           yj=yj_safe-yi
22862           zj=zj_safe-zi
22863           endif
22864
22865 !          dxj = dc_norm( 1, nres+j )
22866 !          dyj = dc_norm( 2, nres+j )
22867 !          dzj = dc_norm( 3, nres+j )
22868
22869           itypi = itype(i,1)
22870           itypj = itype(j,5)
22871 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22872 ! sampling performed with amber package
22873 !          alf1   = 0.0d0
22874 !          alf2   = 0.0d0
22875 !          alf12  = 0.0d0
22876 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22877           chi1 = chicat(itypi,itypj)
22878           chis1 = chiscat(itypi,itypj)
22879           chip1 = chippcat(itypi,itypj)
22880 !          chis2 = chis(itypj,itypi)
22881 !          chis12 = chis1 * chis2
22882           sig1 = sigmap1cat(itypi,itypj)
22883 !          sig2 = sigmap2(itypi,itypj)
22884 ! alpha factors from Fcav/Gcav
22885           b1cav = alphasurcat(1,itypi,itypj)
22886           b2cav = alphasurcat(2,itypi,itypj)
22887           b3cav = alphasurcat(3,itypi,itypj)
22888           b4cav = alphasurcat(4,itypi,itypj)
22889
22890 ! used to determine whether we want to do quadrupole calculations
22891        eps_in = epsintabcat(itypi,itypj)
22892        if (eps_in.eq.0.0) eps_in=1.0
22893
22894        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22895 !       Rtail = 0.0d0
22896
22897        DO k = 1, 3
22898         ctail(k,1)=c(k,i+nres)
22899         ctail(k,2)=c(k,j)
22900        END DO
22901 !c! tail distances will be themselves usefull elswhere
22902 !c1 (in Gcav, for example)
22903        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22904        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22905        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22906        Rtail = dsqrt( &
22907           (Rtail_distance(1)*Rtail_distance(1)) &
22908         + (Rtail_distance(2)*Rtail_distance(2)) &
22909         + (Rtail_distance(3)*Rtail_distance(3)))
22910 ! tail location and distance calculations
22911 ! dhead1
22912        d1 = dheadcat(1, 1, itypi, itypj)
22913 !       d2 = dhead(2, 1, itypi, itypj)
22914        DO k = 1,3
22915 ! location of polar head is computed by taking hydrophobic centre
22916 ! and moving by a d1 * dc_norm vector
22917 ! see unres publications for very informative images
22918         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22919         chead(k,2) = c(k, j)
22920 ! distance
22921 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22922 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22923         Rhead_distance(k) = chead(k,2) - chead(k,1)
22924        END DO
22925 ! pitagoras (root of sum of squares)
22926        Rhead = dsqrt( &
22927           (Rhead_distance(1)*Rhead_distance(1)) &
22928         + (Rhead_distance(2)*Rhead_distance(2)) &
22929         + (Rhead_distance(3)*Rhead_distance(3)))
22930 !-------------------------------------------------------------------
22931 ! zero everything that should be zero'ed
22932        evdwij = 0.0d0
22933        ECL = 0.0d0
22934        Elj = 0.0d0
22935        Equad = 0.0d0
22936        Epol = 0.0d0
22937        Fcav=0.0d0
22938        eheadtail = 0.0d0
22939        dGCLdOM1 = 0.0d0
22940        dGCLdOM2 = 0.0d0
22941        dGCLdOM12 = 0.0d0
22942        dPOLdOM1 = 0.0d0
22943        dPOLdOM2 = 0.0d0
22944           Fcav = 0.0d0
22945           dFdR = 0.0d0
22946           dCAVdOM1  = 0.0d0
22947           dCAVdOM2  = 0.0d0
22948           dCAVdOM12 = 0.0d0
22949           dscj_inv = vbld_inv(j+nres)
22950 !          print *,i,j,dscj_inv,dsci_inv
22951 ! rij holds 1/(distance of Calpha atoms)
22952           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22953           rij  = dsqrt(rrij)
22954           CALL sc_angular
22955 ! this should be in elgrad_init but om's are calculated by sc_angular
22956 ! which in turn is used by older potentials
22957 ! om = omega, sqom = om^2
22958           sqom1  = om1 * om1
22959           sqom2  = om2 * om2
22960           sqom12 = om12 * om12
22961
22962 ! now we calculate EGB - Gey-Berne
22963 ! It will be summed up in evdwij and saved in evdw
22964           sigsq     = 1.0D0  / sigsq
22965           sig       = sig0ij * dsqrt(sigsq)
22966 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22967           rij_shift = Rtail - sig + sig0ij
22968           IF (rij_shift.le.0.0D0) THEN
22969            evdw = 1.0D20
22970            RETURN
22971           END IF
22972           sigder = -sig * sigsq
22973           rij_shift = 1.0D0 / rij_shift
22974           fac       = rij_shift**expon
22975           c1        = fac  * fac * aa_aq(itypi,itypj)
22976 !          print *,"ADAM",aa_aq(itypi,itypj)
22977
22978 !          c1        = 0.0d0
22979           c2        = fac  * bb_aq(itypi,itypj)
22980 !          c2        = 0.0d0
22981           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22982           eps2der   = eps3rt * evdwij
22983           eps3der   = eps2rt * evdwij
22984 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22985           evdwij    = eps2rt * eps3rt * evdwij
22986 !#ifdef TSCSC
22987 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22988 !           evdw_p = evdw_p + evdwij
22989 !          ELSE
22990 !           evdw_m = evdw_m + evdwij
22991 !          END IF
22992 !#else
22993           evdw = evdw  &
22994               + evdwij
22995 !#endif
22996           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22997           fac    = -expon * (c1 + evdwij) * rij_shift
22998           sigder = fac * sigder
22999 ! Calculate distance derivative
23000           gg(1) =  fac
23001           gg(2) =  fac
23002           gg(3) =  fac
23003
23004           fac = chis1 * sqom1 + chis2 * sqom2 &
23005           - 2.0d0 * chis12 * om1 * om2 * om12
23006           pom = 1.0d0 - chis1 * chis2 * sqom12
23007           Lambf = (1.0d0 - (fac / pom))
23008           Lambf = dsqrt(Lambf)
23009           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23010           Chif = Rtail * sparrow
23011           ChiLambf = Chif * Lambf
23012           eagle = dsqrt(ChiLambf)
23013           bat = ChiLambf ** 11.0d0
23014           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23015           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23016           botsq = bot * bot
23017           Fcav = top / bot
23018
23019        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23020        dbot = 12.0d0 * b4cav * bat * Lambf
23021        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23022
23023           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23024           dbot = 12.0d0 * b4cav * bat * Chif
23025           eagle = Lambf * pom
23026           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23027           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23028           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23029               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23030
23031           dFdL = ((dtop * bot - top * dbot) / botsq)
23032           dCAVdOM1  = dFdL * ( dFdOM1 )
23033           dCAVdOM2  = dFdL * ( dFdOM2 )
23034           dCAVdOM12 = dFdL * ( dFdOM12 )
23035
23036        DO k= 1, 3
23037         ertail(k) = Rtail_distance(k)/Rtail
23038        END DO
23039        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23040        erdxj = scalar( ertail(1), dC_norm(1,j) )
23041        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23042        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23043        DO k = 1, 3
23044         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23045         gvdwx(k,i) = gvdwx(k,i) &
23046                   - (( dFdR + gg(k) ) * pom)
23047         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23048 !        gvdwx(k,j) = gvdwx(k,j)   &
23049 !                  + (( dFdR + gg(k) ) * pom)
23050         gvdwc(k,i) = gvdwc(k,i)  &
23051                   - (( dFdR + gg(k) ) * ertail(k))
23052         gvdwc(k,j) = gvdwc(k,j) &
23053                   + (( dFdR + gg(k) ) * ertail(k))
23054         gg(k) = 0.0d0
23055
23056 !c! Compute head-head and head-tail energies for each state
23057           isel = iabs(Qi) + iabs(Qj)
23058           IF (isel.eq.0) THEN
23059 !c! No charges - do nothing
23060            eheadtail = 0.0d0
23061
23062           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
23063 !c! Nonpolar-charge interactions
23064           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23065             Qi=Qi*2
23066             Qij=Qij*2
23067            endif
23068           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23069             Qj=Qj*2
23070             Qij=Qij*2
23071            endif
23072
23073            CALL enq_cat(epol)
23074            eheadtail = epol
23075 !           eheadtail = 0.0d0
23076
23077           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
23078 !c! Dipole-charge interactions
23079           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23080             Qi=Qi*2
23081             Qij=Qij*2
23082            endif
23083           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23084             Qj=Qj*2
23085             Qij=Qij*2
23086            endif
23087            CALL edq_cat(ecl, elj, epol)
23088           eheadtail = ECL + elj + epol
23089 !           eheadtail = 0.0d0
23090
23091           ELSE IF ((isel.eq.2.and.   &
23092                iabs(Qi).eq.1).and.  &
23093                nstate(itypi,itypj).eq.1) THEN
23094
23095 !c! Same charge-charge interaction ( +/+ or -/- )
23096           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23097             Qi=Qi*2
23098             Qij=Qij*2
23099            endif
23100           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23101             Qj=Qj*2
23102             Qij=Qij*2
23103            endif
23104
23105            CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23106            eheadtail = ECL + Egb + Epol + Fisocav + Elj
23107 !           eheadtail = 0.0d0
23108
23109 !          ELSE IF ((isel.eq.2.and.  &
23110 !               iabs(Qi).eq.1).and. &
23111 !               nstate(itypi,itypj).ne.1) THEN
23112 !c! Different charge-charge interaction ( +/- or -/+ )
23113 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23114 !            Qi=Qi*2
23115 !            Qij=Qij*2
23116 !           endif
23117 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23118 !            Qj=Qj*2
23119 !            Qij=Qij*2
23120 !           endif
23121 !
23122 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23123        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23124       evdw = evdw  + Fcav + eheadtail
23125
23126        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23127         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23128         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23129         Equad,evdwij+Fcav+eheadtail,evdw
23130 !       evdw = evdw  + Fcav  + eheadtail
23131
23132 !        iF (nstate(itypi,itypj).eq.1) THEN
23133         CALL sc_grad_cat
23134 !       END IF
23135 !c!-------------------------------------------------------------------
23136 !c! NAPISY KONCOWE
23137          END DO   ! j
23138         END DO    ! iint
23139        END DO     ! i
23140 !c      write (iout,*) "Number of loop steps in EGB:",ind
23141 !c      energy_dec=.false.
23142 !              print *,"EVDW KURW",evdw,nres
23143
23144       return
23145       end subroutine ecats_prot_amber
23146
23147 !---------------------------------------------------------------------------
23148 ! old for Ca2+
23149        subroutine ecat_prot(ecation_prot)
23150 !      use calc_data
23151 !      use comm_momo
23152        integer i,j,k,subchap,itmp,inum
23153         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23154         r7,r4,ecationcation
23155         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23156         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23157         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23158         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23159         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23160         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23161         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23162         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23163         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23164         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23165         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23166         ndiv,ndivi
23167         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23168         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23169         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23170         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23171         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23172         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23173         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23174         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23175         dEvan1Cat
23176         real(kind=8),dimension(6) :: vcatprm
23177         ecation_prot=0.0d0
23178 ! first lets calculate interaction with peptide groups
23179         if (nres_molec(5).eq.0) return
23180         itmp=0
23181         do i=1,4
23182         itmp=itmp+nres_molec(i)
23183         enddo
23184 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23185         do i=ibond_start,ibond_end
23186 !         cycle
23187          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23188         xi=0.5d0*(c(1,i)+c(1,i+1))
23189         yi=0.5d0*(c(2,i)+c(2,i+1))
23190         zi=0.5d0*(c(3,i)+c(3,i+1))
23191           xi=mod(xi,boxxsize)
23192           if (xi.lt.0) xi=xi+boxxsize
23193           yi=mod(yi,boxysize)
23194           if (yi.lt.0) yi=yi+boxysize
23195           zi=mod(zi,boxzsize)
23196           if (zi.lt.0) zi=zi+boxzsize
23197
23198          do j=itmp+1,itmp+nres_molec(5)
23199 !           print *,"WTF",itmp,j,i
23200 ! all parameters were for Ca2+ to approximate single charge divide by two
23201          ndiv=1.0
23202          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23203          wconst=78*ndiv
23204         wdip =1.092777950857032D2
23205         wdip=wdip/wconst
23206         wmodquad=-2.174122713004870D4
23207         wmodquad=wmodquad/wconst
23208         wquad1 = 3.901232068562804D1
23209         wquad1=wquad1/wconst
23210         wquad2 = 3
23211         wquad2=wquad2/wconst
23212         wvan1 = 0.1
23213         wvan2 = 6
23214 !        itmp=0
23215
23216            xj=c(1,j)
23217            yj=c(2,j)
23218            zj=c(3,j)
23219           xj=dmod(xj,boxxsize)
23220           if (xj.lt.0) xj=xj+boxxsize
23221           yj=dmod(yj,boxysize)
23222           if (yj.lt.0) yj=yj+boxysize
23223           zj=dmod(zj,boxzsize)
23224           if (zj.lt.0) zj=zj+boxzsize
23225       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23226       xj_safe=xj
23227       yj_safe=yj
23228       zj_safe=zj
23229       subchap=0
23230       do xshift=-1,1
23231       do yshift=-1,1
23232       do zshift=-1,1
23233           xj=xj_safe+xshift*boxxsize
23234           yj=yj_safe+yshift*boxysize
23235           zj=zj_safe+zshift*boxzsize
23236           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23237           if(dist_temp.lt.dist_init) then
23238             dist_init=dist_temp
23239             xj_temp=xj
23240             yj_temp=yj
23241             zj_temp=zj
23242             subchap=1
23243           endif
23244        enddo
23245        enddo
23246        enddo
23247        if (subchap.eq.1) then
23248           xj=xj_temp-xi
23249           yj=yj_temp-yi
23250           zj=zj_temp-zi
23251        else
23252           xj=xj_safe-xi
23253           yj=yj_safe-yi
23254           zj=zj_safe-zi
23255        endif
23256 !       enddo
23257 !       enddo
23258        rcpm = sqrt(xj**2+yj**2+zj**2)
23259        drcp_norm(1)=xj/rcpm
23260        drcp_norm(2)=yj/rcpm
23261        drcp_norm(3)=zj/rcpm
23262        dcmag=0.0
23263        do k=1,3
23264        dcmag=dcmag+dc(k,i)**2
23265        enddo
23266        dcmag=dsqrt(dcmag)
23267        do k=1,3
23268          myd_norm(k)=dc(k,i)/dcmag
23269        enddo
23270         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23271         drcp_norm(3)*myd_norm(3)
23272         rsecp = rcpm**2
23273         Ir = 1.0d0/rcpm
23274         Irsecp = 1.0d0/rsecp
23275         Irthrp = Irsecp/rcpm
23276         Irfourp = Irthrp/rcpm
23277         Irfiftp = Irfourp/rcpm
23278         Irsistp=Irfiftp/rcpm
23279         Irseven=Irsistp/rcpm
23280         Irtwelv=Irsistp*Irsistp
23281         Irthir=Irtwelv/rcpm
23282         sin2thet = (1-costhet*costhet)
23283         sinthet=sqrt(sin2thet)
23284         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23285              *sin2thet
23286         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23287              2*wvan2**6*Irsistp)
23288         ecation_prot = ecation_prot+E1+E2
23289 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23290         dE1dr = -2*costhet*wdip*Irthrp-&
23291          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23292         dE2dr = 3*wquad1*wquad2*Irfourp-     &
23293           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23294         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23295         do k=1,3
23296           drdpep(k) = -drcp_norm(k)
23297           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23298           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23299           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23300           dEddci(k) = dEdcos*dcosddci(k)
23301         enddo
23302         do k=1,3
23303         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23304         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23305         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23306         enddo
23307        enddo ! j
23308        enddo ! i
23309 !------------------------------------------sidechains
23310 !        do i=1,nres_molec(1)
23311         do i=ibond_start,ibond_end
23312          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23313 !         cycle
23314 !        print *,i,ecation_prot
23315         xi=(c(1,i+nres))
23316         yi=(c(2,i+nres))
23317         zi=(c(3,i+nres))
23318           xi=mod(xi,boxxsize)
23319           if (xi.lt.0) xi=xi+boxxsize
23320           yi=mod(yi,boxysize)
23321           if (yi.lt.0) yi=yi+boxysize
23322           zi=mod(zi,boxzsize)
23323           if (zi.lt.0) zi=zi+boxzsize
23324           do k=1,3
23325             cm1(k)=dc(k,i+nres)
23326           enddo
23327            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23328          do j=itmp+1,itmp+nres_molec(5)
23329          ndiv=1.0
23330          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23331
23332            xj=c(1,j)
23333            yj=c(2,j)
23334            zj=c(3,j)
23335           xj=dmod(xj,boxxsize)
23336           if (xj.lt.0) xj=xj+boxxsize
23337           yj=dmod(yj,boxysize)
23338           if (yj.lt.0) yj=yj+boxysize
23339           zj=dmod(zj,boxzsize)
23340           if (zj.lt.0) zj=zj+boxzsize
23341       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23342       xj_safe=xj
23343       yj_safe=yj
23344       zj_safe=zj
23345       subchap=0
23346       do xshift=-1,1
23347       do yshift=-1,1
23348       do zshift=-1,1
23349           xj=xj_safe+xshift*boxxsize
23350           yj=yj_safe+yshift*boxysize
23351           zj=zj_safe+zshift*boxzsize
23352           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23353           if(dist_temp.lt.dist_init) then
23354             dist_init=dist_temp
23355             xj_temp=xj
23356             yj_temp=yj
23357             zj_temp=zj
23358             subchap=1
23359           endif
23360        enddo
23361        enddo
23362        enddo
23363        if (subchap.eq.1) then
23364           xj=xj_temp-xi
23365           yj=yj_temp-yi
23366           zj=zj_temp-zi
23367        else
23368           xj=xj_safe-xi
23369           yj=yj_safe-yi
23370           zj=zj_safe-zi
23371        endif
23372 !       enddo
23373 !       enddo
23374 ! 15- Glu 16-Asp
23375          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23376          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23377          (itype(i,1).eq.25))) then
23378             if(itype(i,1).eq.16) then
23379             inum=1
23380             else
23381             inum=2
23382             endif
23383             do k=1,6
23384             vcatprm(k)=catprm(k,inum)
23385             enddo
23386             dASGL=catprm(7,inum)
23387 !             do k=1,3
23388 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23389                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23390                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23391                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23392
23393 !                valpha(k)=c(k,i)
23394 !                vcat(k)=c(k,j)
23395                 if (subchap.eq.1) then
23396                  vcat(1)=xj_temp
23397                  vcat(2)=yj_temp
23398                  vcat(3)=zj_temp
23399                  else
23400                 vcat(1)=xj_safe
23401                 vcat(2)=yj_safe
23402                 vcat(3)=zj_safe
23403                  endif
23404                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23405                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23406                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23407
23408 !              enddo
23409         do k=1,3
23410           dx(k) = vcat(k)-vcm(k)
23411         enddo
23412         do k=1,3
23413           v1(k)=(vcm(k)-valpha(k))
23414           v2(k)=(vcat(k)-valpha(k))
23415         enddo
23416         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23417         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23418         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23419
23420 !  The weights of the energy function calculated from
23421 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23422           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23423             ndivi=0.5
23424           else
23425             ndivi=1.0
23426           endif
23427          ndiv=1.0
23428          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23429
23430         wh2o=78*ndivi*ndiv
23431         wc = vcatprm(1)
23432         wc=wc/wh2o
23433         wdip =vcatprm(2)
23434         wdip=wdip/wh2o
23435         wquad1 =vcatprm(3)
23436         wquad1=wquad1/wh2o
23437         wquad2 = vcatprm(4)
23438         wquad2=wquad2/wh2o
23439         wquad2p = 1.0d0-wquad2
23440         wvan1 = vcatprm(5)
23441         wvan2 =vcatprm(6)
23442         opt = dx(1)**2+dx(2)**2
23443         rsecp = opt+dx(3)**2
23444         rs = sqrt(rsecp)
23445         rthrp = rsecp*rs
23446         rfourp = rthrp*rs
23447         rsixp = rfourp*rsecp
23448         reight=rsixp*rsecp
23449         Ir = 1.0d0/rs
23450         Irsecp = 1.0d0/rsecp
23451         Irthrp = Irsecp/rs
23452         Irfourp = Irthrp/rs
23453         Irsixp = 1.0d0/rsixp
23454         Ireight=1.0d0/reight
23455         Irtw=Irsixp*Irsixp
23456         Irthir=Irtw/rs
23457         Irfourt=Irthir/rs
23458         opt1 = (4*rs*dx(3)*wdip)
23459         opt2 = 6*rsecp*wquad1*opt
23460         opt3 = wquad1*wquad2p*Irsixp
23461         opt4 = (wvan1*wvan2**12)
23462         opt5 = opt4*12*Irfourt
23463         opt6 = 2*wvan1*wvan2**6
23464         opt7 = 6*opt6*Ireight
23465         opt8 = wdip/v1m
23466         opt10 = wdip/v2m
23467         opt11 = (rsecp*v2m)**2
23468         opt12 = (rsecp*v1m)**2
23469         opt14 = (v1m*v2m*rsecp)**2
23470         opt15 = -wquad1/v2m**2
23471         opt16 = (rthrp*(v1m*v2m)**2)**2
23472         opt17 = (v1m**2*rthrp)**2
23473         opt18 = -wquad1/rthrp
23474         opt19 = (v1m**2*v2m**2)**2
23475         Ec = wc*Ir
23476         do k=1,3
23477           dEcCat(k) = -(dx(k)*wc)*Irthrp
23478           dEcCm(k)=(dx(k)*wc)*Irthrp
23479           dEcCalp(k)=0.0d0
23480         enddo
23481         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23482         do k=1,3
23483           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23484                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23485           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23486                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23487           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23488                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23489                       *v1dpv2)/opt14
23490         enddo
23491         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23492         do k=1,3
23493           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23494                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23495                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23496           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23497                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23498                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23499           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23500                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23501                         v1dpv2**2)/opt19
23502         enddo
23503         Equad2=wquad1*wquad2p*Irthrp
23504         do k=1,3
23505           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23506           dEquad2Cm(k)=3*dx(k)*rs*opt3
23507           dEquad2Calp(k)=0.0d0
23508         enddo
23509         Evan1=opt4*Irtw
23510         do k=1,3
23511           dEvan1Cat(k)=-dx(k)*opt5
23512           dEvan1Cm(k)=dx(k)*opt5
23513           dEvan1Calp(k)=0.0d0
23514         enddo
23515         Evan2=-opt6*Irsixp
23516         do k=1,3
23517           dEvan2Cat(k)=dx(k)*opt7
23518           dEvan2Cm(k)=-dx(k)*opt7
23519           dEvan2Calp(k)=0.0d0
23520         enddo
23521         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23522 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23523
23524         do k=1,3
23525           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23526                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23527 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23528           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23529                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23530           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23531                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23532         enddo
23533             dscmag = 0.0d0
23534             do k=1,3
23535               dscvec(k) = dc(k,i+nres)
23536               dscmag = dscmag+dscvec(k)*dscvec(k)
23537             enddo
23538             dscmag3 = dscmag
23539             dscmag = sqrt(dscmag)
23540             dscmag3 = dscmag3*dscmag
23541             constA = 1.0d0+dASGL/dscmag
23542             constB = 0.0d0
23543             do k=1,3
23544               constB = constB+dscvec(k)*dEtotalCm(k)
23545             enddo
23546             constB = constB*dASGL/dscmag3
23547             do k=1,3
23548               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23549               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23550                constA*dEtotalCm(k)-constB*dscvec(k)
23551 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23552               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23553               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23554              enddo
23555         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23556            if(itype(i,1).eq.14) then
23557             inum=3
23558             else
23559             inum=4
23560             endif
23561             do k=1,6
23562             vcatprm(k)=catprm(k,inum)
23563             enddo
23564             dASGL=catprm(7,inum)
23565 !             do k=1,3
23566 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23567 !                valpha(k)=c(k,i)
23568 !                vcat(k)=c(k,j)
23569 !              enddo
23570                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23571                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23572                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23573                 if (subchap.eq.1) then
23574                  vcat(1)=xj_temp
23575                  vcat(2)=yj_temp
23576                  vcat(3)=zj_temp
23577                  else
23578                 vcat(1)=xj_safe
23579                 vcat(2)=yj_safe
23580                 vcat(3)=zj_safe
23581                 endif
23582                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23583                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23584                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23585
23586
23587         do k=1,3
23588           dx(k) = vcat(k)-vcm(k)
23589         enddo
23590         do k=1,3
23591           v1(k)=(vcm(k)-valpha(k))
23592           v2(k)=(vcat(k)-valpha(k))
23593         enddo
23594         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23595         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23596         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23597 !  The weights of the energy function calculated from
23598 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23599          ndiv=1.0
23600          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23601
23602         wh2o=78*ndiv
23603         wdip =vcatprm(2)
23604         wdip=wdip/wh2o
23605         wquad1 =vcatprm(3)
23606         wquad1=wquad1/wh2o
23607         wquad2 = vcatprm(4)
23608         wquad2=wquad2/wh2o
23609         wquad2p = 1-wquad2
23610         wvan1 = vcatprm(5)
23611         wvan2 =vcatprm(6)
23612         opt = dx(1)**2+dx(2)**2
23613         rsecp = opt+dx(3)**2
23614         rs = sqrt(rsecp)
23615         rthrp = rsecp*rs
23616         rfourp = rthrp*rs
23617         rsixp = rfourp*rsecp
23618         reight=rsixp*rsecp
23619         Ir = 1.0d0/rs
23620         Irsecp = 1/rsecp
23621         Irthrp = Irsecp/rs
23622         Irfourp = Irthrp/rs
23623         Irsixp = 1/rsixp
23624         Ireight=1/reight
23625         Irtw=Irsixp*Irsixp
23626         Irthir=Irtw/rs
23627         Irfourt=Irthir/rs
23628         opt1 = (4*rs*dx(3)*wdip)
23629         opt2 = 6*rsecp*wquad1*opt
23630         opt3 = wquad1*wquad2p*Irsixp
23631         opt4 = (wvan1*wvan2**12)
23632         opt5 = opt4*12*Irfourt
23633         opt6 = 2*wvan1*wvan2**6
23634         opt7 = 6*opt6*Ireight
23635         opt8 = wdip/v1m
23636         opt10 = wdip/v2m
23637         opt11 = (rsecp*v2m)**2
23638         opt12 = (rsecp*v1m)**2
23639         opt14 = (v1m*v2m*rsecp)**2
23640         opt15 = -wquad1/v2m**2
23641         opt16 = (rthrp*(v1m*v2m)**2)**2
23642         opt17 = (v1m**2*rthrp)**2
23643         opt18 = -wquad1/rthrp
23644         opt19 = (v1m**2*v2m**2)**2
23645         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23646         do k=1,3
23647           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23648                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23649          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23650                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23651           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23652                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23653                       *v1dpv2)/opt14
23654         enddo
23655         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23656         do k=1,3
23657           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23658                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23659                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23660           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23661                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23662                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23663           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23664                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23665                         v1dpv2**2)/opt19
23666         enddo
23667         Equad2=wquad1*wquad2p*Irthrp
23668         do k=1,3
23669           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23670           dEquad2Cm(k)=3*dx(k)*rs*opt3
23671           dEquad2Calp(k)=0.0d0
23672         enddo
23673         Evan1=opt4*Irtw
23674         do k=1,3
23675           dEvan1Cat(k)=-dx(k)*opt5
23676           dEvan1Cm(k)=dx(k)*opt5
23677           dEvan1Calp(k)=0.0d0
23678         enddo
23679         Evan2=-opt6*Irsixp
23680         do k=1,3
23681           dEvan2Cat(k)=dx(k)*opt7
23682           dEvan2Cm(k)=-dx(k)*opt7
23683           dEvan2Calp(k)=0.0d0
23684         enddo
23685          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23686         do k=1,3
23687           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23688                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23689           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23690                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23691           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23692                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23693         enddo
23694             dscmag = 0.0d0
23695             do k=1,3
23696               dscvec(k) = c(k,i+nres)-c(k,i)
23697 ! TU SPRAWDZ???
23698 !              dscvec(1) = xj
23699 !              dscvec(2) = yj
23700 !              dscvec(3) = zj
23701
23702               dscmag = dscmag+dscvec(k)*dscvec(k)
23703             enddo
23704             dscmag3 = dscmag
23705             dscmag = sqrt(dscmag)
23706             dscmag3 = dscmag3*dscmag
23707             constA = 1+dASGL/dscmag
23708             constB = 0.0d0
23709             do k=1,3
23710               constB = constB+dscvec(k)*dEtotalCm(k)
23711             enddo
23712             constB = constB*dASGL/dscmag3
23713             do k=1,3
23714               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23715               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23716                constA*dEtotalCm(k)-constB*dscvec(k)
23717               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23718               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23719              enddo
23720            else
23721             rcal = 0.0d0
23722             do k=1,3
23723 !              r(k) = c(k,j)-c(k,i+nres)
23724               r(1) = xj
23725               r(2) = yj
23726               r(3) = zj
23727               rcal = rcal+r(k)*r(k)
23728             enddo
23729             ract=sqrt(rcal)
23730             rocal=1.5
23731             epscalc=0.2
23732             r0p=0.5*(rocal+sig0(itype(i,1)))
23733             r06 = r0p**6
23734             r012 = r06*r06
23735             Evan1=epscalc*(r012/rcal**6)
23736             Evan2=epscalc*2*(r06/rcal**3)
23737             r4 = rcal**4
23738             r7 = rcal**7
23739             do k=1,3
23740               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23741               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23742             enddo
23743             do k=1,3
23744               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23745             enddo
23746                  ecation_prot = ecation_prot+ Evan1+Evan2
23747             do  k=1,3
23748                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23749                dEtotalCm(k)
23750               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23751               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23752              enddo
23753          endif ! 13-16 residues
23754        enddo !j
23755        enddo !i
23756        return
23757        end subroutine ecat_prot
23758
23759 !----------------------------------------------------------------------------
23760 !-----------------------------------------------------------------------------
23761 !-----------------------------------------------------------------------------
23762       subroutine eprot_sc_base(escbase)
23763       use calc_data
23764 !      implicit real*8 (a-h,o-z)
23765 !      include 'DIMENSIONS'
23766 !      include 'COMMON.GEO'
23767 !      include 'COMMON.VAR'
23768 !      include 'COMMON.LOCAL'
23769 !      include 'COMMON.CHAIN'
23770 !      include 'COMMON.DERIV'
23771 !      include 'COMMON.NAMES'
23772 !      include 'COMMON.INTERACT'
23773 !      include 'COMMON.IOUNITS'
23774 !      include 'COMMON.CALC'
23775 !      include 'COMMON.CONTROL'
23776 !      include 'COMMON.SBRIDGE'
23777       logical :: lprn
23778 !el local variables
23779       integer :: iint,itypi,itypi1,itypj,subchap
23780       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23781       real(kind=8) :: evdw,sig0ij
23782       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23783                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23784                     sslipi,sslipj,faclip
23785       integer :: ii
23786       real(kind=8) :: fracinbuf
23787        real (kind=8) :: escbase
23788        real (kind=8),dimension(4):: ener
23789        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23790        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23791         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23792         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23793         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23794         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23795         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23796         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23797        real(kind=8),dimension(3,2)::chead,erhead_tail
23798        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23799        integer troll
23800        eps_out=80.0d0
23801        escbase=0.0d0
23802 !       do i=1,nres_molec(1)
23803         do i=ibond_start,ibond_end
23804         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23805         itypi  = itype(i,1)
23806         dxi    = dc_norm(1,nres+i)
23807         dyi    = dc_norm(2,nres+i)
23808         dzi    = dc_norm(3,nres+i)
23809         dsci_inv = vbld_inv(i+nres)
23810         xi=c(1,nres+i)
23811         yi=c(2,nres+i)
23812         zi=c(3,nres+i)
23813         xi=mod(xi,boxxsize)
23814          if (xi.lt.0) xi=xi+boxxsize
23815         yi=mod(yi,boxysize)
23816          if (yi.lt.0) yi=yi+boxysize
23817         zi=mod(zi,boxzsize)
23818          if (zi.lt.0) zi=zi+boxzsize
23819          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23820            itypj= itype(j,2)
23821            if (itype(j,2).eq.ntyp1_molec(2))cycle
23822            xj=c(1,j+nres)
23823            yj=c(2,j+nres)
23824            zj=c(3,j+nres)
23825            xj=dmod(xj,boxxsize)
23826            if (xj.lt.0) xj=xj+boxxsize
23827            yj=dmod(yj,boxysize)
23828            if (yj.lt.0) yj=yj+boxysize
23829            zj=dmod(zj,boxzsize)
23830            if (zj.lt.0) zj=zj+boxzsize
23831           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23832           xj_safe=xj
23833           yj_safe=yj
23834           zj_safe=zj
23835           subchap=0
23836
23837           do xshift=-1,1
23838           do yshift=-1,1
23839           do zshift=-1,1
23840           xj=xj_safe+xshift*boxxsize
23841           yj=yj_safe+yshift*boxysize
23842           zj=zj_safe+zshift*boxzsize
23843           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23844           if(dist_temp.lt.dist_init) then
23845             dist_init=dist_temp
23846             xj_temp=xj
23847             yj_temp=yj
23848             zj_temp=zj
23849             subchap=1
23850           endif
23851           enddo
23852           enddo
23853           enddo
23854           if (subchap.eq.1) then
23855           xj=xj_temp-xi
23856           yj=yj_temp-yi
23857           zj=zj_temp-zi
23858           else
23859           xj=xj_safe-xi
23860           yj=yj_safe-yi
23861           zj=zj_safe-zi
23862           endif
23863           dxj = dc_norm( 1, nres+j )
23864           dyj = dc_norm( 2, nres+j )
23865           dzj = dc_norm( 3, nres+j )
23866 !          print *,i,j,itypi,itypj
23867           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23868           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23869 !          d1i=0.0d0
23870 !          d1j=0.0d0
23871 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23872 ! Gay-berne var's
23873           sig0ij = sigma_scbase( itypi,itypj )
23874           chi1   = chi_scbase( itypi, itypj,1 )
23875           chi2   = chi_scbase( itypi, itypj,2 )
23876 !          chi1=0.0d0
23877 !          chi2=0.0d0
23878           chi12  = chi1 * chi2
23879           chip1  = chipp_scbase( itypi, itypj,1 )
23880           chip2  = chipp_scbase( itypi, itypj,2 )
23881 !          chip1=0.0d0
23882 !          chip2=0.0d0
23883           chip12 = chip1 * chip2
23884 ! not used by momo potential, but needed by sc_angular which is shared
23885 ! by all energy_potential subroutines
23886           alf1   = 0.0d0
23887           alf2   = 0.0d0
23888           alf12  = 0.0d0
23889           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23890 !       a12sq = a12sq * a12sq
23891 ! charge of amino acid itypi is...
23892           chis1 = chis_scbase(itypi,itypj,1)
23893           chis2 = chis_scbase(itypi,itypj,2)
23894           chis12 = chis1 * chis2
23895           sig1 = sigmap1_scbase(itypi,itypj)
23896           sig2 = sigmap2_scbase(itypi,itypj)
23897 !       write (*,*) "sig1 = ", sig1
23898 !       write (*,*) "sig2 = ", sig2
23899 ! alpha factors from Fcav/Gcav
23900           b1 = alphasur_scbase(1,itypi,itypj)
23901 !          b1=0.0d0
23902           b2 = alphasur_scbase(2,itypi,itypj)
23903           b3 = alphasur_scbase(3,itypi,itypj)
23904           b4 = alphasur_scbase(4,itypi,itypj)
23905 ! used to determine whether we want to do quadrupole calculations
23906 ! used by Fgb
23907        eps_in = epsintab_scbase(itypi,itypj)
23908        if (eps_in.eq.0.0) eps_in=1.0
23909        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23910 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23911 !-------------------------------------------------------------------
23912 ! tail location and distance calculations
23913        DO k = 1,3
23914 ! location of polar head is computed by taking hydrophobic centre
23915 ! and moving by a d1 * dc_norm vector
23916 ! see unres publications for very informative images
23917         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23918         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23919 ! distance
23920 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23921 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23922         Rhead_distance(k) = chead(k,2) - chead(k,1)
23923        END DO
23924 ! pitagoras (root of sum of squares)
23925        Rhead = dsqrt( &
23926           (Rhead_distance(1)*Rhead_distance(1)) &
23927         + (Rhead_distance(2)*Rhead_distance(2)) &
23928         + (Rhead_distance(3)*Rhead_distance(3)))
23929 !-------------------------------------------------------------------
23930 ! zero everything that should be zero'ed
23931        evdwij = 0.0d0
23932        ECL = 0.0d0
23933        Elj = 0.0d0
23934        Equad = 0.0d0
23935        Epol = 0.0d0
23936        Fcav=0.0d0
23937        eheadtail = 0.0d0
23938        dGCLdOM1 = 0.0d0
23939        dGCLdOM2 = 0.0d0
23940        dGCLdOM12 = 0.0d0
23941        dPOLdOM1 = 0.0d0
23942        dPOLdOM2 = 0.0d0
23943           Fcav = 0.0d0
23944           dFdR = 0.0d0
23945           dCAVdOM1  = 0.0d0
23946           dCAVdOM2  = 0.0d0
23947           dCAVdOM12 = 0.0d0
23948           dscj_inv = vbld_inv(j+nres)
23949 !          print *,i,j,dscj_inv,dsci_inv
23950 ! rij holds 1/(distance of Calpha atoms)
23951           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23952           rij  = dsqrt(rrij)
23953 !----------------------------
23954           CALL sc_angular
23955 ! this should be in elgrad_init but om's are calculated by sc_angular
23956 ! which in turn is used by older potentials
23957 ! om = omega, sqom = om^2
23958           sqom1  = om1 * om1
23959           sqom2  = om2 * om2
23960           sqom12 = om12 * om12
23961
23962 ! now we calculate EGB - Gey-Berne
23963 ! It will be summed up in evdwij and saved in evdw
23964           sigsq     = 1.0D0  / sigsq
23965           sig       = sig0ij * dsqrt(sigsq)
23966 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23967           rij_shift = 1.0/rij - sig + sig0ij
23968           IF (rij_shift.le.0.0D0) THEN
23969            evdw = 1.0D20
23970            RETURN
23971           END IF
23972           sigder = -sig * sigsq
23973           rij_shift = 1.0D0 / rij_shift
23974           fac       = rij_shift**expon
23975           c1        = fac  * fac * aa_scbase(itypi,itypj)
23976 !          c1        = 0.0d0
23977           c2        = fac  * bb_scbase(itypi,itypj)
23978 !          c2        = 0.0d0
23979           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23980           eps2der   = eps3rt * evdwij
23981           eps3der   = eps2rt * evdwij
23982 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23983           evdwij    = eps2rt * eps3rt * evdwij
23984           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23985           fac    = -expon * (c1 + evdwij) * rij_shift
23986           sigder = fac * sigder
23987 !          fac    = rij * fac
23988 ! Calculate distance derivative
23989           gg(1) =  fac
23990           gg(2) =  fac
23991           gg(3) =  fac
23992 !          if (b2.gt.0.0) then
23993           fac = chis1 * sqom1 + chis2 * sqom2 &
23994           - 2.0d0 * chis12 * om1 * om2 * om12
23995 ! we will use pom later in Gcav, so dont mess with it!
23996           pom = 1.0d0 - chis1 * chis2 * sqom12
23997           Lambf = (1.0d0 - (fac / pom))
23998           Lambf = dsqrt(Lambf)
23999           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24000 !       write (*,*) "sparrow = ", sparrow
24001           Chif = 1.0d0/rij * sparrow
24002           ChiLambf = Chif * Lambf
24003           eagle = dsqrt(ChiLambf)
24004           bat = ChiLambf ** 11.0d0
24005           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24006           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24007           botsq = bot * bot
24008           Fcav = top / bot
24009 !          print *,i,j,Fcav
24010           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24011           dbot = 12.0d0 * b4 * bat * Lambf
24012           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24013 !       dFdR = 0.0d0
24014 !      write (*,*) "dFcav/dR = ", dFdR
24015           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24016           dbot = 12.0d0 * b4 * bat * Chif
24017           eagle = Lambf * pom
24018           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24019           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24020           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24021               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24022
24023           dFdL = ((dtop * bot - top * dbot) / botsq)
24024 !       dFdL = 0.0d0
24025           dCAVdOM1  = dFdL * ( dFdOM1 )
24026           dCAVdOM2  = dFdL * ( dFdOM2 )
24027           dCAVdOM12 = dFdL * ( dFdOM12 )
24028
24029           ertail(1) = xj*rij
24030           ertail(2) = yj*rij
24031           ertail(3) = zj*rij
24032 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24033 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24034 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24035 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24036 !           print *,"EOMY",eom1,eom2,eom12
24037 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24038 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24039 ! here dtail=0.0
24040 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24041 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24042        DO k = 1, 3
24043 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24044 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24045         pom = ertail(k)
24046 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24047         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24048                   - (( dFdR + gg(k) ) * pom)
24049 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24050 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24051 !     &             - ( dFdR * pom )
24052         pom = ertail(k)
24053 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24054         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24055                   + (( dFdR + gg(k) ) * pom)
24056 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24057 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24058 !c!     &             + ( dFdR * pom )
24059
24060         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24061                   - (( dFdR + gg(k) ) * ertail(k))
24062 !c!     &             - ( dFdR * ertail(k))
24063
24064         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24065                   + (( dFdR + gg(k) ) * ertail(k))
24066 !c!     &             + ( dFdR * ertail(k))
24067
24068         gg(k) = 0.0d0
24069 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24070 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24071       END DO
24072
24073 !          else
24074
24075 !          endif
24076 !Now dipole-dipole
24077          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24078        w1 = wdipdip_scbase(1,itypi,itypj)
24079        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24080        w3 = wdipdip_scbase(2,itypi,itypj)
24081 !c!-------------------------------------------------------------------
24082 !c! ECL
24083        fac = (om12 - 3.0d0 * om1 * om2)
24084        c1 = (w1 / (Rhead**3.0d0)) * fac
24085        c2 = (w2 / Rhead ** 6.0d0)  &
24086          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24087        c3= (w3/ Rhead ** 6.0d0)  &
24088          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24089        ECL = c1 - c2 + c3
24090 !c!       write (*,*) "w1 = ", w1
24091 !c!       write (*,*) "w2 = ", w2
24092 !c!       write (*,*) "om1 = ", om1
24093 !c!       write (*,*) "om2 = ", om2
24094 !c!       write (*,*) "om12 = ", om12
24095 !c!       write (*,*) "fac = ", fac
24096 !c!       write (*,*) "c1 = ", c1
24097 !c!       write (*,*) "c2 = ", c2
24098 !c!       write (*,*) "Ecl = ", Ecl
24099 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24100 !c!       write (*,*) "c2_2 = ",
24101 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24102 !c!-------------------------------------------------------------------
24103 !c! dervative of ECL is GCL...
24104 !c! dECL/dr
24105        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24106        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24107          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24108        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24109          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24110        dGCLdR = c1 - c2 + c3
24111 !c! dECL/dom1
24112        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24113        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24114          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24115        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24116        dGCLdOM1 = c1 - c2 + c3
24117 !c! dECL/dom2
24118        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24119        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24120          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24121        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24122        dGCLdOM2 = c1 - c2 + c3
24123 !c! dECL/dom12
24124        c1 = w1 / (Rhead ** 3.0d0)
24125        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24126        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24127        dGCLdOM12 = c1 - c2 + c3
24128        DO k= 1, 3
24129         erhead(k) = Rhead_distance(k)/Rhead
24130        END DO
24131        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24132        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24133        facd1 = d1i * vbld_inv(i+nres)
24134        facd2 = d1j * vbld_inv(j+nres)
24135        DO k = 1, 3
24136
24137         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24138         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24139                   - dGCLdR * pom
24140         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24141         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24142                   + dGCLdR * pom
24143
24144         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24145                   - dGCLdR * erhead(k)
24146         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24147                   + dGCLdR * erhead(k)
24148        END DO
24149        endif
24150 !now charge with dipole eg. ARG-dG
24151        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24152       alphapol1 = alphapol_scbase(itypi,itypj)
24153        w1        = wqdip_scbase(1,itypi,itypj)
24154        w2        = wqdip_scbase(2,itypi,itypj)
24155 !       w1=0.0d0
24156 !       w2=0.0d0
24157 !       pis       = sig0head_scbase(itypi,itypj)
24158 !       eps_head   = epshead_scbase(itypi,itypj)
24159 !c!-------------------------------------------------------------------
24160 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24161        R1 = 0.0d0
24162        DO k = 1, 3
24163 !c! Calculate head-to-tail distances tail is center of side-chain
24164         R1=R1+(c(k,j+nres)-chead(k,1))**2
24165        END DO
24166 !c! Pitagoras
24167        R1 = dsqrt(R1)
24168
24169 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24170 !c!     &        +dhead(1,1,itypi,itypj))**2))
24171 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24172 !c!     &        +dhead(2,1,itypi,itypj))**2))
24173
24174 !c!-------------------------------------------------------------------
24175 !c! ecl
24176        sparrow  = w1  *  om1
24177        hawk     = w2 *  (1.0d0 - sqom2)
24178        Ecl = sparrow / Rhead**2.0d0 &
24179            - hawk    / Rhead**4.0d0
24180 !c!-------------------------------------------------------------------
24181 !c! derivative of ecl is Gcl
24182 !c! dF/dr part
24183        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24184                 + 4.0d0 * hawk    / Rhead**5.0d0
24185 !c! dF/dom1
24186        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24187 !c! dF/dom2
24188        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24189 !c--------------------------------------------------------------------
24190 !c Polarization energy
24191 !c Epol
24192        MomoFac1 = (1.0d0 - chi1 * sqom2)
24193        RR1  = R1 * R1 / MomoFac1
24194        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24195        fgb1 = sqrt( RR1 + a12sq * ee1)
24196 !       eps_inout_fac=0.0d0
24197        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24198 ! derivative of Epol is Gpol...
24199        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24200                 / (fgb1 ** 5.0d0)
24201        dFGBdR1 = ( (R1 / MomoFac1) &
24202              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24203              / ( 2.0d0 * fgb1 )
24204        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24205                * (2.0d0 - 0.5d0 * ee1) ) &
24206                / (2.0d0 * fgb1)
24207        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24208 !       dPOLdR1 = 0.0d0
24209        dPOLdOM1 = 0.0d0
24210        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24211        DO k = 1, 3
24212         erhead(k) = Rhead_distance(k)/Rhead
24213         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24214        END DO
24215
24216        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24217        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24218        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24219 !       bat=0.0d0
24220        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24221        facd1 = d1i * vbld_inv(i+nres)
24222        facd2 = d1j * vbld_inv(j+nres)
24223 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24224
24225        DO k = 1, 3
24226         hawk = (erhead_tail(k,1) + &
24227         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24228 !        facd1=0.0d0
24229 !        facd2=0.0d0
24230         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24231         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24232                    - dGCLdR * pom &
24233                    - dPOLdR1 *  (erhead_tail(k,1))
24234 !     &             - dGLJdR * pom
24235
24236         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24237         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24238                    + dGCLdR * pom  &
24239                    + dPOLdR1 * (erhead_tail(k,1))
24240 !     &             + dGLJdR * pom
24241
24242
24243         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24244                   - dGCLdR * erhead(k) &
24245                   - dPOLdR1 * erhead_tail(k,1)
24246 !     &             - dGLJdR * erhead(k)
24247
24248         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24249                   + dGCLdR * erhead(k)  &
24250                   + dPOLdR1 * erhead_tail(k,1)
24251 !     &             + dGLJdR * erhead(k)
24252
24253        END DO
24254        endif
24255 !       print *,i,j,evdwij,epol,Fcav,ECL
24256        escbase=escbase+evdwij+epol+Fcav+ECL
24257        call sc_grad_scbase
24258          enddo
24259       enddo
24260
24261       return
24262       end subroutine eprot_sc_base
24263       SUBROUTINE sc_grad_scbase
24264       use calc_data
24265
24266        real (kind=8) :: dcosom1(3),dcosom2(3)
24267        eom1  =    &
24268               eps2der * eps2rt_om1   &
24269             - 2.0D0 * alf1 * eps3der &
24270             + sigder * sigsq_om1     &
24271             + dCAVdOM1               &
24272             + dGCLdOM1               &
24273             + dPOLdOM1
24274
24275        eom2  =  &
24276               eps2der * eps2rt_om2   &
24277             + 2.0D0 * alf2 * eps3der &
24278             + sigder * sigsq_om2     &
24279             + dCAVdOM2               &
24280             + dGCLdOM2               &
24281             + dPOLdOM2
24282
24283        eom12 =    &
24284               evdwij  * eps1_om12     &
24285             + eps2der * eps2rt_om12   &
24286             - 2.0D0 * alf12 * eps3der &
24287             + sigder *sigsq_om12      &
24288             + dCAVdOM12               &
24289             + dGCLdOM12
24290
24291 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24292 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24293 !               gg(1),gg(2),"rozne"
24294        DO k = 1, 3
24295         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24296         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24297         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24298         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24299                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24300                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24301         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24302                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24303                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24304         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24305         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24306        END DO
24307        RETURN
24308       END SUBROUTINE sc_grad_scbase
24309
24310
24311       subroutine epep_sc_base(epepbase)
24312       use calc_data
24313       logical :: lprn
24314 !el local variables
24315       integer :: iint,itypi,itypi1,itypj,subchap
24316       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24317       real(kind=8) :: evdw,sig0ij
24318       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24319                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24320                     sslipi,sslipj,faclip
24321       integer :: ii
24322       real(kind=8) :: fracinbuf
24323        real (kind=8) :: epepbase
24324        real (kind=8),dimension(4):: ener
24325        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24326        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24327         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24328         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24329         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24330         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24331         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24332         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24333        real(kind=8),dimension(3,2)::chead,erhead_tail
24334        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24335        integer troll
24336        eps_out=80.0d0
24337        epepbase=0.0d0
24338 !       do i=1,nres_molec(1)-1
24339         do i=ibond_start,ibond_end
24340         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24341 !C        itypi  = itype(i,1)
24342         dxi    = dc_norm(1,i)
24343         dyi    = dc_norm(2,i)
24344         dzi    = dc_norm(3,i)
24345 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24346         dsci_inv = vbld_inv(i+1)/2.0
24347         xi=(c(1,i)+c(1,i+1))/2.0
24348         yi=(c(2,i)+c(2,i+1))/2.0
24349         zi=(c(3,i)+c(3,i+1))/2.0
24350         xi=mod(xi,boxxsize)
24351          if (xi.lt.0) xi=xi+boxxsize
24352         yi=mod(yi,boxysize)
24353          if (yi.lt.0) yi=yi+boxysize
24354         zi=mod(zi,boxzsize)
24355          if (zi.lt.0) zi=zi+boxzsize
24356          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24357            itypj= itype(j,2)
24358            if (itype(j,2).eq.ntyp1_molec(2))cycle
24359            xj=c(1,j+nres)
24360            yj=c(2,j+nres)
24361            zj=c(3,j+nres)
24362            xj=dmod(xj,boxxsize)
24363            if (xj.lt.0) xj=xj+boxxsize
24364            yj=dmod(yj,boxysize)
24365            if (yj.lt.0) yj=yj+boxysize
24366            zj=dmod(zj,boxzsize)
24367            if (zj.lt.0) zj=zj+boxzsize
24368           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24369           xj_safe=xj
24370           yj_safe=yj
24371           zj_safe=zj
24372           subchap=0
24373
24374           do xshift=-1,1
24375           do yshift=-1,1
24376           do zshift=-1,1
24377           xj=xj_safe+xshift*boxxsize
24378           yj=yj_safe+yshift*boxysize
24379           zj=zj_safe+zshift*boxzsize
24380           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24381           if(dist_temp.lt.dist_init) then
24382             dist_init=dist_temp
24383             xj_temp=xj
24384             yj_temp=yj
24385             zj_temp=zj
24386             subchap=1
24387           endif
24388           enddo
24389           enddo
24390           enddo
24391           if (subchap.eq.1) then
24392           xj=xj_temp-xi
24393           yj=yj_temp-yi
24394           zj=zj_temp-zi
24395           else
24396           xj=xj_safe-xi
24397           yj=yj_safe-yi
24398           zj=zj_safe-zi
24399           endif
24400           dxj = dc_norm( 1, nres+j )
24401           dyj = dc_norm( 2, nres+j )
24402           dzj = dc_norm( 3, nres+j )
24403 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24404 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24405
24406 ! Gay-berne var's
24407           sig0ij = sigma_pepbase(itypj )
24408           chi1   = chi_pepbase(itypj,1 )
24409           chi2   = chi_pepbase(itypj,2 )
24410 !          chi1=0.0d0
24411 !          chi2=0.0d0
24412           chi12  = chi1 * chi2
24413           chip1  = chipp_pepbase(itypj,1 )
24414           chip2  = chipp_pepbase(itypj,2 )
24415 !          chip1=0.0d0
24416 !          chip2=0.0d0
24417           chip12 = chip1 * chip2
24418           chis1 = chis_pepbase(itypj,1)
24419           chis2 = chis_pepbase(itypj,2)
24420           chis12 = chis1 * chis2
24421           sig1 = sigmap1_pepbase(itypj)
24422           sig2 = sigmap2_pepbase(itypj)
24423 !       write (*,*) "sig1 = ", sig1
24424 !       write (*,*) "sig2 = ", sig2
24425        DO k = 1,3
24426 ! location of polar head is computed by taking hydrophobic centre
24427 ! and moving by a d1 * dc_norm vector
24428 ! see unres publications for very informative images
24429         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24430 ! + d1i * dc_norm(k, i+nres)
24431         chead(k,2) = c(k, j+nres)
24432 ! + d1j * dc_norm(k, j+nres)
24433 ! distance
24434 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24435 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24436         Rhead_distance(k) = chead(k,2) - chead(k,1)
24437 !        print *,gvdwc_pepbase(k,i)
24438
24439        END DO
24440        Rhead = dsqrt( &
24441           (Rhead_distance(1)*Rhead_distance(1)) &
24442         + (Rhead_distance(2)*Rhead_distance(2)) &
24443         + (Rhead_distance(3)*Rhead_distance(3)))
24444
24445 ! alpha factors from Fcav/Gcav
24446           b1 = alphasur_pepbase(1,itypj)
24447 !          b1=0.0d0
24448           b2 = alphasur_pepbase(2,itypj)
24449           b3 = alphasur_pepbase(3,itypj)
24450           b4 = alphasur_pepbase(4,itypj)
24451           alf1   = 0.0d0
24452           alf2   = 0.0d0
24453           alf12  = 0.0d0
24454           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24455 !          print *,i,j,rrij
24456           rij  = dsqrt(rrij)
24457 !----------------------------
24458        evdwij = 0.0d0
24459        ECL = 0.0d0
24460        Elj = 0.0d0
24461        Equad = 0.0d0
24462        Epol = 0.0d0
24463        Fcav=0.0d0
24464        eheadtail = 0.0d0
24465        dGCLdOM1 = 0.0d0
24466        dGCLdOM2 = 0.0d0
24467        dGCLdOM12 = 0.0d0
24468        dPOLdOM1 = 0.0d0
24469        dPOLdOM2 = 0.0d0
24470           Fcav = 0.0d0
24471           dFdR = 0.0d0
24472           dCAVdOM1  = 0.0d0
24473           dCAVdOM2  = 0.0d0
24474           dCAVdOM12 = 0.0d0
24475           dscj_inv = vbld_inv(j+nres)
24476           CALL sc_angular
24477 ! this should be in elgrad_init but om's are calculated by sc_angular
24478 ! which in turn is used by older potentials
24479 ! om = omega, sqom = om^2
24480           sqom1  = om1 * om1
24481           sqom2  = om2 * om2
24482           sqom12 = om12 * om12
24483
24484 ! now we calculate EGB - Gey-Berne
24485 ! It will be summed up in evdwij and saved in evdw
24486           sigsq     = 1.0D0  / sigsq
24487           sig       = sig0ij * dsqrt(sigsq)
24488           rij_shift = 1.0/rij - sig + sig0ij
24489           IF (rij_shift.le.0.0D0) THEN
24490            evdw = 1.0D20
24491            RETURN
24492           END IF
24493           sigder = -sig * sigsq
24494           rij_shift = 1.0D0 / rij_shift
24495           fac       = rij_shift**expon
24496           c1        = fac  * fac * aa_pepbase(itypj)
24497 !          c1        = 0.0d0
24498           c2        = fac  * bb_pepbase(itypj)
24499 !          c2        = 0.0d0
24500           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24501           eps2der   = eps3rt * evdwij
24502           eps3der   = eps2rt * evdwij
24503 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24504           evdwij    = eps2rt * eps3rt * evdwij
24505           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24506           fac    = -expon * (c1 + evdwij) * rij_shift
24507           sigder = fac * sigder
24508 !          fac    = rij * fac
24509 ! Calculate distance derivative
24510           gg(1) =  fac
24511           gg(2) =  fac
24512           gg(3) =  fac
24513           fac = chis1 * sqom1 + chis2 * sqom2 &
24514           - 2.0d0 * chis12 * om1 * om2 * om12
24515 ! we will use pom later in Gcav, so dont mess with it!
24516           pom = 1.0d0 - chis1 * chis2 * sqom12
24517           Lambf = (1.0d0 - (fac / pom))
24518           Lambf = dsqrt(Lambf)
24519           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24520 !       write (*,*) "sparrow = ", sparrow
24521           Chif = 1.0d0/rij * sparrow
24522           ChiLambf = Chif * Lambf
24523           eagle = dsqrt(ChiLambf)
24524           bat = ChiLambf ** 11.0d0
24525           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24526           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24527           botsq = bot * bot
24528           Fcav = top / bot
24529 !          print *,i,j,Fcav
24530           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24531           dbot = 12.0d0 * b4 * bat * Lambf
24532           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24533 !       dFdR = 0.0d0
24534 !      write (*,*) "dFcav/dR = ", dFdR
24535           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24536           dbot = 12.0d0 * b4 * bat * Chif
24537           eagle = Lambf * pom
24538           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24539           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24540           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24541               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24542
24543           dFdL = ((dtop * bot - top * dbot) / botsq)
24544 !       dFdL = 0.0d0
24545           dCAVdOM1  = dFdL * ( dFdOM1 )
24546           dCAVdOM2  = dFdL * ( dFdOM2 )
24547           dCAVdOM12 = dFdL * ( dFdOM12 )
24548
24549           ertail(1) = xj*rij
24550           ertail(2) = yj*rij
24551           ertail(3) = zj*rij
24552        DO k = 1, 3
24553 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24554 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24555         pom = ertail(k)
24556 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24557         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24558                   - (( dFdR + gg(k) ) * pom)/2.0
24559 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24560 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24561 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24562 !     &             - ( dFdR * pom )
24563         pom = ertail(k)
24564 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24565         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24566                   + (( dFdR + gg(k) ) * pom)
24567 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24568 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24569 !c!     &             + ( dFdR * pom )
24570
24571         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24572                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24573 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24574
24575 !c!     &             - ( dFdR * ertail(k))
24576
24577         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24578                   + (( dFdR + gg(k) ) * ertail(k))
24579 !c!     &             + ( dFdR * ertail(k))
24580
24581         gg(k) = 0.0d0
24582 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24583 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24584       END DO
24585
24586
24587        w1 = wdipdip_pepbase(1,itypj)
24588        w2 = -wdipdip_pepbase(3,itypj)/2.0
24589        w3 = wdipdip_pepbase(2,itypj)
24590 !       w1=0.0d0
24591 !       w2=0.0d0
24592 !c!-------------------------------------------------------------------
24593 !c! ECL
24594 !       w3=0.0d0
24595        fac = (om12 - 3.0d0 * om1 * om2)
24596        c1 = (w1 / (Rhead**3.0d0)) * fac
24597        c2 = (w2 / Rhead ** 6.0d0)  &
24598          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24599        c3= (w3/ Rhead ** 6.0d0)  &
24600          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24601
24602        ECL = c1 - c2 + c3
24603
24604        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24605        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24606          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24607        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24608          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24609
24610        dGCLdR = c1 - c2 + c3
24611 !c! dECL/dom1
24612        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24613        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24614          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24615        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24616        dGCLdOM1 = c1 - c2 + c3
24617 !c! dECL/dom2
24618        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24619        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24620          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24621        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24622
24623        dGCLdOM2 = c1 - c2 + c3
24624 !c! dECL/dom12
24625        c1 = w1 / (Rhead ** 3.0d0)
24626        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24627        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24628        dGCLdOM12 = c1 - c2 + c3
24629        DO k= 1, 3
24630         erhead(k) = Rhead_distance(k)/Rhead
24631        END DO
24632        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24633        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24634 !       facd1 = d1 * vbld_inv(i+nres)
24635 !       facd2 = d2 * vbld_inv(j+nres)
24636        DO k = 1, 3
24637
24638 !        pom = erhead(k)
24639 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24640 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24641 !                  - dGCLdR * pom
24642         pom = erhead(k)
24643 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24644         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24645                   + dGCLdR * pom
24646
24647         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24648                   - dGCLdR * erhead(k)/2.0d0
24649 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24650         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24651                   - dGCLdR * erhead(k)/2.0d0
24652 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24653         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24654                   + dGCLdR * erhead(k)
24655        END DO
24656 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24657        epepbase=epepbase+evdwij+Fcav+ECL
24658        call sc_grad_pepbase
24659        enddo
24660        enddo
24661       END SUBROUTINE epep_sc_base
24662       SUBROUTINE sc_grad_pepbase
24663       use calc_data
24664
24665        real (kind=8) :: dcosom1(3),dcosom2(3)
24666        eom1  =    &
24667               eps2der * eps2rt_om1   &
24668             - 2.0D0 * alf1 * eps3der &
24669             + sigder * sigsq_om1     &
24670             + dCAVdOM1               &
24671             + dGCLdOM1               &
24672             + dPOLdOM1
24673
24674        eom2  =  &
24675               eps2der * eps2rt_om2   &
24676             + 2.0D0 * alf2 * eps3der &
24677             + sigder * sigsq_om2     &
24678             + dCAVdOM2               &
24679             + dGCLdOM2               &
24680             + dPOLdOM2
24681
24682        eom12 =    &
24683               evdwij  * eps1_om12     &
24684             + eps2der * eps2rt_om12   &
24685             - 2.0D0 * alf12 * eps3der &
24686             + sigder *sigsq_om12      &
24687             + dCAVdOM12               &
24688             + dGCLdOM12
24689 !        om12=0.0
24690 !        eom12=0.0
24691 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24692 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24693 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24694 !                 *dsci_inv*2.0
24695 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24696 !               gg(1),gg(2),"rozne"
24697        DO k = 1, 3
24698         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24699         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24700         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24701         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24702                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24703                  *dsci_inv*2.0 &
24704                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24705         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24706                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24707                  *dsci_inv*2.0 &
24708                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24709 !         print *,eom12,eom2,om12,om2
24710 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24711 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24712         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24713                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24714                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24715         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24716        END DO
24717        RETURN
24718       END SUBROUTINE sc_grad_pepbase
24719       subroutine eprot_sc_phosphate(escpho)
24720       use calc_data
24721 !      implicit real*8 (a-h,o-z)
24722 !      include 'DIMENSIONS'
24723 !      include 'COMMON.GEO'
24724 !      include 'COMMON.VAR'
24725 !      include 'COMMON.LOCAL'
24726 !      include 'COMMON.CHAIN'
24727 !      include 'COMMON.DERIV'
24728 !      include 'COMMON.NAMES'
24729 !      include 'COMMON.INTERACT'
24730 !      include 'COMMON.IOUNITS'
24731 !      include 'COMMON.CALC'
24732 !      include 'COMMON.CONTROL'
24733 !      include 'COMMON.SBRIDGE'
24734       logical :: lprn
24735 !el local variables
24736       integer :: iint,itypi,itypi1,itypj,subchap
24737       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24738       real(kind=8) :: evdw,sig0ij
24739       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24740                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24741                     sslipi,sslipj,faclip,alpha_sco
24742       integer :: ii
24743       real(kind=8) :: fracinbuf
24744        real (kind=8) :: escpho
24745        real (kind=8),dimension(4):: ener
24746        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24747        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24748         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24749         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24750         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24751         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24752         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24753         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24754        real(kind=8),dimension(3,2)::chead,erhead_tail
24755        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24756        integer troll
24757        eps_out=80.0d0
24758        escpho=0.0d0
24759 !       do i=1,nres_molec(1)
24760         do i=ibond_start,ibond_end
24761         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24762         itypi  = itype(i,1)
24763         dxi    = dc_norm(1,nres+i)
24764         dyi    = dc_norm(2,nres+i)
24765         dzi    = dc_norm(3,nres+i)
24766         dsci_inv = vbld_inv(i+nres)
24767         xi=c(1,nres+i)
24768         yi=c(2,nres+i)
24769         zi=c(3,nres+i)
24770         xi=mod(xi,boxxsize)
24771          if (xi.lt.0) xi=xi+boxxsize
24772         yi=mod(yi,boxysize)
24773          if (yi.lt.0) yi=yi+boxysize
24774         zi=mod(zi,boxzsize)
24775          if (zi.lt.0) zi=zi+boxzsize
24776          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24777            itypj= itype(j,2)
24778            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24779             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24780            xj=(c(1,j)+c(1,j+1))/2.0
24781            yj=(c(2,j)+c(2,j+1))/2.0
24782            zj=(c(3,j)+c(3,j+1))/2.0
24783            xj=dmod(xj,boxxsize)
24784            if (xj.lt.0) xj=xj+boxxsize
24785            yj=dmod(yj,boxysize)
24786            if (yj.lt.0) yj=yj+boxysize
24787            zj=dmod(zj,boxzsize)
24788            if (zj.lt.0) zj=zj+boxzsize
24789           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24790           xj_safe=xj
24791           yj_safe=yj
24792           zj_safe=zj
24793           subchap=0
24794           do xshift=-1,1
24795           do yshift=-1,1
24796           do zshift=-1,1
24797           xj=xj_safe+xshift*boxxsize
24798           yj=yj_safe+yshift*boxysize
24799           zj=zj_safe+zshift*boxzsize
24800           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24801           if(dist_temp.lt.dist_init) then
24802             dist_init=dist_temp
24803             xj_temp=xj
24804             yj_temp=yj
24805             zj_temp=zj
24806             subchap=1
24807           endif
24808           enddo
24809           enddo
24810           enddo
24811           if (subchap.eq.1) then
24812           xj=xj_temp-xi
24813           yj=yj_temp-yi
24814           zj=zj_temp-zi
24815           else
24816           xj=xj_safe-xi
24817           yj=yj_safe-yi
24818           zj=zj_safe-zi
24819           endif
24820           dxj = dc_norm( 1,j )
24821           dyj = dc_norm( 2,j )
24822           dzj = dc_norm( 3,j )
24823           dscj_inv = vbld_inv(j+1)
24824
24825 ! Gay-berne var's
24826           sig0ij = sigma_scpho(itypi )
24827           chi1   = chi_scpho(itypi,1 )
24828           chi2   = chi_scpho(itypi,2 )
24829 !          chi1=0.0d0
24830 !          chi2=0.0d0
24831           chi12  = chi1 * chi2
24832           chip1  = chipp_scpho(itypi,1 )
24833           chip2  = chipp_scpho(itypi,2 )
24834 !          chip1=0.0d0
24835 !          chip2=0.0d0
24836           chip12 = chip1 * chip2
24837           chis1 = chis_scpho(itypi,1)
24838           chis2 = chis_scpho(itypi,2)
24839           chis12 = chis1 * chis2
24840           sig1 = sigmap1_scpho(itypi)
24841           sig2 = sigmap2_scpho(itypi)
24842 !       write (*,*) "sig1 = ", sig1
24843 !       write (*,*) "sig1 = ", sig1
24844 !       write (*,*) "sig2 = ", sig2
24845 ! alpha factors from Fcav/Gcav
24846           alf1   = 0.0d0
24847           alf2   = 0.0d0
24848           alf12  = 0.0d0
24849           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24850
24851           b1 = alphasur_scpho(1,itypi)
24852 !          b1=0.0d0
24853           b2 = alphasur_scpho(2,itypi)
24854           b3 = alphasur_scpho(3,itypi)
24855           b4 = alphasur_scpho(4,itypi)
24856 ! used to determine whether we want to do quadrupole calculations
24857 ! used by Fgb
24858        eps_in = epsintab_scpho(itypi)
24859        if (eps_in.eq.0.0) eps_in=1.0
24860        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24861 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24862 !-------------------------------------------------------------------
24863 ! tail location and distance calculations
24864           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24865           d1j = 0.0
24866        DO k = 1,3
24867 ! location of polar head is computed by taking hydrophobic centre
24868 ! and moving by a d1 * dc_norm vector
24869 ! see unres publications for very informative images
24870         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24871         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24872 ! distance
24873 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24874 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24875         Rhead_distance(k) = chead(k,2) - chead(k,1)
24876        END DO
24877 ! pitagoras (root of sum of squares)
24878        Rhead = dsqrt( &
24879           (Rhead_distance(1)*Rhead_distance(1)) &
24880         + (Rhead_distance(2)*Rhead_distance(2)) &
24881         + (Rhead_distance(3)*Rhead_distance(3)))
24882        Rhead_sq=Rhead**2.0
24883 !-------------------------------------------------------------------
24884 ! zero everything that should be zero'ed
24885        evdwij = 0.0d0
24886        ECL = 0.0d0
24887        Elj = 0.0d0
24888        Equad = 0.0d0
24889        Epol = 0.0d0
24890        Fcav=0.0d0
24891        eheadtail = 0.0d0
24892        dGCLdR=0.0d0
24893        dGCLdOM1 = 0.0d0
24894        dGCLdOM2 = 0.0d0
24895        dGCLdOM12 = 0.0d0
24896        dPOLdOM1 = 0.0d0
24897        dPOLdOM2 = 0.0d0
24898           Fcav = 0.0d0
24899           dFdR = 0.0d0
24900           dCAVdOM1  = 0.0d0
24901           dCAVdOM2  = 0.0d0
24902           dCAVdOM12 = 0.0d0
24903           dscj_inv = vbld_inv(j+1)/2.0
24904 !dhead_scbasej(itypi,itypj)
24905 !          print *,i,j,dscj_inv,dsci_inv
24906 ! rij holds 1/(distance of Calpha atoms)
24907           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24908           rij  = dsqrt(rrij)
24909 !----------------------------
24910           CALL sc_angular
24911 ! this should be in elgrad_init but om's are calculated by sc_angular
24912 ! which in turn is used by older potentials
24913 ! om = omega, sqom = om^2
24914           sqom1  = om1 * om1
24915           sqom2  = om2 * om2
24916           sqom12 = om12 * om12
24917
24918 ! now we calculate EGB - Gey-Berne
24919 ! It will be summed up in evdwij and saved in evdw
24920           sigsq     = 1.0D0  / sigsq
24921           sig       = sig0ij * dsqrt(sigsq)
24922 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24923           rij_shift = 1.0/rij - sig + sig0ij
24924           IF (rij_shift.le.0.0D0) THEN
24925            evdw = 1.0D20
24926            RETURN
24927           END IF
24928           sigder = -sig * sigsq
24929           rij_shift = 1.0D0 / rij_shift
24930           fac       = rij_shift**expon
24931           c1        = fac  * fac * aa_scpho(itypi)
24932 !          c1        = 0.0d0
24933           c2        = fac  * bb_scpho(itypi)
24934 !          c2        = 0.0d0
24935           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24936           eps2der   = eps3rt * evdwij
24937           eps3der   = eps2rt * evdwij
24938 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24939           evdwij    = eps2rt * eps3rt * evdwij
24940           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24941           fac    = -expon * (c1 + evdwij) * rij_shift
24942           sigder = fac * sigder
24943 !          fac    = rij * fac
24944 ! Calculate distance derivative
24945           gg(1) =  fac
24946           gg(2) =  fac
24947           gg(3) =  fac
24948           fac = chis1 * sqom1 + chis2 * sqom2 &
24949           - 2.0d0 * chis12 * om1 * om2 * om12
24950 ! we will use pom later in Gcav, so dont mess with it!
24951           pom = 1.0d0 - chis1 * chis2 * sqom12
24952           Lambf = (1.0d0 - (fac / pom))
24953           Lambf = dsqrt(Lambf)
24954           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24955 !       write (*,*) "sparrow = ", sparrow
24956           Chif = 1.0d0/rij * sparrow
24957           ChiLambf = Chif * Lambf
24958           eagle = dsqrt(ChiLambf)
24959           bat = ChiLambf ** 11.0d0
24960           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24961           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24962           botsq = bot * bot
24963           Fcav = top / bot
24964           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24965           dbot = 12.0d0 * b4 * bat * Lambf
24966           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24967 !       dFdR = 0.0d0
24968 !      write (*,*) "dFcav/dR = ", dFdR
24969           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24970           dbot = 12.0d0 * b4 * bat * Chif
24971           eagle = Lambf * pom
24972           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24973           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24974           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24975               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24976
24977           dFdL = ((dtop * bot - top * dbot) / botsq)
24978 !       dFdL = 0.0d0
24979           dCAVdOM1  = dFdL * ( dFdOM1 )
24980           dCAVdOM2  = dFdL * ( dFdOM2 )
24981           dCAVdOM12 = dFdL * ( dFdOM12 )
24982
24983           ertail(1) = xj*rij
24984           ertail(2) = yj*rij
24985           ertail(3) = zj*rij
24986        DO k = 1, 3
24987 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24988 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24989 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24990
24991         pom = ertail(k)
24992 !        print *,pom,gg(k),dFdR
24993 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24994         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24995                   - (( dFdR + gg(k) ) * pom)
24996 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24997 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24998 !     &             - ( dFdR * pom )
24999 !        pom = ertail(k)
25000 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25001 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25002 !                  + (( dFdR + gg(k) ) * pom)
25003 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25004 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25005 !c!     &             + ( dFdR * pom )
25006
25007         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25008                   - (( dFdR + gg(k) ) * ertail(k))
25009 !c!     &             - ( dFdR * ertail(k))
25010
25011         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25012                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25013
25014         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25015                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25016
25017 !c!     &             + ( dFdR * ertail(k))
25018
25019         gg(k) = 0.0d0
25020         ENDDO
25021 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25022 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25023 !      alphapol1 = alphapol_scpho(itypi)
25024        if (wqq_scpho(itypi).ne.0.0) then
25025        Qij=wqq_scpho(itypi)/eps_in
25026        alpha_sco=1.d0/alphi_scpho(itypi)
25027 !       Qij=0.0
25028        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25029 !c! derivative of Ecl is Gcl...
25030        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25031                 (Rhead*alpha_sco+1) ) / Rhead_sq
25032        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25033        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25034        w1        = wqdip_scpho(1,itypi)
25035        w2        = wqdip_scpho(2,itypi)
25036 !       w1=0.0d0
25037 !       w2=0.0d0
25038 !       pis       = sig0head_scbase(itypi,itypj)
25039 !       eps_head   = epshead_scbase(itypi,itypj)
25040 !c!-------------------------------------------------------------------
25041
25042 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25043 !c!     &        +dhead(1,1,itypi,itypj))**2))
25044 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25045 !c!     &        +dhead(2,1,itypi,itypj))**2))
25046
25047 !c!-------------------------------------------------------------------
25048 !c! ecl
25049        sparrow  = w1  *  om1
25050        hawk     = w2 *  (1.0d0 - sqom2)
25051        Ecl = sparrow / Rhead**2.0d0 &
25052            - hawk    / Rhead**4.0d0
25053 !c!-------------------------------------------------------------------
25054        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25055            1.0/rij,sparrow
25056
25057 !c! derivative of ecl is Gcl
25058 !c! dF/dr part
25059        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25060                 + 4.0d0 * hawk    / Rhead**5.0d0
25061 !c! dF/dom1
25062        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25063 !c! dF/dom2
25064        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25065        endif
25066
25067 !c--------------------------------------------------------------------
25068 !c Polarization energy
25069 !c Epol
25070        R1 = 0.0d0
25071        DO k = 1, 3
25072 !c! Calculate head-to-tail distances tail is center of side-chain
25073         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25074        END DO
25075 !c! Pitagoras
25076        R1 = dsqrt(R1)
25077
25078       alphapol1 = alphapol_scpho(itypi)
25079 !      alphapol1=0.0
25080        MomoFac1 = (1.0d0 - chi2 * sqom1)
25081        RR1  = R1 * R1 / MomoFac1
25082        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25083 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25084        fgb1 = sqrt( RR1 + a12sq * ee1)
25085 !       eps_inout_fac=0.0d0
25086        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25087 ! derivative of Epol is Gpol...
25088        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25089                 / (fgb1 ** 5.0d0)
25090        dFGBdR1 = ( (R1 / MomoFac1) &
25091              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25092              / ( 2.0d0 * fgb1 )
25093        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25094                * (2.0d0 - 0.5d0 * ee1) ) &
25095                / (2.0d0 * fgb1)
25096        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25097 !       dPOLdR1 = 0.0d0
25098 !       dPOLdOM1 = 0.0d0
25099        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25100                * (2.0d0 - 0.5d0 * ee1) ) &
25101                / (2.0d0 * fgb1)
25102
25103        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25104        dPOLdOM2 = 0.0
25105        DO k = 1, 3
25106         erhead(k) = Rhead_distance(k)/Rhead
25107         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25108        END DO
25109
25110        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25111        erdxj = scalar( erhead(1), dC_norm(1,j) )
25112        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25113 !       bat=0.0d0
25114        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25115        facd1 = d1i * vbld_inv(i+nres)
25116        facd2 = d1j * vbld_inv(j)
25117 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25118
25119        DO k = 1, 3
25120         hawk = (erhead_tail(k,1) + &
25121         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25122 !        facd1=0.0d0
25123 !        facd2=0.0d0
25124 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25125 !                pom,(erhead_tail(k,1))
25126
25127 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25128         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25129         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25130                    - dGCLdR * pom &
25131                    - dPOLdR1 *  (erhead_tail(k,1))
25132 !     &             - dGLJdR * pom
25133
25134         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25135 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25136 !                   + dGCLdR * pom  &
25137 !                   + dPOLdR1 * (erhead_tail(k,1))
25138 !     &             + dGLJdR * pom
25139
25140
25141         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25142                   - dGCLdR * erhead(k) &
25143                   - dPOLdR1 * erhead_tail(k,1)
25144 !     &             - dGLJdR * erhead(k)
25145
25146         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25147                   + (dGCLdR * erhead(k)  &
25148                   + dPOLdR1 * erhead_tail(k,1))/2.0
25149         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25150                   + (dGCLdR * erhead(k)  &
25151                   + dPOLdR1 * erhead_tail(k,1))/2.0
25152
25153 !     &             + dGLJdR * erhead(k)
25154 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25155
25156        END DO
25157 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25158        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25159         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25160        escpho=escpho+evdwij+epol+Fcav+ECL
25161        call sc_grad_scpho
25162          enddo
25163
25164       enddo
25165
25166       return
25167       end subroutine eprot_sc_phosphate
25168       SUBROUTINE sc_grad_scpho
25169       use calc_data
25170
25171        real (kind=8) :: dcosom1(3),dcosom2(3)
25172        eom1  =    &
25173               eps2der * eps2rt_om1   &
25174             - 2.0D0 * alf1 * eps3der &
25175             + sigder * sigsq_om1     &
25176             + dCAVdOM1               &
25177             + dGCLdOM1               &
25178             + dPOLdOM1
25179
25180        eom2  =  &
25181               eps2der * eps2rt_om2   &
25182             + 2.0D0 * alf2 * eps3der &
25183             + sigder * sigsq_om2     &
25184             + dCAVdOM2               &
25185             + dGCLdOM2               &
25186             + dPOLdOM2
25187
25188        eom12 =    &
25189               evdwij  * eps1_om12     &
25190             + eps2der * eps2rt_om12   &
25191             - 2.0D0 * alf12 * eps3der &
25192             + sigder *sigsq_om12      &
25193             + dCAVdOM12               &
25194             + dGCLdOM12
25195 !        om12=0.0
25196 !        eom12=0.0
25197 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25198 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25199 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25200 !                 *dsci_inv*2.0
25201 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25202 !               gg(1),gg(2),"rozne"
25203        DO k = 1, 3
25204         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25205         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25206         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25207         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25208                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25209                  *dscj_inv*2.0 &
25210                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25211         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25212                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25213                  *dscj_inv*2.0 &
25214                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25215         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25216                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25217                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25218
25219 !         print *,eom12,eom2,om12,om2
25220 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25221 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25222 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25223 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25224 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25225         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25226        END DO
25227        RETURN
25228       END SUBROUTINE sc_grad_scpho
25229       subroutine eprot_pep_phosphate(epeppho)
25230       use calc_data
25231 !      implicit real*8 (a-h,o-z)
25232 !      include 'DIMENSIONS'
25233 !      include 'COMMON.GEO'
25234 !      include 'COMMON.VAR'
25235 !      include 'COMMON.LOCAL'
25236 !      include 'COMMON.CHAIN'
25237 !      include 'COMMON.DERIV'
25238 !      include 'COMMON.NAMES'
25239 !      include 'COMMON.INTERACT'
25240 !      include 'COMMON.IOUNITS'
25241 !      include 'COMMON.CALC'
25242 !      include 'COMMON.CONTROL'
25243 !      include 'COMMON.SBRIDGE'
25244       logical :: lprn
25245 !el local variables
25246       integer :: iint,itypi,itypi1,itypj,subchap
25247       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25248       real(kind=8) :: evdw,sig0ij
25249       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25250                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25251                     sslipi,sslipj,faclip
25252       integer :: ii
25253       real(kind=8) :: fracinbuf
25254        real (kind=8) :: epeppho
25255        real (kind=8),dimension(4):: ener
25256        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25257        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25258         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25259         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25260         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25261         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25262         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25263         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25264        real(kind=8),dimension(3,2)::chead,erhead_tail
25265        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25266        integer troll
25267        real (kind=8) :: dcosom1(3),dcosom2(3)
25268        epeppho=0.0d0
25269 !       do i=1,nres_molec(1)
25270         do i=ibond_start,ibond_end
25271         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25272         itypi  = itype(i,1)
25273         dsci_inv = vbld_inv(i+1)/2.0
25274         dxi    = dc_norm(1,i)
25275         dyi    = dc_norm(2,i)
25276         dzi    = dc_norm(3,i)
25277         xi=(c(1,i)+c(1,i+1))/2.0
25278         yi=(c(2,i)+c(2,i+1))/2.0
25279         zi=(c(3,i)+c(3,i+1))/2.0
25280         xi=mod(xi,boxxsize)
25281          if (xi.lt.0) xi=xi+boxxsize
25282         yi=mod(yi,boxysize)
25283          if (yi.lt.0) yi=yi+boxysize
25284         zi=mod(zi,boxzsize)
25285          if (zi.lt.0) zi=zi+boxzsize
25286          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25287            itypj= itype(j,2)
25288            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25289             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25290            xj=(c(1,j)+c(1,j+1))/2.0
25291            yj=(c(2,j)+c(2,j+1))/2.0
25292            zj=(c(3,j)+c(3,j+1))/2.0
25293            xj=dmod(xj,boxxsize)
25294            if (xj.lt.0) xj=xj+boxxsize
25295            yj=dmod(yj,boxysize)
25296            if (yj.lt.0) yj=yj+boxysize
25297            zj=dmod(zj,boxzsize)
25298            if (zj.lt.0) zj=zj+boxzsize
25299           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25300           xj_safe=xj
25301           yj_safe=yj
25302           zj_safe=zj
25303           subchap=0
25304           do xshift=-1,1
25305           do yshift=-1,1
25306           do zshift=-1,1
25307           xj=xj_safe+xshift*boxxsize
25308           yj=yj_safe+yshift*boxysize
25309           zj=zj_safe+zshift*boxzsize
25310           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25311           if(dist_temp.lt.dist_init) then
25312             dist_init=dist_temp
25313             xj_temp=xj
25314             yj_temp=yj
25315             zj_temp=zj
25316             subchap=1
25317           endif
25318           enddo
25319           enddo
25320           enddo
25321           if (subchap.eq.1) then
25322           xj=xj_temp-xi
25323           yj=yj_temp-yi
25324           zj=zj_temp-zi
25325           else
25326           xj=xj_safe-xi
25327           yj=yj_safe-yi
25328           zj=zj_safe-zi
25329           endif
25330           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25331           rij  = dsqrt(rrij)
25332           dxj = dc_norm( 1,j )
25333           dyj = dc_norm( 2,j )
25334           dzj = dc_norm( 3,j )
25335           dscj_inv = vbld_inv(j+1)/2.0
25336 ! Gay-berne var's
25337           sig0ij = sigma_peppho
25338 !          chi1=0.0d0
25339 !          chi2=0.0d0
25340           chi12  = chi1 * chi2
25341 !          chip1=0.0d0
25342 !          chip2=0.0d0
25343           chip12 = chip1 * chip2
25344 !          chis1 = 0.0d0
25345 !          chis2 = 0.0d0
25346           chis12 = chis1 * chis2
25347           sig1 = sigmap1_peppho
25348           sig2 = sigmap2_peppho
25349 !       write (*,*) "sig1 = ", sig1
25350 !       write (*,*) "sig1 = ", sig1
25351 !       write (*,*) "sig2 = ", sig2
25352 ! alpha factors from Fcav/Gcav
25353           alf1   = 0.0d0
25354           alf2   = 0.0d0
25355           alf12  = 0.0d0
25356           b1 = alphasur_peppho(1)
25357 !          b1=0.0d0
25358           b2 = alphasur_peppho(2)
25359           b3 = alphasur_peppho(3)
25360           b4 = alphasur_peppho(4)
25361           CALL sc_angular
25362        sqom1=om1*om1
25363        evdwij = 0.0d0
25364        ECL = 0.0d0
25365        Elj = 0.0d0
25366        Equad = 0.0d0
25367        Epol = 0.0d0
25368        Fcav=0.0d0
25369        eheadtail = 0.0d0
25370        dGCLdR=0.0d0
25371        dGCLdOM1 = 0.0d0
25372        dGCLdOM2 = 0.0d0
25373        dGCLdOM12 = 0.0d0
25374        dPOLdOM1 = 0.0d0
25375        dPOLdOM2 = 0.0d0
25376           Fcav = 0.0d0
25377           dFdR = 0.0d0
25378           dCAVdOM1  = 0.0d0
25379           dCAVdOM2  = 0.0d0
25380           dCAVdOM12 = 0.0d0
25381           rij_shift = rij
25382           fac       = rij_shift**expon
25383           c1        = fac  * fac * aa_peppho
25384 !          c1        = 0.0d0
25385           c2        = fac  * bb_peppho
25386 !          c2        = 0.0d0
25387           evdwij    =  c1 + c2
25388 ! Now cavity....................
25389        eagle = dsqrt(1.0/rij_shift)
25390        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25391           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25392           botsq = bot * bot
25393           Fcav = top / bot
25394           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25395           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25396           dFdR = ((dtop * bot - top * dbot) / botsq)
25397        w1        = wqdip_peppho(1)
25398        w2        = wqdip_peppho(2)
25399 !       w1=0.0d0
25400 !       w2=0.0d0
25401 !       pis       = sig0head_scbase(itypi,itypj)
25402 !       eps_head   = epshead_scbase(itypi,itypj)
25403 !c!-------------------------------------------------------------------
25404
25405 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25406 !c!     &        +dhead(1,1,itypi,itypj))**2))
25407 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25408 !c!     &        +dhead(2,1,itypi,itypj))**2))
25409
25410 !c!-------------------------------------------------------------------
25411 !c! ecl
25412        sparrow  = w1  *  om1
25413        hawk     = w2 *  (1.0d0 - sqom1)
25414        Ecl = sparrow * rij_shift**2.0d0 &
25415            - hawk    * rij_shift**4.0d0
25416 !c!-------------------------------------------------------------------
25417 !c! derivative of ecl is Gcl
25418 !c! dF/dr part
25419 !       rij_shift=5.0
25420        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25421                 + 4.0d0 * hawk    * rij_shift**5.0d0
25422 !c! dF/dom1
25423        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25424 !c! dF/dom2
25425        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25426        eom1  =    dGCLdOM1+dGCLdOM2
25427        eom2  =    0.0
25428
25429           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25430 !          fac=0.0
25431           gg(1) =  fac*xj*rij
25432           gg(2) =  fac*yj*rij
25433           gg(3) =  fac*zj*rij
25434          do k=1,3
25435          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25436          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25437          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25438          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25439          gg(k)=0.0
25440          enddo
25441
25442       DO k = 1, 3
25443         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25444         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25445         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25446         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25447 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25448         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25449 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25450         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25451                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25452         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25453                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25454         enddo
25455        epeppho=epeppho+evdwij+Fcav+ECL
25456 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25457        enddo
25458        enddo
25459       end subroutine eprot_pep_phosphate
25460 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25461       subroutine emomo(evdw)
25462       use calc_data
25463       use comm_momo
25464 !      implicit real*8 (a-h,o-z)
25465 !      include 'DIMENSIONS'
25466 !      include 'COMMON.GEO'
25467 !      include 'COMMON.VAR'
25468 !      include 'COMMON.LOCAL'
25469 !      include 'COMMON.CHAIN'
25470 !      include 'COMMON.DERIV'
25471 !      include 'COMMON.NAMES'
25472 !      include 'COMMON.INTERACT'
25473 !      include 'COMMON.IOUNITS'
25474 !      include 'COMMON.CALC'
25475 !      include 'COMMON.CONTROL'
25476 !      include 'COMMON.SBRIDGE'
25477       logical :: lprn
25478 !el local variables
25479       integer :: iint,itypi1,subchap,isel
25480       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25481       real(kind=8) :: evdw
25482       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25483                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25484                     sslipi,sslipj,faclip,alpha_sco
25485       integer :: ii
25486       real(kind=8) :: fracinbuf
25487        real (kind=8) :: escpho
25488        real (kind=8),dimension(4):: ener
25489        real(kind=8) :: b1,b2,egb
25490        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25491         Lambf,&
25492         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25493         dFdOM2,dFdL,dFdOM12,&
25494         federmaus,&
25495         d1i,d1j
25496 !       real(kind=8),dimension(3,2)::erhead_tail
25497 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25498        real(kind=8) ::  facd4, adler, Fgb, facd3
25499        integer troll,jj,istate
25500        real (kind=8) :: dcosom1(3),dcosom2(3)
25501        eps_out=80.0d0
25502        sss_ele_cut=1.0d0
25503 !       print *,"EVDW KURW",evdw,nres
25504       do i=iatsc_s,iatsc_e
25505 !        print *,"I am in EVDW",i
25506         itypi=iabs(itype(i,1))
25507 !        if (i.ne.47) cycle
25508         if (itypi.eq.ntyp1) cycle
25509         itypi1=iabs(itype(i+1,1))
25510         xi=c(1,nres+i)
25511         yi=c(2,nres+i)
25512         zi=c(3,nres+i)
25513           xi=dmod(xi,boxxsize)
25514           if (xi.lt.0) xi=xi+boxxsize
25515           yi=dmod(yi,boxysize)
25516           if (yi.lt.0) yi=yi+boxysize
25517           zi=dmod(zi,boxzsize)
25518           if (zi.lt.0) zi=zi+boxzsize
25519
25520        if ((zi.gt.bordlipbot)  &
25521         .and.(zi.lt.bordliptop)) then
25522 !C the energy transfer exist
25523         if (zi.lt.buflipbot) then
25524 !C what fraction I am in
25525          fracinbuf=1.0d0-  &
25526               ((zi-bordlipbot)/lipbufthick)
25527 !C lipbufthick is thickenes of lipid buffore
25528          sslipi=sscalelip(fracinbuf)
25529          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25530         elseif (zi.gt.bufliptop) then
25531          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25532          sslipi=sscalelip(fracinbuf)
25533          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25534         else
25535          sslipi=1.0d0
25536          ssgradlipi=0.0
25537         endif
25538        else
25539          sslipi=0.0d0
25540          ssgradlipi=0.0
25541        endif
25542 !       print *, sslipi,ssgradlipi
25543         dxi=dc_norm(1,nres+i)
25544         dyi=dc_norm(2,nres+i)
25545         dzi=dc_norm(3,nres+i)
25546 !        dsci_inv=dsc_inv(itypi)
25547         dsci_inv=vbld_inv(i+nres)
25548 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25549 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25550 !
25551 ! Calculate SC interaction energy.
25552 !
25553         do iint=1,nint_gr(i)
25554           do j=istart(i,iint),iend(i,iint)
25555 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25556             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25557               call dyn_ssbond_ene(i,j,evdwij)
25558               evdw=evdw+evdwij
25559               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25560                               'evdw',i,j,evdwij,' ss'
25561 !              if (energy_dec) write (iout,*) &
25562 !                              'evdw',i,j,evdwij,' ss'
25563              do k=j+1,iend(i,iint)
25564 !C search over all next residues
25565               if (dyn_ss_mask(k)) then
25566 !C check if they are cysteins
25567 !C              write(iout,*) 'k=',k
25568
25569 !c              write(iout,*) "PRZED TRI", evdwij
25570 !               evdwij_przed_tri=evdwij
25571               call triple_ssbond_ene(i,j,k,evdwij)
25572 !c               if(evdwij_przed_tri.ne.evdwij) then
25573 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25574 !c               endif
25575
25576 !c              write(iout,*) "PO TRI", evdwij
25577 !C call the energy function that removes the artifical triple disulfide
25578 !C bond the soubroutine is located in ssMD.F
25579               evdw=evdw+evdwij
25580               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25581                             'evdw',i,j,evdwij,'tss'
25582               endif!dyn_ss_mask(k)
25583              enddo! k
25584             ELSE
25585 !el            ind=ind+1
25586             itypj=iabs(itype(j,1))
25587             if (itypj.eq.ntyp1) cycle
25588              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25589
25590 !             if (j.ne.78) cycle
25591 !            dscj_inv=dsc_inv(itypj)
25592             dscj_inv=vbld_inv(j+nres)
25593            xj=c(1,j+nres)
25594            yj=c(2,j+nres)
25595            zj=c(3,j+nres)
25596            xj=dmod(xj,boxxsize)
25597            if (xj.lt.0) xj=xj+boxxsize
25598            yj=dmod(yj,boxysize)
25599            if (yj.lt.0) yj=yj+boxysize
25600            zj=dmod(zj,boxzsize)
25601            if (zj.lt.0) zj=zj+boxzsize
25602           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25603           xj_safe=xj
25604           yj_safe=yj
25605           zj_safe=zj
25606           subchap=0
25607
25608           do xshift=-1,1
25609           do yshift=-1,1
25610           do zshift=-1,1
25611           xj=xj_safe+xshift*boxxsize
25612           yj=yj_safe+yshift*boxysize
25613           zj=zj_safe+zshift*boxzsize
25614           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25615           if(dist_temp.lt.dist_init) then
25616             dist_init=dist_temp
25617             xj_temp=xj
25618             yj_temp=yj
25619             zj_temp=zj
25620             subchap=1
25621           endif
25622           enddo
25623           enddo
25624           enddo
25625           if (subchap.eq.1) then
25626           xj=xj_temp-xi
25627           yj=yj_temp-yi
25628           zj=zj_temp-zi
25629           else
25630           xj=xj_safe-xi
25631           yj=yj_safe-yi
25632           zj=zj_safe-zi
25633           endif
25634           dxj = dc_norm( 1, nres+j )
25635           dyj = dc_norm( 2, nres+j )
25636           dzj = dc_norm( 3, nres+j )
25637 !          print *,i,j,itypi,itypj
25638 !          d1i=0.0d0
25639 !          d1j=0.0d0
25640 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25641 ! Gay-berne var's
25642 !1!          sig0ij = sigma_scsc( itypi,itypj )
25643 !          chi1=0.0d0
25644 !          chi2=0.0d0
25645 !          chip1=0.0d0
25646 !          chip2=0.0d0
25647 ! not used by momo potential, but needed by sc_angular which is shared
25648 ! by all energy_potential subroutines
25649           alf1   = 0.0d0
25650           alf2   = 0.0d0
25651           alf12  = 0.0d0
25652           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25653 !       a12sq = a12sq * a12sq
25654 ! charge of amino acid itypi is...
25655           chis1 = chis(itypi,itypj)
25656           chis2 = chis(itypj,itypi)
25657           chis12 = chis1 * chis2
25658           sig1 = sigmap1(itypi,itypj)
25659           sig2 = sigmap2(itypi,itypj)
25660 !       write (*,*) "sig1 = ", sig1
25661 !          chis1=0.0
25662 !          chis2=0.0
25663 !                    chis12 = chis1 * chis2
25664 !          sig1=0.0
25665 !          sig2=0.0
25666 !       write (*,*) "sig2 = ", sig2
25667 ! alpha factors from Fcav/Gcav
25668           b1cav = alphasur(1,itypi,itypj)
25669 !          b1cav=0.0d0
25670           b2cav = alphasur(2,itypi,itypj)
25671           b3cav = alphasur(3,itypi,itypj)
25672           b4cav = alphasur(4,itypi,itypj)
25673 ! used to determine whether we want to do quadrupole calculations
25674        eps_in = epsintab(itypi,itypj)
25675        if (eps_in.eq.0.0) eps_in=1.0
25676
25677        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25678        Rtail = 0.0d0
25679 !       dtail(1,itypi,itypj)=0.0
25680 !       dtail(2,itypi,itypj)=0.0
25681
25682        DO k = 1, 3
25683         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25684         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25685        END DO
25686 !c! tail distances will be themselves usefull elswhere
25687 !c1 (in Gcav, for example)
25688        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25689        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25690        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25691        Rtail = dsqrt( &
25692           (Rtail_distance(1)*Rtail_distance(1)) &
25693         + (Rtail_distance(2)*Rtail_distance(2)) &
25694         + (Rtail_distance(3)*Rtail_distance(3)))
25695
25696 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25697 !-------------------------------------------------------------------
25698 ! tail location and distance calculations
25699        d1 = dhead(1, 1, itypi, itypj)
25700        d2 = dhead(2, 1, itypi, itypj)
25701
25702        DO k = 1,3
25703 ! location of polar head is computed by taking hydrophobic centre
25704 ! and moving by a d1 * dc_norm vector
25705 ! see unres publications for very informative images
25706         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25707         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25708 ! distance
25709 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25710 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25711         Rhead_distance(k) = chead(k,2) - chead(k,1)
25712        END DO
25713 ! pitagoras (root of sum of squares)
25714        Rhead = dsqrt( &
25715           (Rhead_distance(1)*Rhead_distance(1)) &
25716         + (Rhead_distance(2)*Rhead_distance(2)) &
25717         + (Rhead_distance(3)*Rhead_distance(3)))
25718 !-------------------------------------------------------------------
25719 ! zero everything that should be zero'ed
25720        evdwij = 0.0d0
25721        ECL = 0.0d0
25722        Elj = 0.0d0
25723        Equad = 0.0d0
25724        Epol = 0.0d0
25725        Fcav=0.0d0
25726        eheadtail = 0.0d0
25727        dGCLdOM1 = 0.0d0
25728        dGCLdOM2 = 0.0d0
25729        dGCLdOM12 = 0.0d0
25730        dPOLdOM1 = 0.0d0
25731        dPOLdOM2 = 0.0d0
25732           Fcav = 0.0d0
25733           dFdR = 0.0d0
25734           dCAVdOM1  = 0.0d0
25735           dCAVdOM2  = 0.0d0
25736           dCAVdOM12 = 0.0d0
25737           dscj_inv = vbld_inv(j+nres)
25738 !          print *,i,j,dscj_inv,dsci_inv
25739 ! rij holds 1/(distance of Calpha atoms)
25740           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25741           rij  = dsqrt(rrij)
25742 !----------------------------
25743           CALL sc_angular
25744 ! this should be in elgrad_init but om's are calculated by sc_angular
25745 ! which in turn is used by older potentials
25746 ! om = omega, sqom = om^2
25747           sqom1  = om1 * om1
25748           sqom2  = om2 * om2
25749           sqom12 = om12 * om12
25750
25751 ! now we calculate EGB - Gey-Berne
25752 ! It will be summed up in evdwij and saved in evdw
25753           sigsq     = 1.0D0  / sigsq
25754           sig       = sig0ij * dsqrt(sigsq)
25755 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25756           rij_shift = Rtail - sig + sig0ij
25757           IF (rij_shift.le.0.0D0) THEN
25758            evdw = 1.0D20
25759            RETURN
25760           END IF
25761           sigder = -sig * sigsq
25762           rij_shift = 1.0D0 / rij_shift
25763           fac       = rij_shift**expon
25764           c1        = fac  * fac * aa_aq(itypi,itypj)
25765 !          print *,"ADAM",aa_aq(itypi,itypj)
25766
25767 !          c1        = 0.0d0
25768           c2        = fac  * bb_aq(itypi,itypj)
25769 !          c2        = 0.0d0
25770           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25771           eps2der   = eps3rt * evdwij
25772           eps3der   = eps2rt * evdwij
25773 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25774           evdwij    = eps2rt * eps3rt * evdwij
25775 !#ifdef TSCSC
25776 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25777 !           evdw_p = evdw_p + evdwij
25778 !          ELSE
25779 !           evdw_m = evdw_m + evdwij
25780 !          END IF
25781 !#else
25782           evdw = evdw  &
25783               + evdwij
25784 !#endif
25785
25786           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25787           fac    = -expon * (c1 + evdwij) * rij_shift
25788           sigder = fac * sigder
25789 !          fac    = rij * fac
25790 ! Calculate distance derivative
25791           gg(1) =  fac
25792           gg(2) =  fac
25793           gg(3) =  fac
25794 !          if (b2.gt.0.0) then
25795           fac = chis1 * sqom1 + chis2 * sqom2 &
25796           - 2.0d0 * chis12 * om1 * om2 * om12
25797 ! we will use pom later in Gcav, so dont mess with it!
25798           pom = 1.0d0 - chis1 * chis2 * sqom12
25799           Lambf = (1.0d0 - (fac / pom))
25800 !          print *,"fac,pom",fac,pom,Lambf
25801           Lambf = dsqrt(Lambf)
25802           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25803 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25804 !       write (*,*) "sparrow = ", sparrow
25805           Chif = Rtail * sparrow
25806 !           print *,"rij,sparrow",rij , sparrow
25807           ChiLambf = Chif * Lambf
25808           eagle = dsqrt(ChiLambf)
25809           bat = ChiLambf ** 11.0d0
25810           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25811           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25812           botsq = bot * bot
25813 !          print *,top,bot,"bot,top",ChiLambf,Chif
25814           Fcav = top / bot
25815
25816        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25817        dbot = 12.0d0 * b4cav * bat * Lambf
25818        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25819
25820           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25821           dbot = 12.0d0 * b4cav * bat * Chif
25822           eagle = Lambf * pom
25823           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25824           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25825           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25826               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25827
25828           dFdL = ((dtop * bot - top * dbot) / botsq)
25829 !       dFdL = 0.0d0
25830           dCAVdOM1  = dFdL * ( dFdOM1 )
25831           dCAVdOM2  = dFdL * ( dFdOM2 )
25832           dCAVdOM12 = dFdL * ( dFdOM12 )
25833
25834        DO k= 1, 3
25835         ertail(k) = Rtail_distance(k)/Rtail
25836        END DO
25837        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25838        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25839        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25840        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25841        DO k = 1, 3
25842 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25843 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25844         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25845         gvdwx(k,i) = gvdwx(k,i) &
25846                   - (( dFdR + gg(k) ) * pom)
25847 !c!     &             - ( dFdR * pom )
25848         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25849         gvdwx(k,j) = gvdwx(k,j)   &
25850                   + (( dFdR + gg(k) ) * pom)
25851 !c!     &             + ( dFdR * pom )
25852
25853         gvdwc(k,i) = gvdwc(k,i)  &
25854                   - (( dFdR + gg(k) ) * ertail(k))
25855 !c!     &             - ( dFdR * ertail(k))
25856
25857         gvdwc(k,j) = gvdwc(k,j) &
25858                   + (( dFdR + gg(k) ) * ertail(k))
25859 !c!     &             + ( dFdR * ertail(k))
25860
25861         gg(k) = 0.0d0
25862 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25863 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25864       END DO
25865
25866
25867 !c! Compute head-head and head-tail energies for each state
25868
25869           isel = iabs(Qi) + iabs(Qj)
25870 ! double charge for Phophorylated! itype - 25,27,27
25871 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25872 !            Qi=Qi*2
25873 !            Qij=Qij*2
25874 !           endif
25875 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25876 !            Qj=Qj*2
25877 !            Qij=Qij*2
25878 !           endif
25879
25880 !          isel=0
25881           IF (isel.eq.0) THEN
25882 !c! No charges - do nothing
25883            eheadtail = 0.0d0
25884
25885           ELSE IF (isel.eq.4) THEN
25886 !c! Calculate dipole-dipole interactions
25887            CALL edd(ecl)
25888            eheadtail = ECL
25889 !           eheadtail = 0.0d0
25890
25891           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25892 !c! Charge-nonpolar interactions
25893           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25894             Qi=Qi*2
25895             Qij=Qij*2
25896            endif
25897           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25898             Qj=Qj*2
25899             Qij=Qij*2
25900            endif
25901
25902            CALL eqn(epol)
25903            eheadtail = epol
25904 !           eheadtail = 0.0d0
25905
25906           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25907 !c! Nonpolar-charge interactions
25908           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25909             Qi=Qi*2
25910             Qij=Qij*2
25911            endif
25912           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25913             Qj=Qj*2
25914             Qij=Qij*2
25915            endif
25916
25917            CALL enq(epol)
25918            eheadtail = epol
25919 !           eheadtail = 0.0d0
25920
25921           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25922 !c! Charge-dipole interactions
25923           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25924             Qi=Qi*2
25925             Qij=Qij*2
25926            endif
25927           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25928             Qj=Qj*2
25929             Qij=Qij*2
25930            endif
25931
25932            CALL eqd(ecl, elj, epol)
25933            eheadtail = ECL + elj + epol
25934 !           eheadtail = 0.0d0
25935
25936           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25937 !c! Dipole-charge interactions
25938           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25939             Qi=Qi*2
25940             Qij=Qij*2
25941            endif
25942           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25943             Qj=Qj*2
25944             Qij=Qij*2
25945            endif
25946            CALL edq(ecl, elj, epol)
25947           eheadtail = ECL + elj + epol
25948 !           eheadtail = 0.0d0
25949
25950           ELSE IF ((isel.eq.2.and.   &
25951                iabs(Qi).eq.1).and.  &
25952                nstate(itypi,itypj).eq.1) THEN
25953 !c! Same charge-charge interaction ( +/+ or -/- )
25954           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25955             Qi=Qi*2
25956             Qij=Qij*2
25957            endif
25958           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25959             Qj=Qj*2
25960             Qij=Qij*2
25961            endif
25962
25963            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25964            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25965 !           eheadtail = 0.0d0
25966
25967           ELSE IF ((isel.eq.2.and.  &
25968                iabs(Qi).eq.1).and. &
25969                nstate(itypi,itypj).ne.1) THEN
25970 !c! Different charge-charge interaction ( +/- or -/+ )
25971           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25972             Qi=Qi*2
25973             Qij=Qij*2
25974            endif
25975           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25976             Qj=Qj*2
25977             Qij=Qij*2
25978            endif
25979
25980            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25981           END IF
25982        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25983       evdw = evdw  + Fcav + eheadtail
25984
25985        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25986         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25987         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25988         Equad,evdwij+Fcav+eheadtail,evdw
25989 !       evdw = evdw  + Fcav  + eheadtail
25990
25991         iF (nstate(itypi,itypj).eq.1) THEN
25992         CALL sc_grad
25993        END IF
25994 !c!-------------------------------------------------------------------
25995 !c! NAPISY KONCOWE
25996          END DO   ! j
25997         END DO    ! iint
25998        END DO     ! i
25999 !c      write (iout,*) "Number of loop steps in EGB:",ind
26000 !c      energy_dec=.false.
26001 !              print *,"EVDW KURW",evdw,nres
26002
26003        RETURN
26004       END SUBROUTINE emomo
26005 !C------------------------------------------------------------------------------------
26006       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26007       use calc_data
26008       use comm_momo
26009        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26010          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26011 !       integer :: k
26012 !c! Epol and Gpol analytical parameters
26013        alphapol1 = alphapol(itypi,itypj)
26014        alphapol2 = alphapol(itypj,itypi)
26015 !c! Fisocav and Gisocav analytical parameters
26016        al1  = alphiso(1,itypi,itypj)
26017        al2  = alphiso(2,itypi,itypj)
26018        al3  = alphiso(3,itypi,itypj)
26019        al4  = alphiso(4,itypi,itypj)
26020        csig = (1.0d0  &
26021            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26022            + sigiso2(itypi,itypj)**2.0d0))
26023 !c!
26024        pis  = sig0head(itypi,itypj)
26025        eps_head = epshead(itypi,itypj)
26026        Rhead_sq = Rhead * Rhead
26027 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26028 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26029        R1 = 0.0d0
26030        R2 = 0.0d0
26031        DO k = 1, 3
26032 !c! Calculate head-to-tail distances needed by Epol
26033         R1=R1+(ctail(k,2)-chead(k,1))**2
26034         R2=R2+(chead(k,2)-ctail(k,1))**2
26035        END DO
26036 !c! Pitagoras
26037        R1 = dsqrt(R1)
26038        R2 = dsqrt(R2)
26039
26040 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26041 !c!     &        +dhead(1,1,itypi,itypj))**2))
26042 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26043 !c!     &        +dhead(2,1,itypi,itypj))**2))
26044
26045 !c!-------------------------------------------------------------------
26046 !c! Coulomb electrostatic interaction
26047        Ecl = (332.0d0 * Qij) / Rhead
26048 !c! derivative of Ecl is Gcl...
26049        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26050        dGCLdOM1 = 0.0d0
26051        dGCLdOM2 = 0.0d0
26052        dGCLdOM12 = 0.0d0
26053        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26054        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26055        debkap=debaykap(itypi,itypj)
26056        Egb = -(332.0d0 * Qij *&
26057         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26058 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26059 !c! Derivative of Egb is Ggb...
26060        dGGBdFGB = -(-332.0d0 * Qij * &
26061        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26062        -(332.0d0 * Qij *&
26063         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26064        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26065        dGGBdR = dGGBdFGB * dFGBdR
26066 !c!-------------------------------------------------------------------
26067 !c! Fisocav - isotropic cavity creation term
26068 !c! or "how much energy it costs to put charged head in water"
26069        pom = Rhead * csig
26070        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26071        bot = (1.0d0 + al4 * pom**12.0d0)
26072        botsq = bot * bot
26073        FisoCav = top / bot
26074 !      write (*,*) "Rhead = ",Rhead
26075 !      write (*,*) "csig = ",csig
26076 !      write (*,*) "pom = ",pom
26077 !      write (*,*) "al1 = ",al1
26078 !      write (*,*) "al2 = ",al2
26079 !      write (*,*) "al3 = ",al3
26080 !      write (*,*) "al4 = ",al4
26081 !        write (*,*) "top = ",top
26082 !        write (*,*) "bot = ",bot
26083 !c! Derivative of Fisocav is GCV...
26084        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26085        dbot = 12.0d0 * al4 * pom ** 11.0d0
26086        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26087 !c!-------------------------------------------------------------------
26088 !c! Epol
26089 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26090        MomoFac1 = (1.0d0 - chi1 * sqom2)
26091        MomoFac2 = (1.0d0 - chi2 * sqom1)
26092        RR1  = ( R1 * R1 ) / MomoFac1
26093        RR2  = ( R2 * R2 ) / MomoFac2
26094        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26095        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26096        fgb1 = sqrt( RR1 + a12sq * ee1 )
26097        fgb2 = sqrt( RR2 + a12sq * ee2 )
26098        epol = 332.0d0 * eps_inout_fac * ( &
26099       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26100 !c!       epol = 0.0d0
26101        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26102                / (fgb1 ** 5.0d0)
26103        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26104                / (fgb2 ** 5.0d0)
26105        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26106              / ( 2.0d0 * fgb1 )
26107        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26108              / ( 2.0d0 * fgb2 )
26109        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26110                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26111        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26112                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26113        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26114 !c!       dPOLdR1 = 0.0d0
26115        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26116 !c!       dPOLdR2 = 0.0d0
26117        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26118 !c!       dPOLdOM1 = 0.0d0
26119        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26120 !c!       dPOLdOM2 = 0.0d0
26121 !c!-------------------------------------------------------------------
26122 !c! Elj
26123 !c! Lennard-Jones 6-12 interaction between heads
26124        pom = (pis / Rhead)**6.0d0
26125        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26126 !c! derivative of Elj is Glj
26127        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26128              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26129 !c!-------------------------------------------------------------------
26130 !c! Return the results
26131 !c! These things do the dRdX derivatives, that is
26132 !c! allow us to change what we see from function that changes with
26133 !c! distance to function that changes with LOCATION (of the interaction
26134 !c! site)
26135        DO k = 1, 3
26136         erhead(k) = Rhead_distance(k)/Rhead
26137         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26138         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26139        END DO
26140
26141        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26142        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26143        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26144        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26145        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26146        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26147        facd1 = d1 * vbld_inv(i+nres)
26148        facd2 = d2 * vbld_inv(j+nres)
26149        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26150        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26151
26152 !c! Now we add appropriate partial derivatives (one in each dimension)
26153        DO k = 1, 3
26154         hawk   = (erhead_tail(k,1) + &
26155         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26156         condor = (erhead_tail(k,2) + &
26157         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26158
26159         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26160         gvdwx(k,i) = gvdwx(k,i) &
26161                   - dGCLdR * pom&
26162                   - dGGBdR * pom&
26163                   - dGCVdR * pom&
26164                   - dPOLdR1 * hawk&
26165                   - dPOLdR2 * (erhead_tail(k,2)&
26166       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26167                   - dGLJdR * pom
26168
26169         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26170         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26171                    + dGGBdR * pom+ dGCVdR * pom&
26172                   + dPOLdR1 * (erhead_tail(k,1)&
26173       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26174                   + dPOLdR2 * condor + dGLJdR * pom
26175
26176         gvdwc(k,i) = gvdwc(k,i)  &
26177                   - dGCLdR * erhead(k)&
26178                   - dGGBdR * erhead(k)&
26179                   - dGCVdR * erhead(k)&
26180                   - dPOLdR1 * erhead_tail(k,1)&
26181                   - dPOLdR2 * erhead_tail(k,2)&
26182                   - dGLJdR * erhead(k)
26183
26184         gvdwc(k,j) = gvdwc(k,j)         &
26185                   + dGCLdR * erhead(k) &
26186                   + dGGBdR * erhead(k) &
26187                   + dGCVdR * erhead(k) &
26188                   + dPOLdR1 * erhead_tail(k,1) &
26189                   + dPOLdR2 * erhead_tail(k,2)&
26190                   + dGLJdR * erhead(k)
26191
26192        END DO
26193        RETURN
26194       END SUBROUTINE eqq
26195
26196       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26197       use calc_data
26198       use comm_momo
26199        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26200          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26201 !       integer :: k
26202 !c! Epol and Gpol analytical parameters
26203        alphapol1 = alphapolcat(itypi,itypj)
26204        alphapol2 = alphapolcat(itypj,itypi)
26205 !c! Fisocav and Gisocav analytical parameters
26206        al1  = alphisocat(1,itypi,itypj)
26207        al2  = alphisocat(2,itypi,itypj)
26208        al3  = alphisocat(3,itypi,itypj)
26209        al4  = alphisocat(4,itypi,itypj)
26210        csig = (1.0d0  &
26211            / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26212            + sigiso2cat(itypi,itypj)**2.0d0))
26213 !c!
26214        pis  = sig0headcat(itypi,itypj)
26215        eps_head = epsheadcat(itypi,itypj)
26216        Rhead_sq = Rhead * Rhead
26217 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26218 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26219        R1 = 0.0d0
26220        R2 = 0.0d0
26221        DO k = 1, 3
26222 !c! Calculate head-to-tail distances needed by Epol
26223         R1=R1+(ctail(k,2)-chead(k,1))**2
26224         R2=R2+(chead(k,2)-ctail(k,1))**2
26225        END DO
26226 !c! Pitagoras
26227        R1 = dsqrt(R1)
26228        R2 = dsqrt(R2)
26229
26230 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26231 !c!     &        +dhead(1,1,itypi,itypj))**2))
26232 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26233 !c!     &        +dhead(2,1,itypi,itypj))**2))
26234
26235 !c!-------------------------------------------------------------------
26236 !c! Coulomb electrostatic interaction
26237        Ecl = (332.0d0 * Qij) / Rhead
26238 !c! derivative of Ecl is Gcl...
26239        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26240        dGCLdOM1 = 0.0d0
26241        dGCLdOM2 = 0.0d0
26242        dGCLdOM12 = 0.0d0
26243        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26244        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26245        debkap=debaykapcat(itypi,itypj)
26246        Egb = -(332.0d0 * Qij *&
26247         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26248 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26249 !c! Derivative of Egb is Ggb...
26250        dGGBdFGB = -(-332.0d0 * Qij * &
26251        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26252        -(332.0d0 * Qij *&
26253         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26254        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26255        dGGBdR = dGGBdFGB * dFGBdR
26256 !c!-------------------------------------------------------------------
26257 !c! Fisocav - isotropic cavity creation term
26258 !c! or "how much energy it costs to put charged head in water"
26259        pom = Rhead * csig
26260        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26261        bot = (1.0d0 + al4 * pom**12.0d0)
26262        botsq = bot * bot
26263        FisoCav = top / bot
26264 !      write (*,*) "Rhead = ",Rhead
26265 !      write (*,*) "csig = ",csig
26266 !      write (*,*) "pom = ",pom
26267 !      write (*,*) "al1 = ",al1
26268 !      write (*,*) "al2 = ",al2
26269 !      write (*,*) "al3 = ",al3
26270 !      write (*,*) "al4 = ",al4
26271 !        write (*,*) "top = ",top
26272 !        write (*,*) "bot = ",bot
26273 !c! Derivative of Fisocav is GCV...
26274        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26275        dbot = 12.0d0 * al4 * pom ** 11.0d0
26276        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26277 !c!-------------------------------------------------------------------
26278 !c! Epol
26279 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26280        MomoFac1 = (1.0d0 - chi1 * sqom2)
26281        MomoFac2 = (1.0d0 - chi2 * sqom1)
26282        RR1  = ( R1 * R1 ) / MomoFac1
26283        RR2  = ( R2 * R2 ) / MomoFac2
26284        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26285        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26286        fgb1 = sqrt( RR1 + a12sq * ee1 )
26287        fgb2 = sqrt( RR2 + a12sq * ee2 )
26288        epol = 332.0d0 * eps_inout_fac * ( &
26289       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26290 !c!       epol = 0.0d0
26291        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26292                / (fgb1 ** 5.0d0)
26293        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26294                / (fgb2 ** 5.0d0)
26295        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26296              / ( 2.0d0 * fgb1 )
26297        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26298              / ( 2.0d0 * fgb2 )
26299        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26300                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26301        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26302                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26303        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26304 !c!       dPOLdR1 = 0.0d0
26305        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26306 !c!       dPOLdR2 = 0.0d0
26307        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26308 !c!       dPOLdOM1 = 0.0d0
26309        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26310 !c!       dPOLdOM2 = 0.0d0
26311 !c!-------------------------------------------------------------------
26312 !c! Elj
26313 !c! Lennard-Jones 6-12 interaction between heads
26314        pom = (pis / Rhead)**6.0d0
26315        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26316 !c! derivative of Elj is Glj
26317        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26318              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26319 !c!-------------------------------------------------------------------
26320 !c! Return the results
26321 !c! These things do the dRdX derivatives, that is
26322 !c! allow us to change what we see from function that changes with
26323 !c! distance to function that changes with LOCATION (of the interaction
26324 !c! site)
26325        DO k = 1, 3
26326         erhead(k) = Rhead_distance(k)/Rhead
26327         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26328         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26329        END DO
26330
26331        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26332        erdxj = scalar( erhead(1), dC_norm(1,j) )
26333        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26334        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26335        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26336        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26337        facd1 = d1 * vbld_inv(i+nres)
26338        facd2 = d2 * vbld_inv(j)
26339        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26340        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26341
26342 !c! Now we add appropriate partial derivatives (one in each dimension)
26343        DO k = 1, 3
26344         hawk   = (erhead_tail(k,1) + &
26345         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26346         condor = (erhead_tail(k,2) + &
26347         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26348
26349         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26350         gvdwx(k,i) = gvdwx(k,i) &
26351                   - dGCLdR * pom&
26352                   - dGGBdR * pom&
26353                   - dGCVdR * pom&
26354                   - dPOLdR1 * hawk&
26355                   - dPOLdR2 * (erhead_tail(k,2)&
26356       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26357                   - dGLJdR * pom
26358
26359         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26360         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26361                    + dGGBdR * pom+ dGCVdR * pom&
26362                   + dPOLdR1 * (erhead_tail(k,1)&
26363       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26364                   + dPOLdR2 * condor + dGLJdR * pom
26365
26366         gvdwc(k,i) = gvdwc(k,i)  &
26367                   - dGCLdR * erhead(k)&
26368                   - dGGBdR * erhead(k)&
26369                   - dGCVdR * erhead(k)&
26370                   - dPOLdR1 * erhead_tail(k,1)&
26371                   - dPOLdR2 * erhead_tail(k,2)&
26372                   - dGLJdR * erhead(k)
26373
26374         gvdwc(k,j) = gvdwc(k,j)         &
26375                   + dGCLdR * erhead(k) &
26376                   + dGGBdR * erhead(k) &
26377                   + dGCVdR * erhead(k) &
26378                   + dPOLdR1 * erhead_tail(k,1) &
26379                   + dPOLdR2 * erhead_tail(k,2)&
26380                   + dGLJdR * erhead(k)
26381
26382        END DO
26383        RETURN
26384       END SUBROUTINE eqq_cat
26385 !c!-------------------------------------------------------------------
26386       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26387       use comm_momo
26388       use calc_data
26389
26390        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26391        double precision ener(4)
26392        double precision dcosom1(3),dcosom2(3)
26393 !c! used in Epol derivatives
26394        double precision facd3, facd4
26395        double precision federmaus, adler
26396        integer istate,ii,jj
26397        real (kind=8) :: Fgb
26398 !       print *,"CALLING EQUAD"
26399 !c! Epol and Gpol analytical parameters
26400        alphapol1 = alphapol(itypi,itypj)
26401        alphapol2 = alphapol(itypj,itypi)
26402 !c! Fisocav and Gisocav analytical parameters
26403        al1  = alphiso(1,itypi,itypj)
26404        al2  = alphiso(2,itypi,itypj)
26405        al3  = alphiso(3,itypi,itypj)
26406        al4  = alphiso(4,itypi,itypj)
26407        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26408             + sigiso2(itypi,itypj)**2.0d0))
26409 !c!
26410        w1   = wqdip(1,itypi,itypj)
26411        w2   = wqdip(2,itypi,itypj)
26412        pis  = sig0head(itypi,itypj)
26413        eps_head = epshead(itypi,itypj)
26414 !c! First things first:
26415 !c! We need to do sc_grad's job with GB and Fcav
26416        eom1  = eps2der * eps2rt_om1 &
26417              - 2.0D0 * alf1 * eps3der&
26418              + sigder * sigsq_om1&
26419              + dCAVdOM1
26420        eom2  = eps2der * eps2rt_om2 &
26421              + 2.0D0 * alf2 * eps3der&
26422              + sigder * sigsq_om2&
26423              + dCAVdOM2
26424        eom12 =  evdwij  * eps1_om12 &
26425              + eps2der * eps2rt_om12 &
26426              - 2.0D0 * alf12 * eps3der&
26427              + sigder *sigsq_om12&
26428              + dCAVdOM12
26429 !c! now some magical transformations to project gradient into
26430 !c! three cartesian vectors
26431        DO k = 1, 3
26432         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26433         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26434         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26435 !c! this acts on hydrophobic center of interaction
26436         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26437                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26438                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26439         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26440                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26441                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26442 !c! this acts on Calpha
26443         gvdwc(k,i)=gvdwc(k,i)-gg(k)
26444         gvdwc(k,j)=gvdwc(k,j)+gg(k)
26445        END DO
26446 !c! sc_grad is done, now we will compute
26447        eheadtail = 0.0d0
26448        eom1 = 0.0d0
26449        eom2 = 0.0d0
26450        eom12 = 0.0d0
26451        DO istate = 1, nstate(itypi,itypj)
26452 !c*************************************************************
26453         IF (istate.ne.1) THEN
26454          IF (istate.lt.3) THEN
26455           ii = 1
26456          ELSE
26457           ii = 2
26458          END IF
26459         jj = istate/ii
26460         d1 = dhead(1,ii,itypi,itypj)
26461         d2 = dhead(2,jj,itypi,itypj)
26462         DO k = 1,3
26463          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26464          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26465          Rhead_distance(k) = chead(k,2) - chead(k,1)
26466         END DO
26467 !c! pitagoras (root of sum of squares)
26468         Rhead = dsqrt( &
26469                (Rhead_distance(1)*Rhead_distance(1))  &
26470              + (Rhead_distance(2)*Rhead_distance(2))  &
26471              + (Rhead_distance(3)*Rhead_distance(3)))
26472         END IF
26473         Rhead_sq = Rhead * Rhead
26474
26475 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26476 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26477         R1 = 0.0d0
26478         R2 = 0.0d0
26479         DO k = 1, 3
26480 !c! Calculate head-to-tail distances
26481          R1=R1+(ctail(k,2)-chead(k,1))**2
26482          R2=R2+(chead(k,2)-ctail(k,1))**2
26483         END DO
26484 !c! Pitagoras
26485         R1 = dsqrt(R1)
26486         R2 = dsqrt(R2)
26487         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26488 !c!        Ecl = 0.0d0
26489 !c!        write (*,*) "Ecl = ", Ecl
26490 !c! derivative of Ecl is Gcl...
26491         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26492 !c!        dGCLdR = 0.0d0
26493         dGCLdOM1 = 0.0d0
26494         dGCLdOM2 = 0.0d0
26495         dGCLdOM12 = 0.0d0
26496 !c!-------------------------------------------------------------------
26497 !c! Generalised Born Solvent Polarization
26498         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26499         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26500         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26501 !c!        Egb = 0.0d0
26502 !c!      write (*,*) "a1*a2 = ", a12sq
26503 !c!      write (*,*) "Rhead = ", Rhead
26504 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26505 !c!      write (*,*) "ee = ", ee
26506 !c!      write (*,*) "Fgb = ", Fgb
26507 !c!      write (*,*) "fac = ", eps_inout_fac
26508 !c!      write (*,*) "Qij = ", Qij
26509 !c!      write (*,*) "Egb = ", Egb
26510 !c! Derivative of Egb is Ggb...
26511 !c! dFGBdR is used by Quad's later...
26512         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26513         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26514                / ( 2.0d0 * Fgb )
26515         dGGBdR = dGGBdFGB * dFGBdR
26516 !c!        dGGBdR = 0.0d0
26517 !c!-------------------------------------------------------------------
26518 !c! Fisocav - isotropic cavity creation term
26519         pom = Rhead * csig
26520         top = al1 * (dsqrt(pom) + al2 * pom - al3)
26521         bot = (1.0d0 + al4 * pom**12.0d0)
26522         botsq = bot * bot
26523         FisoCav = top / bot
26524         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26525         dbot = 12.0d0 * al4 * pom ** 11.0d0
26526         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26527 !c!        dGCVdR = 0.0d0
26528 !c!-------------------------------------------------------------------
26529 !c! Polarization energy
26530 !c! Epol
26531         MomoFac1 = (1.0d0 - chi1 * sqom2)
26532         MomoFac2 = (1.0d0 - chi2 * sqom1)
26533         RR1  = ( R1 * R1 ) / MomoFac1
26534         RR2  = ( R2 * R2 ) / MomoFac2
26535         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26536         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26537         fgb1 = sqrt( RR1 + a12sq * ee1 )
26538         fgb2 = sqrt( RR2 + a12sq * ee2 )
26539         epol = 332.0d0 * eps_inout_fac * (&
26540         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26541 !c!        epol = 0.0d0
26542 !c! derivative of Epol is Gpol...
26543         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26544                   / (fgb1 ** 5.0d0)
26545         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26546                   / (fgb2 ** 5.0d0)
26547         dFGBdR1 = ( (R1 / MomoFac1) &
26548                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
26549                 / ( 2.0d0 * fgb1 )
26550         dFGBdR2 = ( (R2 / MomoFac2) &
26551                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26552                 / ( 2.0d0 * fgb2 )
26553         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26554                  * ( 2.0d0 - 0.5d0 * ee1) ) &
26555                  / ( 2.0d0 * fgb1 )
26556         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26557                  * ( 2.0d0 - 0.5d0 * ee2) ) &
26558                  / ( 2.0d0 * fgb2 )
26559         dPOLdR1 = dPOLdFGB1 * dFGBdR1
26560 !c!        dPOLdR1 = 0.0d0
26561         dPOLdR2 = dPOLdFGB2 * dFGBdR2
26562 !c!        dPOLdR2 = 0.0d0
26563         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26564 !c!        dPOLdOM1 = 0.0d0
26565         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26566         pom = (pis / Rhead)**6.0d0
26567         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26568 !c!        Elj = 0.0d0
26569 !c! derivative of Elj is Glj
26570         dGLJdR = 4.0d0 * eps_head &
26571             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26572             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26573 !c!        dGLJdR = 0.0d0
26574 !c!-------------------------------------------------------------------
26575 !c! Equad
26576        IF (Wqd.ne.0.0d0) THEN
26577         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26578              - 37.5d0  * ( sqom1 + sqom2 ) &
26579              + 157.5d0 * ( sqom1 * sqom2 ) &
26580              - 45.0d0  * om1*om2*om12
26581         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26582         Equad = fac * Beta1
26583 !c!        Equad = 0.0d0
26584 !c! derivative of Equad...
26585         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26586 !c!        dQUADdR = 0.0d0
26587         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26588 !c!        dQUADdOM1 = 0.0d0
26589         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26590 !c!        dQUADdOM2 = 0.0d0
26591         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26592        ELSE
26593          Beta1 = 0.0d0
26594          Equad = 0.0d0
26595         END IF
26596 !c!-------------------------------------------------------------------
26597 !c! Return the results
26598 !c! Angular stuff
26599         eom1 = dPOLdOM1 + dQUADdOM1
26600         eom2 = dPOLdOM2 + dQUADdOM2
26601         eom12 = dQUADdOM12
26602 !c! now some magical transformations to project gradient into
26603 !c! three cartesian vectors
26604         DO k = 1, 3
26605          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26606          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26607          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26608         END DO
26609 !c! Radial stuff
26610         DO k = 1, 3
26611          erhead(k) = Rhead_distance(k)/Rhead
26612          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26613          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26614         END DO
26615         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26616         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26617         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26618         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26619         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26620         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26621         facd1 = d1 * vbld_inv(i+nres)
26622         facd2 = d2 * vbld_inv(j+nres)
26623         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26624         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26625         DO k = 1, 3
26626          hawk   = erhead_tail(k,1) + &
26627          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26628          condor = erhead_tail(k,2) + &
26629          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26630
26631          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26632 !c! this acts on hydrophobic center of interaction
26633          gheadtail(k,1,1) = gheadtail(k,1,1) &
26634                          - dGCLdR * pom &
26635                          - dGGBdR * pom &
26636                          - dGCVdR * pom &
26637                          - dPOLdR1 * hawk &
26638                          - dPOLdR2 * (erhead_tail(k,2) &
26639       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26640                          - dGLJdR * pom &
26641                          - dQUADdR * pom&
26642                          - tuna(k) &
26643                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26644                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26645
26646          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26647 !c! this acts on hydrophobic center of interaction
26648          gheadtail(k,2,1) = gheadtail(k,2,1)  &
26649                          + dGCLdR * pom      &
26650                          + dGGBdR * pom      &
26651                          + dGCVdR * pom      &
26652                          + dPOLdR1 * (erhead_tail(k,1) &
26653       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26654                          + dPOLdR2 * condor &
26655                          + dGLJdR * pom &
26656                          + dQUADdR * pom &
26657                          + tuna(k) &
26658                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26659                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26660
26661 !c! this acts on Calpha
26662          gheadtail(k,3,1) = gheadtail(k,3,1)  &
26663                          - dGCLdR * erhead(k)&
26664                          - dGGBdR * erhead(k)&
26665                          - dGCVdR * erhead(k)&
26666                          - dPOLdR1 * erhead_tail(k,1)&
26667                          - dPOLdR2 * erhead_tail(k,2)&
26668                          - dGLJdR * erhead(k) &
26669                          - dQUADdR * erhead(k)&
26670                          - tuna(k)
26671 !c! this acts on Calpha
26672          gheadtail(k,4,1) = gheadtail(k,4,1)   &
26673                           + dGCLdR * erhead(k) &
26674                           + dGGBdR * erhead(k) &
26675                           + dGCVdR * erhead(k) &
26676                           + dPOLdR1 * erhead_tail(k,1) &
26677                           + dPOLdR2 * erhead_tail(k,2) &
26678                           + dGLJdR * erhead(k) &
26679                           + dQUADdR * erhead(k)&
26680                           + tuna(k)
26681         END DO
26682         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26683         eheadtail = eheadtail &
26684                   + wstate(istate, itypi, itypj) &
26685                   * dexp(-betaT * ener(istate))
26686 !c! foreach cartesian dimension
26687         DO k = 1, 3
26688 !c! foreach of two gvdwx and gvdwc
26689          DO l = 1, 4
26690           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26691                            + wstate( istate, itypi, itypj ) &
26692                            * dexp(-betaT * ener(istate)) &
26693                            * gheadtail(k,l,1)
26694           gheadtail(k,l,1) = 0.0d0
26695          END DO
26696         END DO
26697        END DO
26698 !c! Here ended the gigantic DO istate = 1, 4, which starts
26699 !c! at the beggining of the subroutine
26700
26701        DO k = 1, 3
26702         DO l = 1, 4
26703          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26704         END DO
26705         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26706         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26707         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26708         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26709         DO l = 1, 4
26710          gheadtail(k,l,1) = 0.0d0
26711          gheadtail(k,l,2) = 0.0d0
26712         END DO
26713        END DO
26714        eheadtail = (-dlog(eheadtail)) / betaT
26715        dPOLdOM1 = 0.0d0
26716        dPOLdOM2 = 0.0d0
26717        dQUADdOM1 = 0.0d0
26718        dQUADdOM2 = 0.0d0
26719        dQUADdOM12 = 0.0d0
26720        RETURN
26721       END SUBROUTINE energy_quad
26722 !!-----------------------------------------------------------
26723       SUBROUTINE eqn(Epol)
26724       use comm_momo
26725       use calc_data
26726
26727       double precision  facd4, federmaus,epol
26728       alphapol1 = alphapol(itypi,itypj)
26729 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26730        R1 = 0.0d0
26731        DO k = 1, 3
26732 !c! Calculate head-to-tail distances
26733         R1=R1+(ctail(k,2)-chead(k,1))**2
26734        END DO
26735 !c! Pitagoras
26736        R1 = dsqrt(R1)
26737
26738 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26739 !c!     &        +dhead(1,1,itypi,itypj))**2))
26740 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26741 !c!     &        +dhead(2,1,itypi,itypj))**2))
26742 !c--------------------------------------------------------------------
26743 !c Polarization energy
26744 !c Epol
26745        MomoFac1 = (1.0d0 - chi1 * sqom2)
26746        RR1  = R1 * R1 / MomoFac1
26747        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26748        fgb1 = sqrt( RR1 + a12sq * ee1)
26749        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26750        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26751                / (fgb1 ** 5.0d0)
26752        dFGBdR1 = ( (R1 / MomoFac1) &
26753               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26754               / ( 2.0d0 * fgb1 )
26755        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26756                 * (2.0d0 - 0.5d0 * ee1) ) &
26757                 / (2.0d0 * fgb1)
26758        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26759 !c!       dPOLdR1 = 0.0d0
26760        dPOLdOM1 = 0.0d0
26761        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26762        DO k = 1, 3
26763         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26764        END DO
26765        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26766        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26767        facd1 = d1 * vbld_inv(i+nres)
26768        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26769
26770        DO k = 1, 3
26771         hawk = (erhead_tail(k,1) + &
26772         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26773
26774         gvdwx(k,i) = gvdwx(k,i) &
26775                    - dPOLdR1 * hawk
26776         gvdwx(k,j) = gvdwx(k,j) &
26777                    + dPOLdR1 * (erhead_tail(k,1) &
26778        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26779
26780         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26781         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26782
26783        END DO
26784        RETURN
26785       END SUBROUTINE eqn
26786       SUBROUTINE enq(Epol)
26787       use calc_data
26788       use comm_momo
26789        double precision facd3, adler,epol
26790        alphapol2 = alphapol(itypj,itypi)
26791 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26792        R2 = 0.0d0
26793        DO k = 1, 3
26794 !c! Calculate head-to-tail distances
26795         R2=R2+(chead(k,2)-ctail(k,1))**2
26796        END DO
26797 !c! Pitagoras
26798        R2 = dsqrt(R2)
26799
26800 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26801 !c!     &        +dhead(1,1,itypi,itypj))**2))
26802 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26803 !c!     &        +dhead(2,1,itypi,itypj))**2))
26804 !c------------------------------------------------------------------------
26805 !c Polarization energy
26806        MomoFac2 = (1.0d0 - chi2 * sqom1)
26807        RR2  = R2 * R2 / MomoFac2
26808        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26809        fgb2 = sqrt(RR2  + a12sq * ee2)
26810        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26811        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26812                 / (fgb2 ** 5.0d0)
26813        dFGBdR2 = ( (R2 / MomoFac2)  &
26814               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26815               / (2.0d0 * fgb2)
26816        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26817                 * (2.0d0 - 0.5d0 * ee2) ) &
26818                 / (2.0d0 * fgb2)
26819        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26820 !c!       dPOLdR2 = 0.0d0
26821        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26822 !c!       dPOLdOM1 = 0.0d0
26823        dPOLdOM2 = 0.0d0
26824 !c!-------------------------------------------------------------------
26825 !c! Return the results
26826 !c! (See comments in Eqq)
26827        DO k = 1, 3
26828         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26829        END DO
26830        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26831        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26832        facd2 = d2 * vbld_inv(j+nres)
26833        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26834        DO k = 1, 3
26835         condor = (erhead_tail(k,2) &
26836        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26837
26838         gvdwx(k,i) = gvdwx(k,i) &
26839                    - dPOLdR2 * (erhead_tail(k,2) &
26840        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26841         gvdwx(k,j) = gvdwx(k,j)   &
26842                    + dPOLdR2 * condor
26843
26844         gvdwc(k,i) = gvdwc(k,i) &
26845                    - dPOLdR2 * erhead_tail(k,2)
26846         gvdwc(k,j) = gvdwc(k,j) &
26847                    + dPOLdR2 * erhead_tail(k,2)
26848
26849        END DO
26850       RETURN
26851       END SUBROUTINE enq
26852
26853       SUBROUTINE enq_cat(Epol)
26854       use calc_data
26855       use comm_momo
26856        double precision facd3, adler,epol
26857        alphapol2 = alphapolcat(itypj,itypi)
26858 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26859        R2 = 0.0d0
26860        DO k = 1, 3
26861 !c! Calculate head-to-tail distances
26862         R2=R2+(chead(k,2)-ctail(k,1))**2
26863        END DO
26864 !c! Pitagoras
26865        R2 = dsqrt(R2)
26866
26867 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26868 !c!     &        +dhead(1,1,itypi,itypj))**2))
26869 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26870 !c!     &        +dhead(2,1,itypi,itypj))**2))
26871 !c------------------------------------------------------------------------
26872 !c Polarization energy
26873        MomoFac2 = (1.0d0 - chi2 * sqom1)
26874        RR2  = R2 * R2 / MomoFac2
26875        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26876        fgb2 = sqrt(RR2  + a12sq * ee2)
26877        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26878        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26879                 / (fgb2 ** 5.0d0)
26880        dFGBdR2 = ( (R2 / MomoFac2)  &
26881               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26882               / (2.0d0 * fgb2)
26883        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26884                 * (2.0d0 - 0.5d0 * ee2) ) &
26885                 / (2.0d0 * fgb2)
26886        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26887 !c!       dPOLdR2 = 0.0d0
26888        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26889 !c!       dPOLdOM1 = 0.0d0
26890        dPOLdOM2 = 0.0d0
26891
26892 !c!-------------------------------------------------------------------
26893 !c! Return the results
26894 !c! (See comments in Eqq)
26895        DO k = 1, 3
26896         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26897        END DO
26898        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26899        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26900        facd2 = d2 * vbld_inv(j+nres)
26901        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26902        DO k = 1, 3
26903         condor = (erhead_tail(k,2) &
26904        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26905
26906         gvdwx(k,i) = gvdwx(k,i) &
26907                    - dPOLdR2 * (erhead_tail(k,2) &
26908        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26909         gvdwx(k,j) = gvdwx(k,j)   &
26910                    + dPOLdR2 * condor
26911
26912         gvdwc(k,i) = gvdwc(k,i) &
26913                    - dPOLdR2 * erhead_tail(k,2)
26914         gvdwc(k,j) = gvdwc(k,j) &
26915                    + dPOLdR2 * erhead_tail(k,2)
26916
26917        END DO
26918       RETURN
26919       END SUBROUTINE enq_cat
26920
26921       SUBROUTINE eqd(Ecl,Elj,Epol)
26922       use calc_data
26923       use comm_momo
26924        double precision  facd4, federmaus,ecl,elj,epol
26925        alphapol1 = alphapol(itypi,itypj)
26926        w1        = wqdip(1,itypi,itypj)
26927        w2        = wqdip(2,itypi,itypj)
26928        pis       = sig0head(itypi,itypj)
26929        eps_head   = epshead(itypi,itypj)
26930 !c!-------------------------------------------------------------------
26931 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26932        R1 = 0.0d0
26933        DO k = 1, 3
26934 !c! Calculate head-to-tail distances
26935         R1=R1+(ctail(k,2)-chead(k,1))**2
26936        END DO
26937 !c! Pitagoras
26938        R1 = dsqrt(R1)
26939
26940 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26941 !c!     &        +dhead(1,1,itypi,itypj))**2))
26942 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26943 !c!     &        +dhead(2,1,itypi,itypj))**2))
26944
26945 !c!-------------------------------------------------------------------
26946 !c! ecl
26947        sparrow  = w1 * Qi * om1
26948        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26949        Ecl = sparrow / Rhead**2.0d0 &
26950            - hawk    / Rhead**4.0d0
26951        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26952                  + 4.0d0 * hawk    / Rhead**5.0d0
26953 !c! dF/dom1
26954        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26955 !c! dF/dom2
26956        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26957 !c--------------------------------------------------------------------
26958 !c Polarization energy
26959 !c Epol
26960        MomoFac1 = (1.0d0 - chi1 * sqom2)
26961        RR1  = R1 * R1 / MomoFac1
26962        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26963        fgb1 = sqrt( RR1 + a12sq * ee1)
26964        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26965 !c!       epol = 0.0d0
26966 !c!------------------------------------------------------------------
26967 !c! derivative of Epol is Gpol...
26968        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26969                / (fgb1 ** 5.0d0)
26970        dFGBdR1 = ( (R1 / MomoFac1)  &
26971              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26972              / ( 2.0d0 * fgb1 )
26973        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26974                * (2.0d0 - 0.5d0 * ee1) ) &
26975                / (2.0d0 * fgb1)
26976        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26977 !c!       dPOLdR1 = 0.0d0
26978        dPOLdOM1 = 0.0d0
26979        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26980 !c!       dPOLdOM2 = 0.0d0
26981 !c!-------------------------------------------------------------------
26982 !c! Elj
26983        pom = (pis / Rhead)**6.0d0
26984        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26985 !c! derivative of Elj is Glj
26986        dGLJdR = 4.0d0 * eps_head &
26987           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26988           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26989        DO k = 1, 3
26990         erhead(k) = Rhead_distance(k)/Rhead
26991         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26992        END DO
26993
26994        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26995        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26996        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26997        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26998        facd1 = d1 * vbld_inv(i+nres)
26999        facd2 = d2 * vbld_inv(j+nres)
27000        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27001
27002        DO k = 1, 3
27003         hawk = (erhead_tail(k,1) +  &
27004         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27005
27006         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27007         gvdwx(k,i) = gvdwx(k,i)  &
27008                    - dGCLdR * pom&
27009                    - dPOLdR1 * hawk &
27010                    - dGLJdR * pom
27011
27012         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27013         gvdwx(k,j) = gvdwx(k,j)    &
27014                    + dGCLdR * pom  &
27015                    + dPOLdR1 * (erhead_tail(k,1) &
27016        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27017                    + dGLJdR * pom
27018
27019
27020         gvdwc(k,i) = gvdwc(k,i)          &
27021                    - dGCLdR * erhead(k)  &
27022                    - dPOLdR1 * erhead_tail(k,1) &
27023                    - dGLJdR * erhead(k)
27024
27025         gvdwc(k,j) = gvdwc(k,j)          &
27026                    + dGCLdR * erhead(k)  &
27027                    + dPOLdR1 * erhead_tail(k,1) &
27028                    + dGLJdR * erhead(k)
27029
27030        END DO
27031        RETURN
27032       END SUBROUTINE eqd
27033       SUBROUTINE edq(Ecl,Elj,Epol)
27034 !       IMPLICIT NONE
27035        use comm_momo
27036       use calc_data
27037
27038       double precision  facd3, adler,ecl,elj,epol
27039        alphapol2 = alphapol(itypj,itypi)
27040        w1        = wqdip(1,itypi,itypj)
27041        w2        = wqdip(2,itypi,itypj)
27042        pis       = sig0head(itypi,itypj)
27043        eps_head  = epshead(itypi,itypj)
27044 !c!-------------------------------------------------------------------
27045 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27046        R2 = 0.0d0
27047        DO k = 1, 3
27048 !c! Calculate head-to-tail distances
27049         R2=R2+(chead(k,2)-ctail(k,1))**2
27050        END DO
27051 !c! Pitagoras
27052        R2 = dsqrt(R2)
27053
27054 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27055 !c!     &        +dhead(1,1,itypi,itypj))**2))
27056 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27057 !c!     &        +dhead(2,1,itypi,itypj))**2))
27058
27059
27060 !c!-------------------------------------------------------------------
27061 !c! ecl
27062        sparrow  = w1 * Qi * om1
27063        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27064        ECL = sparrow / Rhead**2.0d0 &
27065            - hawk    / Rhead**4.0d0
27066 !c!-------------------------------------------------------------------
27067 !c! derivative of ecl is Gcl
27068 !c! dF/dr part
27069        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27070                  + 4.0d0 * hawk    / Rhead**5.0d0
27071 !c! dF/dom1
27072        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27073 !c! dF/dom2
27074        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27075 !c--------------------------------------------------------------------
27076 !c Polarization energy
27077 !c Epol
27078        MomoFac2 = (1.0d0 - chi2 * sqom1)
27079        RR2  = R2 * R2 / MomoFac2
27080        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27081        fgb2 = sqrt(RR2  + a12sq * ee2)
27082        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27083        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27084                / (fgb2 ** 5.0d0)
27085        dFGBdR2 = ( (R2 / MomoFac2)  &
27086                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27087                / (2.0d0 * fgb2)
27088        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27089                 * (2.0d0 - 0.5d0 * ee2) ) &
27090                 / (2.0d0 * fgb2)
27091        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27092 !c!       dPOLdR2 = 0.0d0
27093        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27094 !c!       dPOLdOM1 = 0.0d0
27095        dPOLdOM2 = 0.0d0
27096 !c!-------------------------------------------------------------------
27097 !c! Elj
27098        pom = (pis / Rhead)**6.0d0
27099        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27100 !c! derivative of Elj is Glj
27101        dGLJdR = 4.0d0 * eps_head &
27102            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27103            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27104 !c!-------------------------------------------------------------------
27105 !c! Return the results
27106 !c! (see comments in Eqq)
27107        DO k = 1, 3
27108         erhead(k) = Rhead_distance(k)/Rhead
27109         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27110        END DO
27111        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27112        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27113        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27114        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27115        facd1 = d1 * vbld_inv(i+nres)
27116        facd2 = d2 * vbld_inv(j+nres)
27117        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27118        DO k = 1, 3
27119         condor = (erhead_tail(k,2) &
27120        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27121
27122         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27123         gvdwx(k,i) = gvdwx(k,i) &
27124                   - dGCLdR * pom &
27125                   - dPOLdR2 * (erhead_tail(k,2) &
27126        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27127                   - dGLJdR * pom
27128
27129         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27130         gvdwx(k,j) = gvdwx(k,j) &
27131                   + dGCLdR * pom &
27132                   + dPOLdR2 * condor &
27133                   + dGLJdR * pom
27134
27135
27136         gvdwc(k,i) = gvdwc(k,i) &
27137                   - dGCLdR * erhead(k) &
27138                   - dPOLdR2 * erhead_tail(k,2) &
27139                   - dGLJdR * erhead(k)
27140
27141         gvdwc(k,j) = gvdwc(k,j) &
27142                   + dGCLdR * erhead(k) &
27143                   + dPOLdR2 * erhead_tail(k,2) &
27144                   + dGLJdR * erhead(k)
27145
27146        END DO
27147        RETURN
27148       END SUBROUTINE edq
27149
27150       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27151       use comm_momo
27152       use calc_data
27153
27154       double precision  facd3, adler,ecl,elj,epol
27155        alphapol2 = alphapolcat(itypj,itypi)
27156        w1        = wqdipcat(1,itypi,itypj)
27157        w2        = wqdipcat(2,itypi,itypj)
27158        pis       = sig0headcat(itypi,itypj)
27159        eps_head  = epsheadcat(itypi,itypj)
27160 !c!-------------------------------------------------------------------
27161 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27162        R2 = 0.0d0
27163        DO k = 1, 3
27164 !c! Calculate head-to-tail distances
27165         R2=R2+(chead(k,2)-ctail(k,1))**2
27166        END DO
27167 !c! Pitagoras
27168        R2 = dsqrt(R2)
27169
27170 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27171 !c!     &        +dhead(1,1,itypi,itypj))**2))
27172 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27173 !c!     &        +dhead(2,1,itypi,itypj))**2))
27174
27175
27176 !c!-------------------------------------------------------------------
27177 !c! ecl
27178        sparrow  = w1 * Qi * om1
27179        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27180        ECL = sparrow / Rhead**2.0d0 &
27181            - hawk    / Rhead**4.0d0
27182 !c!-------------------------------------------------------------------
27183 !c! derivative of ecl is Gcl
27184 !c! dF/dr part
27185        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27186                  + 4.0d0 * hawk    / Rhead**5.0d0
27187 !c! dF/dom1
27188        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27189 !c! dF/dom2
27190        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27191 !c--------------------------------------------------------------------
27192 !c--------------------------------------------------------------------
27193 !c Polarization energy
27194 !c Epol
27195        MomoFac2 = (1.0d0 - chi2 * sqom1)
27196        RR2  = R2 * R2 / MomoFac2
27197        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27198        fgb2 = sqrt(RR2  + a12sq * ee2)
27199        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27200        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27201                / (fgb2 ** 5.0d0)
27202        dFGBdR2 = ( (R2 / MomoFac2)  &
27203                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27204                / (2.0d0 * fgb2)
27205        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27206                 * (2.0d0 - 0.5d0 * ee2) ) &
27207                 / (2.0d0 * fgb2)
27208        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27209 !c!       dPOLdR2 = 0.0d0
27210        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27211 !c!       dPOLdOM1 = 0.0d0
27212        dPOLdOM2 = 0.0d0
27213 !c!-------------------------------------------------------------------
27214 !c! Elj
27215        pom = (pis / Rhead)**6.0d0
27216        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27217 !c! derivative of Elj is Glj
27218        dGLJdR = 4.0d0 * eps_head &
27219            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27220            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27221 !c!-------------------------------------------------------------------
27222
27223 !c! Return the results
27224 !c! (see comments in Eqq)
27225        DO k = 1, 3
27226         erhead(k) = Rhead_distance(k)/Rhead
27227         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27228        END DO
27229        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27230        erdxj = scalar( erhead(1), dC_norm(1,j) )
27231        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27232        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27233        facd1 = d1 * vbld_inv(i+nres)
27234        facd2 = d2 * vbld_inv(j)
27235        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27236        DO k = 1, 3
27237         condor = (erhead_tail(k,2) &
27238        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27239
27240         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27241         gvdwx(k,i) = gvdwx(k,i) &
27242                   - dGCLdR * pom &
27243                   - dPOLdR2 * (erhead_tail(k,2) &
27244        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27245                   - dGLJdR * pom
27246
27247         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27248         gvdwx(k,j) = gvdwx(k,j) &
27249                   + dGCLdR * pom &
27250                   + dPOLdR2 * condor &
27251                   + dGLJdR * pom
27252
27253
27254         gvdwc(k,i) = gvdwc(k,i) &
27255                   - dGCLdR * erhead(k) &
27256                   - dPOLdR2 * erhead_tail(k,2) &
27257                   - dGLJdR * erhead(k)
27258
27259         gvdwc(k,j) = gvdwc(k,j) &
27260                   + dGCLdR * erhead(k) &
27261                   + dPOLdR2 * erhead_tail(k,2) &
27262                   + dGLJdR * erhead(k)
27263
27264        END DO
27265        RETURN
27266       END SUBROUTINE edq_cat
27267
27268
27269       SUBROUTINE edd(ECL)
27270 !       IMPLICIT NONE
27271        use comm_momo
27272       use calc_data
27273
27274        double precision ecl
27275 !c!       csig = sigiso(itypi,itypj)
27276        w1 = wqdip(1,itypi,itypj)
27277        w2 = wqdip(2,itypi,itypj)
27278 !c!-------------------------------------------------------------------
27279 !c! ECL
27280        fac = (om12 - 3.0d0 * om1 * om2)
27281        c1 = (w1 / (Rhead**3.0d0)) * fac
27282        c2 = (w2 / Rhead ** 6.0d0) &
27283           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27284        ECL = c1 - c2
27285 !c!       write (*,*) "w1 = ", w1
27286 !c!       write (*,*) "w2 = ", w2
27287 !c!       write (*,*) "om1 = ", om1
27288 !c!       write (*,*) "om2 = ", om2
27289 !c!       write (*,*) "om12 = ", om12
27290 !c!       write (*,*) "fac = ", fac
27291 !c!       write (*,*) "c1 = ", c1
27292 !c!       write (*,*) "c2 = ", c2
27293 !c!       write (*,*) "Ecl = ", Ecl
27294 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27295 !c!       write (*,*) "c2_2 = ",
27296 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27297 !c!-------------------------------------------------------------------
27298 !c! dervative of ECL is GCL...
27299 !c! dECL/dr
27300        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27301        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27302           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27303        dGCLdR = c1 - c2
27304 !c! dECL/dom1
27305        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27306        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27307           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27308        dGCLdOM1 = c1 - c2
27309 !c! dECL/dom2
27310        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27311        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27312           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27313        dGCLdOM2 = c1 - c2
27314 !c! dECL/dom12
27315        c1 = w1 / (Rhead ** 3.0d0)
27316        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27317        dGCLdOM12 = c1 - c2
27318 !c!-------------------------------------------------------------------
27319 !c! Return the results
27320 !c! (see comments in Eqq)
27321        DO k= 1, 3
27322         erhead(k) = Rhead_distance(k)/Rhead
27323        END DO
27324        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27325        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27326        facd1 = d1 * vbld_inv(i+nres)
27327        facd2 = d2 * vbld_inv(j+nres)
27328        DO k = 1, 3
27329
27330         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27331         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27332         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27333         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27334
27335         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27336         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27337        END DO
27338        RETURN
27339       END SUBROUTINE edd
27340       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27341 !       IMPLICIT NONE
27342        use comm_momo
27343       use calc_data
27344
27345        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27346        eps_out=80.0d0
27347        itypi = itype(i,1)
27348        itypj = itype(j,1)
27349 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27350 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27351 !c!       t_bath = 300
27352 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27353        Rb=0.001986d0
27354        BetaT = 1.0d0 / (298.0d0 * Rb)
27355 !c! Gay-berne var's
27356        sig0ij = sigma( itypi,itypj )
27357        chi1   = chi( itypi, itypj )
27358        chi2   = chi( itypj, itypi )
27359        chi12  = chi1 * chi2
27360        chip1  = chipp( itypi, itypj )
27361        chip2  = chipp( itypj, itypi )
27362        chip12 = chip1 * chip2
27363 !       chi1=0.0
27364 !       chi2=0.0
27365 !       chi12=0.0
27366 !       chip1=0.0
27367 !       chip2=0.0
27368 !       chip12=0.0
27369 !c! not used by momo potential, but needed by sc_angular which is shared
27370 !c! by all energy_potential subroutines
27371        alf1   = 0.0d0
27372        alf2   = 0.0d0
27373        alf12  = 0.0d0
27374 !c! location, location, location
27375 !       xj  = c( 1, nres+j ) - xi
27376 !       yj  = c( 2, nres+j ) - yi
27377 !       zj  = c( 3, nres+j ) - zi
27378        dxj = dc_norm( 1, nres+j )
27379        dyj = dc_norm( 2, nres+j )
27380        dzj = dc_norm( 3, nres+j )
27381 !c! distance from center of chain(?) to polar/charged head
27382 !c!       write (*,*) "istate = ", 1
27383 !c!       write (*,*) "ii = ", 1
27384 !c!       write (*,*) "jj = ", 1
27385        d1 = dhead(1, 1, itypi, itypj)
27386        d2 = dhead(2, 1, itypi, itypj)
27387 !c! ai*aj from Fgb
27388        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27389 !c!       a12sq = a12sq * a12sq
27390 !c! charge of amino acid itypi is...
27391        Qi  = icharge(itypi)
27392        Qj  = icharge(itypj)
27393        Qij = Qi * Qj
27394 !c! chis1,2,12
27395        chis1 = chis(itypi,itypj)
27396        chis2 = chis(itypj,itypi)
27397        chis12 = chis1 * chis2
27398        sig1 = sigmap1(itypi,itypj)
27399        sig2 = sigmap2(itypi,itypj)
27400 !c!       write (*,*) "sig1 = ", sig1
27401 !c!       write (*,*) "sig2 = ", sig2
27402 !c! alpha factors from Fcav/Gcav
27403        b1cav = alphasur(1,itypi,itypj)
27404 !       b1cav=0.0
27405        b2cav = alphasur(2,itypi,itypj)
27406        b3cav = alphasur(3,itypi,itypj)
27407        b4cav = alphasur(4,itypi,itypj)
27408        wqd = wquad(itypi, itypj)
27409 !c! used by Fgb
27410        eps_in = epsintab(itypi,itypj)
27411        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27412 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27413 !c!-------------------------------------------------------------------
27414 !c! tail location and distance calculations
27415        Rtail = 0.0d0
27416        DO k = 1, 3
27417         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27418         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27419        END DO
27420 !c! tail distances will be themselves usefull elswhere
27421 !c1 (in Gcav, for example)
27422        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27423        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27424        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27425        Rtail = dsqrt(  &
27426           (Rtail_distance(1)*Rtail_distance(1))  &
27427         + (Rtail_distance(2)*Rtail_distance(2))  &
27428         + (Rtail_distance(3)*Rtail_distance(3)))
27429 !c!-------------------------------------------------------------------
27430 !c! Calculate location and distance between polar heads
27431 !c! distance between heads
27432 !c! for each one of our three dimensional space...
27433        d1 = dhead(1, 1, itypi, itypj)
27434        d2 = dhead(2, 1, itypi, itypj)
27435
27436        DO k = 1,3
27437 !c! location of polar head is computed by taking hydrophobic centre
27438 !c! and moving by a d1 * dc_norm vector
27439 !c! see unres publications for very informative images
27440         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27441         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27442 !c! distance
27443 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27444 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27445         Rhead_distance(k) = chead(k,2) - chead(k,1)
27446        END DO
27447 !c! pitagoras (root of sum of squares)
27448        Rhead = dsqrt(   &
27449           (Rhead_distance(1)*Rhead_distance(1)) &
27450         + (Rhead_distance(2)*Rhead_distance(2)) &
27451         + (Rhead_distance(3)*Rhead_distance(3)))
27452 !c!-------------------------------------------------------------------
27453 !c! zero everything that should be zero'ed
27454        Egb = 0.0d0
27455        ECL = 0.0d0
27456        Elj = 0.0d0
27457        Equad = 0.0d0
27458        Epol = 0.0d0
27459        eheadtail = 0.0d0
27460        dGCLdOM1 = 0.0d0
27461        dGCLdOM2 = 0.0d0
27462        dGCLdOM12 = 0.0d0
27463        dPOLdOM1 = 0.0d0
27464        dPOLdOM2 = 0.0d0
27465        RETURN
27466       END SUBROUTINE elgrad_init
27467
27468
27469       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27470       use comm_momo
27471       use calc_data
27472        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27473        eps_out=80.0d0
27474        itypi = itype(i,1)
27475        itypj = itype(j,1)
27476 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27477 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27478 !c!       t_bath = 300
27479 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27480        Rb=0.001986d0
27481        BetaT = 1.0d0 / (298.0d0 * Rb)
27482 !c! Gay-berne var's
27483        sig0ij = sigmacat( itypi,itypj )
27484        chi1   = chicat( itypi, itypj )
27485 !       chi2   = chi( itypj, itypi )
27486        chi2   = 0.0d0
27487 !       chi12  = chi1 * chi2
27488        chi12  = 0.0d0
27489        chip1  = chippcat( itypi, itypj )
27490 !       chip2  = chipp( itypj, itypi )
27491        chip2  = 0.0d0
27492 !       chip12 = chip1 * chip2
27493        chip12 = 0.0d0
27494 !       chi1=0.0
27495 !       chi2=0.0
27496 !       chi12=0.0
27497 !       chip1=0.0
27498 !       chip2=0.0
27499 !       chip12=0.0
27500 !c! not used by momo potential, but needed by sc_angular which is shared
27501 !c! by all energy_potential subroutines
27502        alf1   = 0.0d0
27503        alf2   = 0.0d0
27504        alf12  = 0.0d0
27505 !c! location, location, location
27506 !       xj  = c( 1, nres+j ) - xi
27507 !       yj  = c( 2, nres+j ) - yi
27508 !       zj  = c( 3, nres+j ) - zi
27509        dxj = dc_norm( 1, nres+j )
27510        dyj = dc_norm( 2, nres+j )
27511        dzj = dc_norm( 3, nres+j )
27512 !c! distance from center of chain(?) to polar/charged head
27513        d1 = dheadcat(1, 1, itypi, itypj)
27514        d2 = dheadcat(2, 1, itypi, itypj)
27515 !c! ai*aj from Fgb
27516        a12sq = rborncat(itypi,itypj) * rborncat(itypj,itypi)
27517 !c!       a12sq = a12sq * a12sq
27518 !c! charge of amino acid itypi is...
27519        Qi  = ichargecat(itypi)
27520        Qj  = ichargecat(itypj)
27521        Qij = Qi * Qj
27522 !c! chis1,2,12
27523        chis1 = chiscat(itypi,itypj)
27524 !       chis2 = chis(itypj,itypi)
27525        chis2 = 0.0d0
27526 !       chis12 = chis1 * chis2
27527        chis12 = 0.0d0
27528        sig1 = sigmap1cat(itypi,itypj)
27529        sig2 = sigmap2cat(itypi,itypj)
27530 !c! alpha factors from Fcav/Gcav
27531        b1cav = alphasurcat(1,itypi,itypj)
27532 !       b1cav=0.0
27533        b2cav = alphasurcat(2,itypi,itypj)
27534        b3cav = alphasurcat(3,itypi,itypj)
27535        b4cav = alphasurcat(4,itypi,itypj)
27536        wqd = wquadcat(itypi, itypj)
27537 !c! used by Fgb
27538        eps_in = epsintabcat(itypi,itypj)
27539        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27540 !c!-------------------------------------------------------------------
27541 !c! tail location and distance calculations
27542        Rtail = 0.0d0
27543        DO k = 1, 3
27544         ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27545         ctail(k,2)=c(k,j+nres)-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27546        END DO
27547 !c! tail distances will be themselves usefull elswhere
27548 !c1 (in Gcav, for example)
27549        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27550        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27551        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27552        Rtail = dsqrt(  &
27553           (Rtail_distance(1)*Rtail_distance(1))  &
27554         + (Rtail_distance(2)*Rtail_distance(2))  &
27555         + (Rtail_distance(3)*Rtail_distance(3)))
27556 !c!-------------------------------------------------------------------
27557 !c! Calculate location and distance between polar heads
27558 !c! distance between heads
27559 !c! for each one of our three dimensional space...
27560        d1 = dheadcat(1, 1, itypi, itypj)
27561        d2 = dheadcat(2, 1, itypi, itypj)
27562
27563        DO k = 1,3
27564 !c! location of polar head is computed by taking hydrophobic centre
27565 !c! and moving by a d1 * dc_norm vector
27566 !c! see unres publications for very informative images
27567         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27568         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27569 !c! distance
27570 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27571 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27572         Rhead_distance(k) = chead(k,2) - chead(k,1)
27573        END DO
27574 !c! pitagoras (root of sum of squares)
27575        Rhead = dsqrt(   &
27576           (Rhead_distance(1)*Rhead_distance(1)) &
27577         + (Rhead_distance(2)*Rhead_distance(2)) &
27578         + (Rhead_distance(3)*Rhead_distance(3)))
27579 !c!-------------------------------------------------------------------
27580 !c! zero everything that should be zero'ed
27581        Egb = 0.0d0
27582        ECL = 0.0d0
27583        Elj = 0.0d0
27584        Equad = 0.0d0
27585        Epol = 0.0d0
27586        eheadtail = 0.0d0
27587        dGCLdOM1 = 0.0d0
27588        dGCLdOM2 = 0.0d0
27589        dGCLdOM12 = 0.0d0
27590        dPOLdOM1 = 0.0d0
27591        dPOLdOM2 = 0.0d0
27592        RETURN
27593       END SUBROUTINE elgrad_init_cat
27594
27595
27596       double precision function tschebyshev(m,n,x,y)
27597       implicit none
27598       integer i,m,n
27599       double precision x(n),y,yy(0:maxvar),aux
27600 !c Tschebyshev polynomial. Note that the first term is omitted
27601 !c m=0: the constant term is included
27602 !c m=1: the constant term is not included
27603       yy(0)=1.0d0
27604       yy(1)=y
27605       do i=2,n
27606         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27607       enddo
27608       aux=0.0d0
27609       do i=m,n
27610         aux=aux+x(i)*yy(i)
27611       enddo
27612       tschebyshev=aux
27613       return
27614       end function tschebyshev
27615 !C--------------------------------------------------------------------------
27616       double precision function gradtschebyshev(m,n,x,y)
27617       implicit none
27618       integer i,m,n
27619       double precision x(n+1),y,yy(0:maxvar),aux
27620 !c Tschebyshev polynomial. Note that the first term is omitted
27621 !c m=0: the constant term is included
27622 !c m=1: the constant term is not included
27623       yy(0)=1.0d0
27624       yy(1)=2.0d0*y
27625       do i=2,n
27626         yy(i)=2*y*yy(i-1)-yy(i-2)
27627       enddo
27628       aux=0.0d0
27629       do i=m,n
27630         aux=aux+x(i+1)*yy(i)*(i+1)
27631 !C        print *, x(i+1),yy(i),i
27632       enddo
27633       gradtschebyshev=aux
27634       return
27635       end function gradtschebyshev
27636
27637
27638
27639
27640
27641       end module energy