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       if (oldion.gt.0) then
 854       call ecat_prot(ecation_prot)
 855       else
 856       call ecats_prot_amber(ecation_prot)
 857       endif
 858       if (nres_molec(2).gt.0) then
 859       call eprot_sc_base(escbase)
 860       call epep_sc_base(epepbase)
 861       call eprot_sc_phosphate(escpho)
 862       call eprot_pep_phosphate(epeppho)
 863       else
 864       epepbase=0.0
 865       escbase=0.0
 866       escpho=0.0
 867       epeppho=0.0
 868       endif
 869 !      call ecatcat(ecationcation)
 870 !      print *,"after ebend", wtor_nucl
 871 #ifdef TIMING
 872       time_enecalc=time_enecalc+MPI_Wtime()-time00
 873 #endif
 874 !      print *,"Processor",myrank," computed Uconstr"
 875 #ifdef TIMING
 876       time00=MPI_Wtime()
 877 #endif
 878 !
 879 ! Sum the energies
 880 !
 881       energia(1)=evdw
 882 #ifdef SCP14
 883       energia(2)=evdw2-evdw2_14
 884       energia(18)=evdw2_14
 885 #else
 886       energia(2)=evdw2
 887       energia(18)=0.0d0
 888 #endif
 889 #ifdef SPLITELE
 890       energia(3)=ees
 891       energia(16)=evdw1
 892 #else
 893       energia(3)=ees+evdw1
 894       energia(16)=0.0d0
 895 #endif
 896       energia(4)=ecorr
 897       energia(5)=ecorr5
 898       energia(6)=ecorr6
 899       energia(7)=eel_loc
 900       energia(8)=eello_turn3
 901       energia(9)=eello_turn4
 902       energia(10)=eturn6
 903       energia(11)=ebe
 904       energia(12)=escloc
 905       energia(13)=etors
 906       energia(14)=etors_d
 907       energia(15)=ehpb
 908       energia(19)=edihcnstr
 909       energia(17)=estr
 910       energia(20)=Uconst+Uconst_back
 911       energia(21)=esccor
 912       energia(22)=eliptran
 913       energia(23)=Eafmforce
 914       energia(24)=ethetacnstr
 915       energia(25)=etube
 916 !---------------------------------------------------------------
 917       energia(26)=evdwpp
 918       energia(27)=eespp
 919       energia(28)=evdwpsb
 920       energia(29)=eelpsb
 921       energia(30)=evdwsb
 922       energia(31)=eelsb
 923       energia(32)=estr_nucl
 924       energia(33)=ebe_nucl
 925       energia(34)=esbloc
 926       energia(35)=etors_nucl
 927       energia(36)=etors_d_nucl
 928       energia(37)=ecorr_nucl
 929       energia(38)=ecorr3_nucl
 930 !----------------------------------------------------------------------
 931 !    Here are the energies showed per procesor if the are more processors
 932 !    per molecule then we sum it up in sum_energy subroutine
 933 !      print *," Processor",myrank," calls SUM_ENERGY"
 934       energia(42)=ecation_prot
 935       energia(41)=ecationcation
 936       energia(46)=escbase
 937       energia(47)=epepbase
 938       energia(48)=escpho
 939       energia(49)=epeppho
 940 !      energia(50)=ecations_prot_amber
 941       call sum_energy(energia,.true.)
 942       if (dyn_ss) call dyn_set_nss
 943 !      print *," Processor",myrank," left SUM_ENERGY"
 944 #ifdef TIMING
 945       time_sumene=time_sumene+MPI_Wtime()-time00
 946 #endif
 947 !        call enerprint(energia)
 948 !elwrite(iout,*)"finish etotal"
 949       return
 950       end subroutine etotal
 951 !-----------------------------------------------------------------------------
 952       subroutine sum_energy(energia,reduce)
 953 !      implicit real*8 (a-h,o-z)
 954 !      include 'DIMENSIONS'
 955 #ifndef ISNAN
 956       external proc_proc
 957 #ifdef WINPGI
 958 !MS$ATTRIBUTES C ::  proc_proc
 959 #endif
 960 #endif
 961 #ifdef MPI
 962       include "mpif.h"
 963 #endif
 964 !      include 'COMMON.SETUP'
 965 !      include 'COMMON.IOUNITS'
 966       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 967 !      include 'COMMON.FFIELD'
 968 !      include 'COMMON.DERIV'
 969 !      include 'COMMON.INTERACT'
 970 !      include 'COMMON.SBRIDGE'
 971 !      include 'COMMON.CHAIN'
 972 !      include 'COMMON.VAR'
 973 !      include 'COMMON.CONTROL'
 974 !      include 'COMMON.TIME1'
 975       logical :: reduce
 976       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 977       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 978       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 979         eliptran,etube, Eafmforce,ethetacnstr
 980       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 981                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 982                       ecorr3_nucl
 983       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
 984       real(kind=8) :: escbase,epepbase,escpho,epeppho
 985       integer :: i
 986 #ifdef MPI
 987       integer :: ierr
 988       real(kind=8) :: time00
 989       if (nfgtasks.gt.1 .and. reduce) then
 990
 991 #ifdef DEBUG
 992         write (iout,*) "energies before REDUCE"
 993         call enerprint(energia)
 994         call flush(iout)
 995 #endif
 996         do i=0,n_ene
 997           enebuff(i)=energia(i)
 998         enddo
 999         time00=MPI_Wtime()
1000         call MPI_Barrier(FG_COMM,IERR)
1001         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1002         time00=MPI_Wtime()
1003         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1004           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1005 #ifdef DEBUG
1006         write (iout,*) "energies after REDUCE"
1007         call enerprint(energia)
1008         call flush(iout)
1009 #endif
1010         time_Reduce=time_Reduce+MPI_Wtime()-time00
1011       endif
1012       if (fg_rank.eq.0) then
1013 #endif
1014       evdw=energia(1)
1015 #ifdef SCP14
1016       evdw2=energia(2)+energia(18)
1017       evdw2_14=energia(18)
1018 #else
1019       evdw2=energia(2)
1020 #endif
1021 #ifdef SPLITELE
1022       ees=energia(3)
1023       evdw1=energia(16)
1024 #else
1025       ees=energia(3)
1026       evdw1=0.0d0
1027 #endif
1028       ecorr=energia(4)
1029       ecorr5=energia(5)
1030       ecorr6=energia(6)
1031       eel_loc=energia(7)
1032       eello_turn3=energia(8)
1033       eello_turn4=energia(9)
1034       eturn6=energia(10)
1035       ebe=energia(11)
1036       escloc=energia(12)
1037       etors=energia(13)
1038       etors_d=energia(14)
1039       ehpb=energia(15)
1040       edihcnstr=energia(19)
1041       estr=energia(17)
1042       Uconst=energia(20)
1043       esccor=energia(21)
1044       eliptran=energia(22)
1045       Eafmforce=energia(23)
1046       ethetacnstr=energia(24)
1047       etube=energia(25)
1048       evdwpp=energia(26)
1049       eespp=energia(27)
1050       evdwpsb=energia(28)
1051       eelpsb=energia(29)
1052       evdwsb=energia(30)
1053       eelsb=energia(31)
1054       estr_nucl=energia(32)
1055       ebe_nucl=energia(33)
1056       esbloc=energia(34)
1057       etors_nucl=energia(35)
1058       etors_d_nucl=energia(36)
1059       ecorr_nucl=energia(37)
1060       ecorr3_nucl=energia(38)
1061       ecation_prot=energia(42)
1062       ecationcation=energia(41)
1063       escbase=energia(46)
1064       epepbase=energia(47)
1065       escpho=energia(48)
1066       epeppho=energia(49)
1067 !      ecations_prot_amber=energia(50)
1068
1069 !      energia(41)=ecation_prot
1070 !      energia(42)=ecationcation
1071
1072
1073 #ifdef SPLITELE
1074       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1075        +wang*ebe+wtor*etors+wscloc*escloc &
1076        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1077        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1078        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1079        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1080        +Eafmforce+ethetacnstr  &
1081        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1082        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1083        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1084        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1085        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1086        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1087 #else
1088       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1089        +wang*ebe+wtor*etors+wscloc*escloc &
1090        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1091        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1092        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1093        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1094        +Eafmforce+ethetacnstr &
1095        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1096        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1097        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1098        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1099        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1100        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1101 #endif
1102       energia(0)=etot
1103 ! detecting NaNQ
1104 #ifdef ISNAN
1105 #ifdef AIX
1106       if (isnan(etot).ne.0) energia(0)=1.0d+99
1107 #else
1108       if (isnan(etot)) energia(0)=1.0d+99
1109 #endif
1110 #else
1111       i=0
1112 #ifdef WINPGI
1113       idumm=proc_proc(etot,i)
1114 #else
1115       call proc_proc(etot,i)
1116 #endif
1117       if(i.eq.1)energia(0)=1.0d+99
1118 #endif
1119 #ifdef MPI
1120       endif
1121 #endif
1122 !      call enerprint(energia)
1123       call flush(iout)
1124       return
1125       end subroutine sum_energy
1126 !-----------------------------------------------------------------------------
1127       subroutine rescale_weights(t_bath)
1128 !      implicit real*8 (a-h,o-z)
1129 #ifdef MPI
1130       include 'mpif.h'
1131 #endif
1132 !      include 'DIMENSIONS'
1133 !      include 'COMMON.IOUNITS'
1134 !      include 'COMMON.FFIELD'
1135 !      include 'COMMON.SBRIDGE'
1136       real(kind=8) :: kfac=2.4d0
1137       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1138 !el local variables
1139       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1140       real(kind=8) :: T0=3.0d2
1141       integer :: ierror
1142 !      facT=temp0/t_bath
1143 !      facT=2*temp0/(t_bath+temp0)
1144       if (rescale_mode.eq.0) then
1145         facT(1)=1.0d0
1146         facT(2)=1.0d0
1147         facT(3)=1.0d0
1148         facT(4)=1.0d0
1149         facT(5)=1.0d0
1150         facT(6)=1.0d0
1151       else if (rescale_mode.eq.1) then
1152         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1153         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1154         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1155         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1156         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1157 #ifdef WHAM_RUN
1158 !#if defined(WHAM_RUN) || defined(CLUSTER)
1159 #if defined(FUNCTH)
1160 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1161         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1162 #elif defined(FUNCT)
1163         facT(6)=t_bath/T0
1164 #else
1165         facT(6)=1.0d0
1166 #endif
1167 #endif
1168       else if (rescale_mode.eq.2) then
1169         x=t_bath/temp0
1170         x2=x*x
1171         x3=x2*x
1172         x4=x3*x
1173         x5=x4*x
1174         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1175         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1176         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1177         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1178         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1179 #ifdef WHAM_RUN
1180 !#if defined(WHAM_RUN) || defined(CLUSTER)
1181 #if defined(FUNCTH)
1182         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1183 #elif defined(FUNCT)
1184         facT(6)=t_bath/T0
1185 #else
1186         facT(6)=1.0d0
1187 #endif
1188 #endif
1189       else
1190         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1191         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1192 #ifdef MPI
1193        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1194 #endif
1195        stop 555
1196       endif
1197       welec=weights(3)*fact(1)
1198       wcorr=weights(4)*fact(3)
1199       wcorr5=weights(5)*fact(4)
1200       wcorr6=weights(6)*fact(5)
1201       wel_loc=weights(7)*fact(2)
1202       wturn3=weights(8)*fact(2)
1203       wturn4=weights(9)*fact(3)
1204       wturn6=weights(10)*fact(5)
1205       wtor=weights(13)*fact(1)
1206       wtor_d=weights(14)*fact(2)
1207       wsccor=weights(21)*fact(1)
1208       welpsb=weights(28)*fact(1)
1209       wcorr_nucl= weights(37)*fact(1)
1210       wcorr3_nucl=weights(38)*fact(2)
1211       wtor_nucl=  weights(35)*fact(1)
1212       wtor_d_nucl=weights(36)*fact(2)
1213       wpepbase=weights(47)*fact(1)
1214       return
1215       end subroutine rescale_weights
1216 !-----------------------------------------------------------------------------
1217       subroutine enerprint(energia)
1218 !      implicit real*8 (a-h,o-z)
1219 !      include 'DIMENSIONS'
1220 !      include 'COMMON.IOUNITS'
1221 !      include 'COMMON.FFIELD'
1222 !      include 'COMMON.SBRIDGE'
1223 !      include 'COMMON.MD'
1224       real(kind=8) :: energia(0:n_ene)
1225 !el local variables
1226       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1227       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1228       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1229        etube,ethetacnstr,Eafmforce
1230       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1231                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1232                       ecorr3_nucl
1233       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1234       real(kind=8) :: escbase,epepbase,escpho,epeppho
1235
1236       etot=energia(0)
1237       evdw=energia(1)
1238       evdw2=energia(2)
1239 #ifdef SCP14
1240       evdw2=energia(2)+energia(18)
1241 #else
1242       evdw2=energia(2)
1243 #endif
1244       ees=energia(3)
1245 #ifdef SPLITELE
1246       evdw1=energia(16)
1247 #endif
1248       ecorr=energia(4)
1249       ecorr5=energia(5)
1250       ecorr6=energia(6)
1251       eel_loc=energia(7)
1252       eello_turn3=energia(8)
1253       eello_turn4=energia(9)
1254       eello_turn6=energia(10)
1255       ebe=energia(11)
1256       escloc=energia(12)
1257       etors=energia(13)
1258       etors_d=energia(14)
1259       ehpb=energia(15)
1260       edihcnstr=energia(19)
1261       estr=energia(17)
1262       Uconst=energia(20)
1263       esccor=energia(21)
1264       eliptran=energia(22)
1265       Eafmforce=energia(23)
1266       ethetacnstr=energia(24)
1267       etube=energia(25)
1268       evdwpp=energia(26)
1269       eespp=energia(27)
1270       evdwpsb=energia(28)
1271       eelpsb=energia(29)
1272       evdwsb=energia(30)
1273       eelsb=energia(31)
1274       estr_nucl=energia(32)
1275       ebe_nucl=energia(33)
1276       esbloc=energia(34)
1277       etors_nucl=energia(35)
1278       etors_d_nucl=energia(36)
1279       ecorr_nucl=energia(37)
1280       ecorr3_nucl=energia(38)
1281       ecation_prot=energia(42)
1282       ecationcation=energia(41)
1283       escbase=energia(46)
1284       epepbase=energia(47)
1285       escpho=energia(48)
1286       epeppho=energia(49)
1287 !      ecations_prot_amber=energia(50)
1288 #ifdef SPLITELE
1289       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1290         estr,wbond,ebe,wang,&
1291         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1292         ecorr,wcorr,&
1293         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1294         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1295         edihcnstr,ethetacnstr,ebr*nss,&
1296         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1297         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1298         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1299         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1300         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1301         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1302         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1303         etot
1304    10 format (/'Virtual-chain energies:'// &
1305        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1306        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1307        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1308        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1309        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1310        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1311        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1312        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1313        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1314        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1315        ' (SS bridges & dist. cnstr.)'/ &
1316        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1317        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1318        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1319        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1320        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1321        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1322        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1323        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1324        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1325        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1326        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1327        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1328        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1329        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1330        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1331        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1332        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1333        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1334        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1335        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1336        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1337        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1338        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1339        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1340        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1341        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1342        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1343        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1344        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1345        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1346        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1347        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1348        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1349        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1350        'ETOT=  ',1pE16.6,' (total)')
1351 #else
1352       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1353         estr,wbond,ebe,wang,&
1354         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1355         ecorr,wcorr,&
1356         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1357         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1358         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1359         etube,wtube, &
1360         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1361         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1362         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1363         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1364         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1365         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1366         etot
1367    10 format (/'Virtual-chain energies:'// &
1368        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1369        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1370        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1371        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1372        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1373        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1374        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1375        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1376        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1377        ' (SS bridges & dist. cnstr.)'/ &
1378        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1379        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1380        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1381        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1382        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1383        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1384        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1385        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1386        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1387        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1388        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1389        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1390        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1391        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1392        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1393        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1394        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1395        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1396        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1397        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1398        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1399        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1400        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1401        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1402        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1403        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1404        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1405        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1406        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1407        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1408        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1409        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1410        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1411        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1412        'ETOT=  ',1pE16.6,' (total)')
1413 #endif
1414       return
1415       end subroutine enerprint
1416 !-----------------------------------------------------------------------------
1417       subroutine elj(evdw)
1418 !
1419 ! This subroutine calculates the interaction energy of nonbonded side chains
1420 ! assuming the LJ potential of interaction.
1421 !
1422 !      implicit real*8 (a-h,o-z)
1423 !      include 'DIMENSIONS'
1424       real(kind=8),parameter :: accur=1.0d-10
1425 !      include 'COMMON.GEO'
1426 !      include 'COMMON.VAR'
1427 !      include 'COMMON.LOCAL'
1428 !      include 'COMMON.CHAIN'
1429 !      include 'COMMON.DERIV'
1430 !      include 'COMMON.INTERACT'
1431 !      include 'COMMON.TORSION'
1432 !      include 'COMMON.SBRIDGE'
1433 !      include 'COMMON.NAMES'
1434 !      include 'COMMON.IOUNITS'
1435 !      include 'COMMON.CONTACTS'
1436       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1437       integer :: num_conti
1438 !el local variables
1439       integer :: i,itypi,iint,j,itypi1,itypj,k
1440       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1441       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1442       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1443
1444 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1445       evdw=0.0D0
1446 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1447 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1448 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1449 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1450
1451       do i=iatsc_s,iatsc_e
1452         itypi=iabs(itype(i,1))
1453         if (itypi.eq.ntyp1) cycle
1454         itypi1=iabs(itype(i+1,1))
1455         xi=c(1,nres+i)
1456         yi=c(2,nres+i)
1457         zi=c(3,nres+i)
1458 ! Change 12/1/95
1459         num_conti=0
1460 !
1461 ! Calculate SC interaction energy.
1462 !
1463         do iint=1,nint_gr(i)
1464 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1465 !d   &                  'iend=',iend(i,iint)
1466           do j=istart(i,iint),iend(i,iint)
1467             itypj=iabs(itype(j,1))
1468             if (itypj.eq.ntyp1) cycle
1469             xj=c(1,nres+j)-xi
1470             yj=c(2,nres+j)-yi
1471             zj=c(3,nres+j)-zi
1472 ! Change 12/1/95 to calculate four-body interactions
1473             rij=xj*xj+yj*yj+zj*zj
1474             rrij=1.0D0/rij
1475 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1476             eps0ij=eps(itypi,itypj)
1477             fac=rrij**expon2
1478             e1=fac*fac*aa_aq(itypi,itypj)
1479             e2=fac*bb_aq(itypi,itypj)
1480             evdwij=e1+e2
1481 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1482 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1483 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1484 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1485 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1486 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1487             evdw=evdw+evdwij
1488 !
1489 ! Calculate the components of the gradient in DC and X
1490 !
1491             fac=-rrij*(e1+evdwij)
1492             gg(1)=xj*fac
1493             gg(2)=yj*fac
1494             gg(3)=zj*fac
1495             do k=1,3
1496               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1497               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1498               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1499               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1500             enddo
1501 !grad            do k=i,j-1
1502 !grad              do l=1,3
1503 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1504 !grad              enddo
1505 !grad            enddo
1506 !
1507 ! 12/1/95, revised on 5/20/97
1508 !
1509 ! Calculate the contact function. The ith column of the array JCONT will
1510 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1511 ! greater than I). The arrays FACONT and GACONT will contain the values of
1512 ! the contact function and its derivative.
1513 !
1514 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1515 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1516 ! Uncomment next line, if the correlation interactions are contact function only
1517             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1518               rij=dsqrt(rij)
1519               sigij=sigma(itypi,itypj)
1520               r0ij=rs0(itypi,itypj)
1521 !
1522 ! Check whether the SC's are not too far to make a contact.
1523 !
1524               rcut=1.5d0*r0ij
1525               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1526 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1527 !
1528               if (fcont.gt.0.0D0) then
1529 ! If the SC-SC distance if close to sigma, apply spline.
1530 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1531 !Adam &             fcont1,fprimcont1)
1532 !Adam           fcont1=1.0d0-fcont1
1533 !Adam           if (fcont1.gt.0.0d0) then
1534 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1535 !Adam             fcont=fcont*fcont1
1536 !Adam           endif
1537 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1538 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1539 !ga             do k=1,3
1540 !ga               gg(k)=gg(k)*eps0ij
1541 !ga             enddo
1542 !ga             eps0ij=-evdwij*eps0ij
1543 ! Uncomment for AL's type of SC correlation interactions.
1544 !adam           eps0ij=-evdwij
1545                 num_conti=num_conti+1
1546                 jcont(num_conti,i)=j
1547                 facont(num_conti,i)=fcont*eps0ij
1548                 fprimcont=eps0ij*fprimcont/rij
1549                 fcont=expon*fcont
1550 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1551 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1552 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1553 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1554                 gacont(1,num_conti,i)=-fprimcont*xj
1555                 gacont(2,num_conti,i)=-fprimcont*yj
1556                 gacont(3,num_conti,i)=-fprimcont*zj
1557 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1558 !d              write (iout,'(2i3,3f10.5)')
1559 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1560               endif
1561             endif
1562           enddo      ! j
1563         enddo        ! iint
1564 ! Change 12/1/95
1565         num_cont(i)=num_conti
1566       enddo          ! i
1567       do i=1,nct
1568         do j=1,3
1569           gvdwc(j,i)=expon*gvdwc(j,i)
1570           gvdwx(j,i)=expon*gvdwx(j,i)
1571         enddo
1572       enddo
1573 !******************************************************************************
1574 !
1575 !                              N O T E !!!
1576 !
1577 ! To save time, the factor of EXPON has been extracted from ALL components
1578 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1579 ! use!
1580 !
1581 !******************************************************************************
1582       return
1583       end subroutine elj
1584 !-----------------------------------------------------------------------------
1585       subroutine eljk(evdw)
1586 !
1587 ! This subroutine calculates the interaction energy of nonbonded side chains
1588 ! assuming the LJK potential of interaction.
1589 !
1590 !      implicit real*8 (a-h,o-z)
1591 !      include 'DIMENSIONS'
1592 !      include 'COMMON.GEO'
1593 !      include 'COMMON.VAR'
1594 !      include 'COMMON.LOCAL'
1595 !      include 'COMMON.CHAIN'
1596 !      include 'COMMON.DERIV'
1597 !      include 'COMMON.INTERACT'
1598 !      include 'COMMON.IOUNITS'
1599 !      include 'COMMON.NAMES'
1600       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1601       logical :: scheck
1602 !el local variables
1603       integer :: i,iint,j,itypi,itypi1,k,itypj
1604       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1605       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1606
1607 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1608       evdw=0.0D0
1609       do i=iatsc_s,iatsc_e
1610         itypi=iabs(itype(i,1))
1611         if (itypi.eq.ntyp1) cycle
1612         itypi1=iabs(itype(i+1,1))
1613         xi=c(1,nres+i)
1614         yi=c(2,nres+i)
1615         zi=c(3,nres+i)
1616 !
1617 ! Calculate SC interaction energy.
1618 !
1619         do iint=1,nint_gr(i)
1620           do j=istart(i,iint),iend(i,iint)
1621             itypj=iabs(itype(j,1))
1622             if (itypj.eq.ntyp1) cycle
1623             xj=c(1,nres+j)-xi
1624             yj=c(2,nres+j)-yi
1625             zj=c(3,nres+j)-zi
1626             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1627             fac_augm=rrij**expon
1628             e_augm=augm(itypi,itypj)*fac_augm
1629             r_inv_ij=dsqrt(rrij)
1630             rij=1.0D0/r_inv_ij
1631             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1632             fac=r_shift_inv**expon
1633             e1=fac*fac*aa_aq(itypi,itypj)
1634             e2=fac*bb_aq(itypi,itypj)
1635             evdwij=e_augm+e1+e2
1636 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1637 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1638 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1639 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1640 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1641 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1642 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1643             evdw=evdw+evdwij
1644 !
1645 ! Calculate the components of the gradient in DC and X
1646 !
1647             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1648             gg(1)=xj*fac
1649             gg(2)=yj*fac
1650             gg(3)=zj*fac
1651             do k=1,3
1652               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1653               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1654               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1655               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1656             enddo
1657 !grad            do k=i,j-1
1658 !grad              do l=1,3
1659 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1660 !grad              enddo
1661 !grad            enddo
1662           enddo      ! j
1663         enddo        ! iint
1664       enddo          ! i
1665       do i=1,nct
1666         do j=1,3
1667           gvdwc(j,i)=expon*gvdwc(j,i)
1668           gvdwx(j,i)=expon*gvdwx(j,i)
1669         enddo
1670       enddo
1671       return
1672       end subroutine eljk
1673 !-----------------------------------------------------------------------------
1674       subroutine ebp(evdw)
1675 !
1676 ! This subroutine calculates the interaction energy of nonbonded side chains
1677 ! assuming the Berne-Pechukas potential of interaction.
1678 !
1679       use comm_srutu
1680       use calc_data
1681 !      implicit real*8 (a-h,o-z)
1682 !      include 'DIMENSIONS'
1683 !      include 'COMMON.GEO'
1684 !      include 'COMMON.VAR'
1685 !      include 'COMMON.LOCAL'
1686 !      include 'COMMON.CHAIN'
1687 !      include 'COMMON.DERIV'
1688 !      include 'COMMON.NAMES'
1689 !      include 'COMMON.INTERACT'
1690 !      include 'COMMON.IOUNITS'
1691 !      include 'COMMON.CALC'
1692       use comm_srutu
1693 !el      integer :: icall
1694 !el      common /srutu/ icall
1695 !     double precision rrsave(maxdim)
1696       logical :: lprn
1697 !el local variables
1698       integer :: iint,itypi,itypi1,itypj
1699       real(kind=8) :: rrij,xi,yi,zi
1700       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1701
1702 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1703       evdw=0.0D0
1704 !     if (icall.eq.0) then
1705 !       lprn=.true.
1706 !     else
1707         lprn=.false.
1708 !     endif
1709 !el      ind=0
1710       do i=iatsc_s,iatsc_e
1711         itypi=iabs(itype(i,1))
1712         if (itypi.eq.ntyp1) cycle
1713         itypi1=iabs(itype(i+1,1))
1714         xi=c(1,nres+i)
1715         yi=c(2,nres+i)
1716         zi=c(3,nres+i)
1717         dxi=dc_norm(1,nres+i)
1718         dyi=dc_norm(2,nres+i)
1719         dzi=dc_norm(3,nres+i)
1720 !        dsci_inv=dsc_inv(itypi)
1721         dsci_inv=vbld_inv(i+nres)
1722 !
1723 ! Calculate SC interaction energy.
1724 !
1725         do iint=1,nint_gr(i)
1726           do j=istart(i,iint),iend(i,iint)
1727 !el            ind=ind+1
1728             itypj=iabs(itype(j,1))
1729             if (itypj.eq.ntyp1) cycle
1730 !            dscj_inv=dsc_inv(itypj)
1731             dscj_inv=vbld_inv(j+nres)
1732             chi1=chi(itypi,itypj)
1733             chi2=chi(itypj,itypi)
1734             chi12=chi1*chi2
1735             chip1=chip(itypi)
1736             chip2=chip(itypj)
1737             chip12=chip1*chip2
1738             alf1=alp(itypi)
1739             alf2=alp(itypj)
1740             alf12=0.5D0*(alf1+alf2)
1741 ! For diagnostics only!!!
1742 !           chi1=0.0D0
1743 !           chi2=0.0D0
1744 !           chi12=0.0D0
1745 !           chip1=0.0D0
1746 !           chip2=0.0D0
1747 !           chip12=0.0D0
1748 !           alf1=0.0D0
1749 !           alf2=0.0D0
1750 !           alf12=0.0D0
1751             xj=c(1,nres+j)-xi
1752             yj=c(2,nres+j)-yi
1753             zj=c(3,nres+j)-zi
1754             dxj=dc_norm(1,nres+j)
1755             dyj=dc_norm(2,nres+j)
1756             dzj=dc_norm(3,nres+j)
1757             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1758 !d          if (icall.eq.0) then
1759 !d            rrsave(ind)=rrij
1760 !d          else
1761 !d            rrij=rrsave(ind)
1762 !d          endif
1763             rij=dsqrt(rrij)
1764 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1765             call sc_angular
1766 ! Calculate whole angle-dependent part of epsilon and contributions
1767 ! to its derivatives
1768             fac=(rrij*sigsq)**expon2
1769             e1=fac*fac*aa_aq(itypi,itypj)
1770             e2=fac*bb_aq(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             evdwij=evdwij*eps2rt*eps3rt
1775             evdw=evdw+evdwij
1776             if (lprn) then
1777             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1778             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1779 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1780 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1781 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1782 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1783 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1784 !d     &        evdwij
1785             endif
1786 ! Calculate gradient components.
1787             e1=e1*eps1*eps2rt**2*eps3rt**2
1788             fac=-expon*(e1+evdwij)
1789             sigder=fac/sigsq
1790             fac=rrij*fac
1791 ! Calculate radial part of the gradient
1792             gg(1)=xj*fac
1793             gg(2)=yj*fac
1794             gg(3)=zj*fac
1795 ! Calculate the angular part of the gradient and sum add the contributions
1796 ! to the appropriate components of the Cartesian gradient.
1797             call sc_grad
1798           enddo      ! j
1799         enddo        ! iint
1800       enddo          ! i
1801 !     stop
1802       return
1803       end subroutine ebp
1804 !-----------------------------------------------------------------------------
1805       subroutine egb(evdw)
1806 !
1807 ! This subroutine calculates the interaction energy of nonbonded side chains
1808 ! assuming the Gay-Berne potential of interaction.
1809 !
1810       use calc_data
1811 !      implicit real*8 (a-h,o-z)
1812 !      include 'DIMENSIONS'
1813 !      include 'COMMON.GEO'
1814 !      include 'COMMON.VAR'
1815 !      include 'COMMON.LOCAL'
1816 !      include 'COMMON.CHAIN'
1817 !      include 'COMMON.DERIV'
1818 !      include 'COMMON.NAMES'
1819 !      include 'COMMON.INTERACT'
1820 !      include 'COMMON.IOUNITS'
1821 !      include 'COMMON.CALC'
1822 !      include 'COMMON.CONTROL'
1823 !      include 'COMMON.SBRIDGE'
1824       logical :: lprn
1825 !el local variables
1826       integer :: iint,itypi,itypi1,itypj,subchap
1827       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1828       real(kind=8) :: evdw,sig0ij
1829       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1830                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1831                     sslipi,sslipj,faclip
1832       integer :: ii
1833       real(kind=8) :: fracinbuf
1834
1835 !cccc      energy_dec=.false.
1836 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1837       evdw=0.0D0
1838       lprn=.false.
1839 !     if (icall.eq.0) lprn=.false.
1840 !el      ind=0
1841       dCAVdOM2=0.0d0
1842       dGCLdOM2=0.0d0
1843       dPOLdOM2=0.0d0
1844       dCAVdOM1=0.0d0
1845       dGCLdOM1=0.0d0
1846       dPOLdOM1=0.0d0
1847
1848
1849       do i=iatsc_s,iatsc_e
1850 !C        print *,"I am in EVDW",i
1851         itypi=iabs(itype(i,1))
1852 !        if (i.ne.47) cycle
1853         if (itypi.eq.ntyp1) cycle
1854         itypi1=iabs(itype(i+1,1))
1855         xi=c(1,nres+i)
1856         yi=c(2,nres+i)
1857         zi=c(3,nres+i)
1858           xi=dmod(xi,boxxsize)
1859           if (xi.lt.0) xi=xi+boxxsize
1860           yi=dmod(yi,boxysize)
1861           if (yi.lt.0) yi=yi+boxysize
1862           zi=dmod(zi,boxzsize)
1863           if (zi.lt.0) zi=zi+boxzsize
1864
1865        if ((zi.gt.bordlipbot)  &
1866         .and.(zi.lt.bordliptop)) then
1867 !C the energy transfer exist
1868         if (zi.lt.buflipbot) then
1869 !C what fraction I am in
1870          fracinbuf=1.0d0-  &
1871               ((zi-bordlipbot)/lipbufthick)
1872 !C lipbufthick is thickenes of lipid buffore
1873          sslipi=sscalelip(fracinbuf)
1874          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1875         elseif (zi.gt.bufliptop) then
1876          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1877          sslipi=sscalelip(fracinbuf)
1878          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1879         else
1880          sslipi=1.0d0
1881          ssgradlipi=0.0
1882         endif
1883        else
1884          sslipi=0.0d0
1885          ssgradlipi=0.0
1886        endif
1887 !       print *, sslipi,ssgradlipi
1888         dxi=dc_norm(1,nres+i)
1889         dyi=dc_norm(2,nres+i)
1890         dzi=dc_norm(3,nres+i)
1891 !        dsci_inv=dsc_inv(itypi)
1892         dsci_inv=vbld_inv(i+nres)
1893 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1894 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1895 !
1896 ! Calculate SC interaction energy.
1897 !
1898         do iint=1,nint_gr(i)
1899           do j=istart(i,iint),iend(i,iint)
1900             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1901               call dyn_ssbond_ene(i,j,evdwij)
1902               evdw=evdw+evdwij
1903               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1904                               'evdw',i,j,evdwij,' ss'
1905 !              if (energy_dec) write (iout,*) &
1906 !                              'evdw',i,j,evdwij,' ss'
1907              do k=j+1,iend(i,iint)
1908 !C search over all next residues
1909               if (dyn_ss_mask(k)) then
1910 !C check if they are cysteins
1911 !C              write(iout,*) 'k=',k
1912
1913 !c              write(iout,*) "PRZED TRI", evdwij
1914 !               evdwij_przed_tri=evdwij
1915               call triple_ssbond_ene(i,j,k,evdwij)
1916 !c               if(evdwij_przed_tri.ne.evdwij) then
1917 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1918 !c               endif
1919
1920 !c              write(iout,*) "PO TRI", evdwij
1921 !C call the energy function that removes the artifical triple disulfide
1922 !C bond the soubroutine is located in ssMD.F
1923               evdw=evdw+evdwij
1924               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1925                             'evdw',i,j,evdwij,'tss'
1926               endif!dyn_ss_mask(k)
1927              enddo! k
1928             ELSE
1929 !el            ind=ind+1
1930             itypj=iabs(itype(j,1))
1931             if (itypj.eq.ntyp1) cycle
1932 !             if (j.ne.78) cycle
1933 !            dscj_inv=dsc_inv(itypj)
1934             dscj_inv=vbld_inv(j+nres)
1935 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1936 !              1.0d0/vbld(j+nres) !d
1937 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1938             sig0ij=sigma(itypi,itypj)
1939             chi1=chi(itypi,itypj)
1940             chi2=chi(itypj,itypi)
1941             chi12=chi1*chi2
1942             chip1=chip(itypi)
1943             chip2=chip(itypj)
1944             chip12=chip1*chip2
1945             alf1=alp(itypi)
1946             alf2=alp(itypj)
1947             alf12=0.5D0*(alf1+alf2)
1948 ! For diagnostics only!!!
1949 !           chi1=0.0D0
1950 !           chi2=0.0D0
1951 !           chi12=0.0D0
1952 !           chip1=0.0D0
1953 !           chip2=0.0D0
1954 !           chip12=0.0D0
1955 !           alf1=0.0D0
1956 !           alf2=0.0D0
1957 !           alf12=0.0D0
1958            xj=c(1,nres+j)
1959            yj=c(2,nres+j)
1960            zj=c(3,nres+j)
1961           xj=dmod(xj,boxxsize)
1962           if (xj.lt.0) xj=xj+boxxsize
1963           yj=dmod(yj,boxysize)
1964           if (yj.lt.0) yj=yj+boxysize
1965           zj=dmod(zj,boxzsize)
1966           if (zj.lt.0) zj=zj+boxzsize
1967 !          print *,"tu",xi,yi,zi,xj,yj,zj
1968 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1969 ! this fragment set correct epsilon for lipid phase
1970        if ((zj.gt.bordlipbot)  &
1971        .and.(zj.lt.bordliptop)) then
1972 !C the energy transfer exist
1973         if (zj.lt.buflipbot) then
1974 !C what fraction I am in
1975          fracinbuf=1.0d0-     &
1976              ((zj-bordlipbot)/lipbufthick)
1977 !C lipbufthick is thickenes of lipid buffore
1978          sslipj=sscalelip(fracinbuf)
1979          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1980         elseif (zj.gt.bufliptop) then
1981          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1982          sslipj=sscalelip(fracinbuf)
1983          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1984         else
1985          sslipj=1.0d0
1986          ssgradlipj=0.0
1987         endif
1988        else
1989          sslipj=0.0d0
1990          ssgradlipj=0.0
1991        endif
1992       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1993        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1994       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1995        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1996 !------------------------------------------------
1997       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1998       xj_safe=xj
1999       yj_safe=yj
2000       zj_safe=zj
2001       subchap=0
2002       do xshift=-1,1
2003       do yshift=-1,1
2004       do zshift=-1,1
2005           xj=xj_safe+xshift*boxxsize
2006           yj=yj_safe+yshift*boxysize
2007           zj=zj_safe+zshift*boxzsize
2008           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2009           if(dist_temp.lt.dist_init) then
2010             dist_init=dist_temp
2011             xj_temp=xj
2012             yj_temp=yj
2013             zj_temp=zj
2014             subchap=1
2015           endif
2016        enddo
2017        enddo
2018        enddo
2019        if (subchap.eq.1) then
2020           xj=xj_temp-xi
2021           yj=yj_temp-yi
2022           zj=zj_temp-zi
2023        else
2024           xj=xj_safe-xi
2025           yj=yj_safe-yi
2026           zj=zj_safe-zi
2027        endif
2028             dxj=dc_norm(1,nres+j)
2029             dyj=dc_norm(2,nres+j)
2030             dzj=dc_norm(3,nres+j)
2031 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2032 !            write (iout,*) "j",j," dc_norm",& !d
2033 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2034 !          write(iout,*)"rrij ",rrij
2035 !          write(iout,*)"xj yj zj ", xj, yj, zj
2036 !          write(iout,*)"xi yi zi ", xi, yi, zi
2037 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2038             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2039             rij=dsqrt(rrij)
2040             sss_ele_cut=sscale_ele(1.0d0/(rij))
2041             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2042 !            print *,sss_ele_cut,sss_ele_grad,&
2043 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2044             if (sss_ele_cut.le.0.0) cycle
2045 ! Calculate angle-dependent terms of energy and contributions to their
2046 ! derivatives.
2047             call sc_angular
2048             sigsq=1.0D0/sigsq
2049             sig=sig0ij*dsqrt(sigsq)
2050             rij_shift=1.0D0/rij-sig+sig0ij
2051 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2052 !            "sig0ij",sig0ij
2053 ! for diagnostics; uncomment
2054 !            rij_shift=1.2*sig0ij
2055 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2056             if (rij_shift.le.0.0D0) then
2057               evdw=1.0D20
2058 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2059 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2060 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2061               return
2062             endif
2063             sigder=-sig*sigsq
2064 !---------------------------------------------------------------
2065             rij_shift=1.0D0/rij_shift
2066             fac=rij_shift**expon
2067             faclip=fac
2068             e1=fac*fac*aa!(itypi,itypj)
2069             e2=fac*bb!(itypi,itypj)
2070             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2071             eps2der=evdwij*eps3rt
2072             eps3der=evdwij*eps2rt
2073 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2074 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2075 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2076             evdwij=evdwij*eps2rt*eps3rt
2077             evdw=evdw+evdwij*sss_ele_cut
2078             if (lprn) then
2079             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2080             epsi=bb**2/aa!(itypi,itypj)
2081             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2082               restyp(itypi,1),i,restyp(itypj,1),j, &
2083               epsi,sigm,chi1,chi2,chip1,chip2, &
2084               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2085               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2086               evdwij
2087             endif
2088
2089             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2090                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2091 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2092 !            if (energy_dec) write (iout,*) &
2093 !                             'evdw',i,j,evdwij
2094 !                       print *,"ZALAMKA", evdw
2095
2096 ! Calculate gradient components.
2097             e1=e1*eps1*eps2rt**2*eps3rt**2
2098             fac=-expon*(e1+evdwij)*rij_shift
2099             sigder=fac*sigder
2100             fac=rij*fac
2101 !            print *,'before fac',fac,rij,evdwij
2102             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2103             *rij
2104 !            print *,'grad part scale',fac,   &
2105 !             evdwij*sss_ele_grad/sss_ele_cut &
2106 !            /sigma(itypi,itypj)*rij
2107 !            fac=0.0d0
2108 ! Calculate the radial part of the gradient
2109             gg(1)=xj*fac
2110             gg(2)=yj*fac
2111             gg(3)=zj*fac
2112 !C Calculate the radial part of the gradient
2113             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2114        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2115         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2116        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2117             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2118             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2119
2120 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2121 ! Calculate angular part of the gradient.
2122             call sc_grad
2123             ENDIF    ! dyn_ss
2124           enddo      ! j
2125         enddo        ! iint
2126       enddo          ! i
2127 !       print *,"ZALAMKA", evdw
2128 !      write (iout,*) "Number of loop steps in EGB:",ind
2129 !ccc      energy_dec=.false.
2130       return
2131       end subroutine egb
2132 !-----------------------------------------------------------------------------
2133       subroutine egbv(evdw)
2134 !
2135 ! This subroutine calculates the interaction energy of nonbonded side chains
2136 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2137 !
2138       use comm_srutu
2139       use calc_data
2140 !      implicit real*8 (a-h,o-z)
2141 !      include 'DIMENSIONS'
2142 !      include 'COMMON.GEO'
2143 !      include 'COMMON.VAR'
2144 !      include 'COMMON.LOCAL'
2145 !      include 'COMMON.CHAIN'
2146 !      include 'COMMON.DERIV'
2147 !      include 'COMMON.NAMES'
2148 !      include 'COMMON.INTERACT'
2149 !      include 'COMMON.IOUNITS'
2150 !      include 'COMMON.CALC'
2151       use comm_srutu
2152 !el      integer :: icall
2153 !el      common /srutu/ icall
2154       logical :: lprn
2155 !el local variables
2156       integer :: iint,itypi,itypi1,itypj
2157       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2158       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2159
2160 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2161       evdw=0.0D0
2162       lprn=.false.
2163 !     if (icall.eq.0) lprn=.true.
2164 !el      ind=0
2165       do i=iatsc_s,iatsc_e
2166         itypi=iabs(itype(i,1))
2167         if (itypi.eq.ntyp1) cycle
2168         itypi1=iabs(itype(i+1,1))
2169         xi=c(1,nres+i)
2170         yi=c(2,nres+i)
2171         zi=c(3,nres+i)
2172         dxi=dc_norm(1,nres+i)
2173         dyi=dc_norm(2,nres+i)
2174         dzi=dc_norm(3,nres+i)
2175 !        dsci_inv=dsc_inv(itypi)
2176         dsci_inv=vbld_inv(i+nres)
2177 !
2178 ! Calculate SC interaction energy.
2179 !
2180         do iint=1,nint_gr(i)
2181           do j=istart(i,iint),iend(i,iint)
2182 !el            ind=ind+1
2183             itypj=iabs(itype(j,1))
2184             if (itypj.eq.ntyp1) cycle
2185 !            dscj_inv=dsc_inv(itypj)
2186             dscj_inv=vbld_inv(j+nres)
2187             sig0ij=sigma(itypi,itypj)
2188             r0ij=r0(itypi,itypj)
2189             chi1=chi(itypi,itypj)
2190             chi2=chi(itypj,itypi)
2191             chi12=chi1*chi2
2192             chip1=chip(itypi)
2193             chip2=chip(itypj)
2194             chip12=chip1*chip2
2195             alf1=alp(itypi)
2196             alf2=alp(itypj)
2197             alf12=0.5D0*(alf1+alf2)
2198 ! For diagnostics only!!!
2199 !           chi1=0.0D0
2200 !           chi2=0.0D0
2201 !           chi12=0.0D0
2202 !           chip1=0.0D0
2203 !           chip2=0.0D0
2204 !           chip12=0.0D0
2205 !           alf1=0.0D0
2206 !           alf2=0.0D0
2207 !           alf12=0.0D0
2208             xj=c(1,nres+j)-xi
2209             yj=c(2,nres+j)-yi
2210             zj=c(3,nres+j)-zi
2211             dxj=dc_norm(1,nres+j)
2212             dyj=dc_norm(2,nres+j)
2213             dzj=dc_norm(3,nres+j)
2214             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2215             rij=dsqrt(rrij)
2216 ! Calculate angle-dependent terms of energy and contributions to their
2217 ! derivatives.
2218             call sc_angular
2219             sigsq=1.0D0/sigsq
2220             sig=sig0ij*dsqrt(sigsq)
2221             rij_shift=1.0D0/rij-sig+r0ij
2222 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2223             if (rij_shift.le.0.0D0) then
2224               evdw=1.0D20
2225               return
2226             endif
2227             sigder=-sig*sigsq
2228 !---------------------------------------------------------------
2229             rij_shift=1.0D0/rij_shift
2230             fac=rij_shift**expon
2231             e1=fac*fac*aa_aq(itypi,itypj)
2232             e2=fac*bb_aq(itypi,itypj)
2233             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2234             eps2der=evdwij*eps3rt
2235             eps3der=evdwij*eps2rt
2236             fac_augm=rrij**expon
2237             e_augm=augm(itypi,itypj)*fac_augm
2238             evdwij=evdwij*eps2rt*eps3rt
2239             evdw=evdw+evdwij+e_augm
2240             if (lprn) then
2241             sigm=dabs(aa_aq(itypi,itypj)/&
2242             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2243             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2244             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2245               restyp(itypi,1),i,restyp(itypj,1),j,&
2246               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2247               chi1,chi2,chip1,chip2,&
2248               eps1,eps2rt**2,eps3rt**2,&
2249               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2250               evdwij+e_augm
2251             endif
2252 ! Calculate gradient components.
2253             e1=e1*eps1*eps2rt**2*eps3rt**2
2254             fac=-expon*(e1+evdwij)*rij_shift
2255             sigder=fac*sigder
2256             fac=rij*fac-2*expon*rrij*e_augm
2257 ! Calculate the radial part of the gradient
2258             gg(1)=xj*fac
2259             gg(2)=yj*fac
2260             gg(3)=zj*fac
2261 ! Calculate angular part of the gradient.
2262             call sc_grad
2263           enddo      ! j
2264         enddo        ! iint
2265       enddo          ! i
2266       end subroutine egbv
2267 !-----------------------------------------------------------------------------
2268 !el      subroutine sc_angular in module geometry
2269 !-----------------------------------------------------------------------------
2270       subroutine e_softsphere(evdw)
2271 !
2272 ! This subroutine calculates the interaction energy of nonbonded side chains
2273 ! assuming the LJ potential of interaction.
2274 !
2275 !      implicit real*8 (a-h,o-z)
2276 !      include 'DIMENSIONS'
2277       real(kind=8),parameter :: accur=1.0d-10
2278 !      include 'COMMON.GEO'
2279 !      include 'COMMON.VAR'
2280 !      include 'COMMON.LOCAL'
2281 !      include 'COMMON.CHAIN'
2282 !      include 'COMMON.DERIV'
2283 !      include 'COMMON.INTERACT'
2284 !      include 'COMMON.TORSION'
2285 !      include 'COMMON.SBRIDGE'
2286 !      include 'COMMON.NAMES'
2287 !      include 'COMMON.IOUNITS'
2288 !      include 'COMMON.CONTACTS'
2289       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2290 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2291 !el local variables
2292       integer :: i,iint,j,itypi,itypi1,itypj,k
2293       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2294       real(kind=8) :: fac
2295
2296       evdw=0.0D0
2297       do i=iatsc_s,iatsc_e
2298         itypi=iabs(itype(i,1))
2299         if (itypi.eq.ntyp1) cycle
2300         itypi1=iabs(itype(i+1,1))
2301         xi=c(1,nres+i)
2302         yi=c(2,nres+i)
2303         zi=c(3,nres+i)
2304 !
2305 ! Calculate SC interaction energy.
2306 !
2307         do iint=1,nint_gr(i)
2308 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2309 !d   &                  'iend=',iend(i,iint)
2310           do j=istart(i,iint),iend(i,iint)
2311             itypj=iabs(itype(j,1))
2312             if (itypj.eq.ntyp1) cycle
2313             xj=c(1,nres+j)-xi
2314             yj=c(2,nres+j)-yi
2315             zj=c(3,nres+j)-zi
2316             rij=xj*xj+yj*yj+zj*zj
2317 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2318             r0ij=r0(itypi,itypj)
2319             r0ijsq=r0ij*r0ij
2320 !            print *,i,j,r0ij,dsqrt(rij)
2321             if (rij.lt.r0ijsq) then
2322               evdwij=0.25d0*(rij-r0ijsq)**2
2323               fac=rij-r0ijsq
2324             else
2325               evdwij=0.0d0
2326               fac=0.0d0
2327             endif
2328             evdw=evdw+evdwij
2329 !
2330 ! Calculate the components of the gradient in DC and X
2331 !
2332             gg(1)=xj*fac
2333             gg(2)=yj*fac
2334             gg(3)=zj*fac
2335             do k=1,3
2336               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2337               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2338               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2339               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2340             enddo
2341 !grad            do k=i,j-1
2342 !grad              do l=1,3
2343 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2344 !grad              enddo
2345 !grad            enddo
2346           enddo ! j
2347         enddo ! iint
2348       enddo ! i
2349       return
2350       end subroutine e_softsphere
2351 !-----------------------------------------------------------------------------
2352       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2353 !
2354 ! Soft-sphere potential of p-p interaction
2355 !
2356 !      implicit real*8 (a-h,o-z)
2357 !      include 'DIMENSIONS'
2358 !      include 'COMMON.CONTROL'
2359 !      include 'COMMON.IOUNITS'
2360 !      include 'COMMON.GEO'
2361 !      include 'COMMON.VAR'
2362 !      include 'COMMON.LOCAL'
2363 !      include 'COMMON.CHAIN'
2364 !      include 'COMMON.DERIV'
2365 !      include 'COMMON.INTERACT'
2366 !      include 'COMMON.CONTACTS'
2367 !      include 'COMMON.TORSION'
2368 !      include 'COMMON.VECTORS'
2369 !      include 'COMMON.FFIELD'
2370       real(kind=8),dimension(3) :: ggg
2371 !d      write(iout,*) 'In EELEC_soft_sphere'
2372 !el local variables
2373       integer :: i,j,k,num_conti,iteli,itelj
2374       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2375       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2376       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2377
2378       ees=0.0D0
2379       evdw1=0.0D0
2380       eel_loc=0.0d0
2381       eello_turn3=0.0d0
2382       eello_turn4=0.0d0
2383 !el      ind=0
2384       do i=iatel_s,iatel_e
2385         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2386         dxi=dc(1,i)
2387         dyi=dc(2,i)
2388         dzi=dc(3,i)
2389         xmedi=c(1,i)+0.5d0*dxi
2390         ymedi=c(2,i)+0.5d0*dyi
2391         zmedi=c(3,i)+0.5d0*dzi
2392         num_conti=0
2393 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2394         do j=ielstart(i),ielend(i)
2395           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2396 !el          ind=ind+1
2397           iteli=itel(i)
2398           itelj=itel(j)
2399           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2400           r0ij=rpp(iteli,itelj)
2401           r0ijsq=r0ij*r0ij
2402           dxj=dc(1,j)
2403           dyj=dc(2,j)
2404           dzj=dc(3,j)
2405           xj=c(1,j)+0.5D0*dxj-xmedi
2406           yj=c(2,j)+0.5D0*dyj-ymedi
2407           zj=c(3,j)+0.5D0*dzj-zmedi
2408           rij=xj*xj+yj*yj+zj*zj
2409           if (rij.lt.r0ijsq) then
2410             evdw1ij=0.25d0*(rij-r0ijsq)**2
2411             fac=rij-r0ijsq
2412           else
2413             evdw1ij=0.0d0
2414             fac=0.0d0
2415           endif
2416           evdw1=evdw1+evdw1ij
2417 !
2418 ! Calculate contributions to the Cartesian gradient.
2419 !
2420           ggg(1)=fac*xj
2421           ggg(2)=fac*yj
2422           ggg(3)=fac*zj
2423           do k=1,3
2424             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2425             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2426           enddo
2427 !
2428 ! Loop over residues i+1 thru j-1.
2429 !
2430 !grad          do k=i+1,j-1
2431 !grad            do l=1,3
2432 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2433 !grad            enddo
2434 !grad          enddo
2435         enddo ! j
2436       enddo   ! i
2437 !grad      do i=nnt,nct-1
2438 !grad        do k=1,3
2439 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2440 !grad        enddo
2441 !grad        do j=i+1,nct-1
2442 !grad          do k=1,3
2443 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2444 !grad          enddo
2445 !grad        enddo
2446 !grad      enddo
2447       return
2448       end subroutine eelec_soft_sphere
2449 !-----------------------------------------------------------------------------
2450       subroutine vec_and_deriv
2451 !      implicit real*8 (a-h,o-z)
2452 !      include 'DIMENSIONS'
2453 #ifdef MPI
2454       include 'mpif.h'
2455 #endif
2456 !      include 'COMMON.IOUNITS'
2457 !      include 'COMMON.GEO'
2458 !      include 'COMMON.VAR'
2459 !      include 'COMMON.LOCAL'
2460 !      include 'COMMON.CHAIN'
2461 !      include 'COMMON.VECTORS'
2462 !      include 'COMMON.SETUP'
2463 !      include 'COMMON.TIME1'
2464       real(kind=8),dimension(3,3,2) :: uyder,uzder
2465       real(kind=8),dimension(2) :: vbld_inv_temp
2466 ! Compute the local reference systems. For reference system (i), the
2467 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2468 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2469 !el local variables
2470       integer :: i,j,k,l
2471       real(kind=8) :: facy,fac,costh
2472
2473 #ifdef PARVEC
2474       do i=ivec_start,ivec_end
2475 #else
2476       do i=1,nres-1
2477 #endif
2478           if (i.eq.nres-1) then
2479 ! Case of the last full residue
2480 ! Compute the Z-axis
2481             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2482             costh=dcos(pi-theta(nres))
2483             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2484             do k=1,3
2485               uz(k,i)=fac*uz(k,i)
2486             enddo
2487 ! Compute the derivatives of uz
2488             uzder(1,1,1)= 0.0d0
2489             uzder(2,1,1)=-dc_norm(3,i-1)
2490             uzder(3,1,1)= dc_norm(2,i-1)
2491             uzder(1,2,1)= dc_norm(3,i-1)
2492             uzder(2,2,1)= 0.0d0
2493             uzder(3,2,1)=-dc_norm(1,i-1)
2494             uzder(1,3,1)=-dc_norm(2,i-1)
2495             uzder(2,3,1)= dc_norm(1,i-1)
2496             uzder(3,3,1)= 0.0d0
2497             uzder(1,1,2)= 0.0d0
2498             uzder(2,1,2)= dc_norm(3,i)
2499             uzder(3,1,2)=-dc_norm(2,i)
2500             uzder(1,2,2)=-dc_norm(3,i)
2501             uzder(2,2,2)= 0.0d0
2502             uzder(3,2,2)= dc_norm(1,i)
2503             uzder(1,3,2)= dc_norm(2,i)
2504             uzder(2,3,2)=-dc_norm(1,i)
2505             uzder(3,3,2)= 0.0d0
2506 ! Compute the Y-axis
2507             facy=fac
2508             do k=1,3
2509               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2510             enddo
2511 ! Compute the derivatives of uy
2512             do j=1,3
2513               do k=1,3
2514                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2515                               -dc_norm(k,i)*dc_norm(j,i-1)
2516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2517               enddo
2518               uyder(j,j,1)=uyder(j,j,1)-costh
2519               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2520             enddo
2521             do j=1,2
2522               do k=1,3
2523                 do l=1,3
2524                   uygrad(l,k,j,i)=uyder(l,k,j)
2525                   uzgrad(l,k,j,i)=uzder(l,k,j)
2526                 enddo
2527               enddo
2528             enddo
2529             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2530             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2531             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2532             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2533           else
2534 ! Other residues
2535 ! Compute the Z-axis
2536             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2537             costh=dcos(pi-theta(i+2))
2538             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2539             do k=1,3
2540               uz(k,i)=fac*uz(k,i)
2541             enddo
2542 ! Compute the derivatives of uz
2543             uzder(1,1,1)= 0.0d0
2544             uzder(2,1,1)=-dc_norm(3,i+1)
2545             uzder(3,1,1)= dc_norm(2,i+1)
2546             uzder(1,2,1)= dc_norm(3,i+1)
2547             uzder(2,2,1)= 0.0d0
2548             uzder(3,2,1)=-dc_norm(1,i+1)
2549             uzder(1,3,1)=-dc_norm(2,i+1)
2550             uzder(2,3,1)= dc_norm(1,i+1)
2551             uzder(3,3,1)= 0.0d0
2552             uzder(1,1,2)= 0.0d0
2553             uzder(2,1,2)= dc_norm(3,i)
2554             uzder(3,1,2)=-dc_norm(2,i)
2555             uzder(1,2,2)=-dc_norm(3,i)
2556             uzder(2,2,2)= 0.0d0
2557             uzder(3,2,2)= dc_norm(1,i)
2558             uzder(1,3,2)= dc_norm(2,i)
2559             uzder(2,3,2)=-dc_norm(1,i)
2560             uzder(3,3,2)= 0.0d0
2561 ! Compute the Y-axis
2562             facy=fac
2563             do k=1,3
2564               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2565             enddo
2566 ! Compute the derivatives of uy
2567             do j=1,3
2568               do k=1,3
2569                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2570                               -dc_norm(k,i)*dc_norm(j,i+1)
2571                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2572               enddo
2573               uyder(j,j,1)=uyder(j,j,1)-costh
2574               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2575             enddo
2576             do j=1,2
2577               do k=1,3
2578                 do l=1,3
2579                   uygrad(l,k,j,i)=uyder(l,k,j)
2580                   uzgrad(l,k,j,i)=uzder(l,k,j)
2581                 enddo
2582               enddo
2583             enddo
2584             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2585             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2586             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2587             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2588           endif
2589       enddo
2590       do i=1,nres-1
2591         vbld_inv_temp(1)=vbld_inv(i+1)
2592         if (i.lt.nres-1) then
2593           vbld_inv_temp(2)=vbld_inv(i+2)
2594           else
2595           vbld_inv_temp(2)=vbld_inv(i)
2596           endif
2597         do j=1,2
2598           do k=1,3
2599             do l=1,3
2600               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2601               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2602             enddo
2603           enddo
2604         enddo
2605       enddo
2606 #if defined(PARVEC) && defined(MPI)
2607       if (nfgtasks1.gt.1) then
2608         time00=MPI_Wtime()
2609 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2610 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2611 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2612         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2613          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2614          FG_COMM1,IERR)
2615         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2616          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2617          FG_COMM1,IERR)
2618         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2619          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2620          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2621         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2622          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2623          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2624         time_gather=time_gather+MPI_Wtime()-time00
2625       endif
2626 !      if (fg_rank.eq.0) then
2627 !        write (iout,*) "Arrays UY and UZ"
2628 !        do i=1,nres-1
2629 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2630 !     &     (uz(k,i),k=1,3)
2631 !        enddo
2632 !      endif
2633 #endif
2634       return
2635       end subroutine vec_and_deriv
2636 !-----------------------------------------------------------------------------
2637       subroutine check_vecgrad
2638 !      implicit real*8 (a-h,o-z)
2639 !      include 'DIMENSIONS'
2640 !      include 'COMMON.IOUNITS'
2641 !      include 'COMMON.GEO'
2642 !      include 'COMMON.VAR'
2643 !      include 'COMMON.LOCAL'
2644 !      include 'COMMON.CHAIN'
2645 !      include 'COMMON.VECTORS'
2646       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2647       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2648       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2649       real(kind=8),dimension(3) :: erij
2650       real(kind=8) :: delta=1.0d-7
2651 !el local variables
2652       integer :: i,j,k,l
2653
2654       call vec_and_deriv
2655 !d      do i=1,nres
2656 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2657 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2658 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2659 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2660 !d     &     (dc_norm(if90,i),if90=1,3)
2661 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2662 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2663 !d          write(iout,'(a)')
2664 !d      enddo
2665       do i=1,nres
2666         do j=1,2
2667           do k=1,3
2668             do l=1,3
2669               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2670               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2671             enddo
2672           enddo
2673         enddo
2674       enddo
2675       call vec_and_deriv
2676       do i=1,nres
2677         do j=1,3
2678           uyt(j,i)=uy(j,i)
2679           uzt(j,i)=uz(j,i)
2680         enddo
2681       enddo
2682       do i=1,nres
2683 !d        write (iout,*) 'i=',i
2684         do k=1,3
2685           erij(k)=dc_norm(k,i)
2686         enddo
2687         do j=1,3
2688           do k=1,3
2689             dc_norm(k,i)=erij(k)
2690           enddo
2691           dc_norm(j,i)=dc_norm(j,i)+delta
2692 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2693 !          do k=1,3
2694 !            dc_norm(k,i)=dc_norm(k,i)/fac
2695 !          enddo
2696 !          write (iout,*) (dc_norm(k,i),k=1,3)
2697 !          write (iout,*) (erij(k),k=1,3)
2698           call vec_and_deriv
2699           do k=1,3
2700             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2701             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2702             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2703             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2704           enddo
2705 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2706 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2707 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2708         enddo
2709         do k=1,3
2710           dc_norm(k,i)=erij(k)
2711         enddo
2712 !d        do k=1,3
2713 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2714 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2715 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2716 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2717 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2718 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2719 !d          write (iout,'(a)')
2720 !d        enddo
2721       enddo
2722       return
2723       end subroutine check_vecgrad
2724 !-----------------------------------------------------------------------------
2725       subroutine set_matrices
2726 !      implicit real*8 (a-h,o-z)
2727 !      include 'DIMENSIONS'
2728 #ifdef MPI
2729       include "mpif.h"
2730 !      include "COMMON.SETUP"
2731       integer :: IERR
2732       integer :: status(MPI_STATUS_SIZE)
2733 #endif
2734 !      include 'COMMON.IOUNITS'
2735 !      include 'COMMON.GEO'
2736 !      include 'COMMON.VAR'
2737 !      include 'COMMON.LOCAL'
2738 !      include 'COMMON.CHAIN'
2739 !      include 'COMMON.DERIV'
2740 !      include 'COMMON.INTERACT'
2741 !      include 'COMMON.CONTACTS'
2742 !      include 'COMMON.TORSION'
2743 !      include 'COMMON.VECTORS'
2744 !      include 'COMMON.FFIELD'
2745       real(kind=8) :: auxvec(2),auxmat(2,2)
2746       integer :: i,iti1,iti,k,l
2747       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2748        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2749 !       print *,"in set matrices"
2750 !
2751 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2752 ! to calculate the el-loc multibody terms of various order.
2753 !
2754 !AL el      mu=0.0d0
2755
2756 #ifdef PARMAT
2757       do i=ivec_start+2,ivec_end+2
2758 #else
2759       do i=3,nres+1
2760 #endif
2761         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2762           if (itype(i-2,1).eq.0) then
2763           iti = nloctyp
2764           else
2765           iti = itype2loc(itype(i-2,1))
2766           endif
2767         else
2768           iti=nloctyp
2769         endif
2770 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2771         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2772           iti1 = itype2loc(itype(i-1,1))
2773         else
2774           iti1=nloctyp
2775         endif
2776 !        print *,i,itype(i-2,1),iti
2777 #ifdef NEWCORR
2778         cost1=dcos(theta(i-1))
2779         sint1=dsin(theta(i-1))
2780         sint1sq=sint1*sint1
2781         sint1cub=sint1sq*sint1
2782         sint1cost1=2*sint1*cost1
2783 !        print *,"cost1",cost1,theta(i-1)
2784 !c        write (iout,*) "bnew1",i,iti
2785 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2786 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2787 !c        write (iout,*) "bnew2",i,iti
2788 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2789 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2790         k=1
2791 !        print *,bnew1(1,k,iti),"bnew1"
2792         do k=1,2
2793           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2794 !          print *,b1k
2795 !          write(*,*) shape(b1)
2796 !          if(.not.allocated(b1)) print *, "WTF?"
2797           b1(k,i-2)=sint1*b1k
2798 !
2799 !             print *,b1(k,i-2)
2800
2801           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2802                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2803 !             print *,gtb1(k,i-2)
2804
2805           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2806           b2(k,i-2)=sint1*b2k
2807 !             print *,b2(k,i-2)
2808
2809           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2810                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2811 !             print *,gtb2(k,i-2)
2812
2813         enddo
2814 !        print *,b1k,b2k
2815         do k=1,2
2816           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2817           cc(1,k,i-2)=sint1sq*aux
2818           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2819                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2820           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2821           dd(1,k,i-2)=sint1sq*aux
2822           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2823                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2824         enddo
2825 !        print *,"after cc"
2826         cc(2,1,i-2)=cc(1,2,i-2)
2827         cc(2,2,i-2)=-cc(1,1,i-2)
2828         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2829         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2830         dd(2,1,i-2)=dd(1,2,i-2)
2831         dd(2,2,i-2)=-dd(1,1,i-2)
2832         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2833         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2834 !        print *,"after dd"
2835
2836         do k=1,2
2837           do l=1,2
2838             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2839             EE(l,k,i-2)=sint1sq*aux
2840             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2841           enddo
2842         enddo
2843         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2844         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2845         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2846         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2847         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2848         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2849         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2850 !        print *,"after ee"
2851
2852 !c        b1tilde(1,i-2)=b1(1,i-2)
2853 !c        b1tilde(2,i-2)=-b1(2,i-2)
2854 !c        b2tilde(1,i-2)=b2(1,i-2)
2855 !c        b2tilde(2,i-2)=-b2(2,i-2)
2856 #ifdef DEBUG
2857         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2858         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2859         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2860         write (iout,*) 'theta=', theta(i-1)
2861 #endif
2862 #else
2863         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2864 !         write(iout,*) "i,",molnum(i)
2865 !         print *, "i,",molnum(i),i,itype(i-2,1)
2866         if (molnum(i).eq.1) then
2867           iti = itype2loc(itype(i-2,1))
2868         else
2869           iti=nloctyp
2870         endif
2871         else
2872           iti=nloctyp
2873         endif
2874 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2875 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2876         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2877           iti1 = itype2loc(itype(i-1,1))
2878         else
2879           iti1=nloctyp
2880         endif
2881 !        print *,i,iti
2882         b1(1,i-2)=b(3,iti)
2883         b1(2,i-2)=b(5,iti)
2884         b2(1,i-2)=b(2,iti)
2885         b2(2,i-2)=b(4,iti)
2886         do k=1,2
2887           do l=1,2
2888            CC(k,l,i-2)=ccold(k,l,iti)
2889            DD(k,l,i-2)=ddold(k,l,iti)
2890            EE(k,l,i-2)=eeold(k,l,iti)
2891           enddo
2892         enddo
2893 #endif
2894         b1tilde(1,i-2)= b1(1,i-2)
2895         b1tilde(2,i-2)=-b1(2,i-2)
2896         b2tilde(1,i-2)= b2(1,i-2)
2897         b2tilde(2,i-2)=-b2(2,i-2)
2898 !c
2899         Ctilde(1,1,i-2)= CC(1,1,i-2)
2900         Ctilde(1,2,i-2)= CC(1,2,i-2)
2901         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2902         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2903 !c
2904         Dtilde(1,1,i-2)= DD(1,1,i-2)
2905         Dtilde(1,2,i-2)= DD(1,2,i-2)
2906         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2907         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2908       enddo
2909 #ifdef PARMAT
2910       do i=ivec_start+2,ivec_end+2
2911 #else
2912       do i=3,nres+1
2913 #endif
2914
2915 !      print *,i,"i"
2916         if (i .lt. nres+1) then
2917           sin1=dsin(phi(i))
2918           cos1=dcos(phi(i))
2919           sintab(i-2)=sin1
2920           costab(i-2)=cos1
2921           obrot(1,i-2)=cos1
2922           obrot(2,i-2)=sin1
2923           sin2=dsin(2*phi(i))
2924           cos2=dcos(2*phi(i))
2925           sintab2(i-2)=sin2
2926           costab2(i-2)=cos2
2927           obrot2(1,i-2)=cos2
2928           obrot2(2,i-2)=sin2
2929           Ug(1,1,i-2)=-cos1
2930           Ug(1,2,i-2)=-sin1
2931           Ug(2,1,i-2)=-sin1
2932           Ug(2,2,i-2)= cos1
2933           Ug2(1,1,i-2)=-cos2
2934           Ug2(1,2,i-2)=-sin2
2935           Ug2(2,1,i-2)=-sin2
2936           Ug2(2,2,i-2)= cos2
2937         else
2938           costab(i-2)=1.0d0
2939           sintab(i-2)=0.0d0
2940           obrot(1,i-2)=1.0d0
2941           obrot(2,i-2)=0.0d0
2942           obrot2(1,i-2)=0.0d0
2943           obrot2(2,i-2)=0.0d0
2944           Ug(1,1,i-2)=1.0d0
2945           Ug(1,2,i-2)=0.0d0
2946           Ug(2,1,i-2)=0.0d0
2947           Ug(2,2,i-2)=1.0d0
2948           Ug2(1,1,i-2)=0.0d0
2949           Ug2(1,2,i-2)=0.0d0
2950           Ug2(2,1,i-2)=0.0d0
2951           Ug2(2,2,i-2)=0.0d0
2952         endif
2953         if (i .gt. 3 .and. i .lt. nres+1) then
2954           obrot_der(1,i-2)=-sin1
2955           obrot_der(2,i-2)= cos1
2956           Ugder(1,1,i-2)= sin1
2957           Ugder(1,2,i-2)=-cos1
2958           Ugder(2,1,i-2)=-cos1
2959           Ugder(2,2,i-2)=-sin1
2960           dwacos2=cos2+cos2
2961           dwasin2=sin2+sin2
2962           obrot2_der(1,i-2)=-dwasin2
2963           obrot2_der(2,i-2)= dwacos2
2964           Ug2der(1,1,i-2)= dwasin2
2965           Ug2der(1,2,i-2)=-dwacos2
2966           Ug2der(2,1,i-2)=-dwacos2
2967           Ug2der(2,2,i-2)=-dwasin2
2968         else
2969           obrot_der(1,i-2)=0.0d0
2970           obrot_der(2,i-2)=0.0d0
2971           Ugder(1,1,i-2)=0.0d0
2972           Ugder(1,2,i-2)=0.0d0
2973           Ugder(2,1,i-2)=0.0d0
2974           Ugder(2,2,i-2)=0.0d0
2975           obrot2_der(1,i-2)=0.0d0
2976           obrot2_der(2,i-2)=0.0d0
2977           Ug2der(1,1,i-2)=0.0d0
2978           Ug2der(1,2,i-2)=0.0d0
2979           Ug2der(2,1,i-2)=0.0d0
2980           Ug2der(2,2,i-2)=0.0d0
2981         endif
2982 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2983         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2984            if (itype(i-2,1).eq.0) then
2985           iti=ntortyp+1
2986            else
2987           iti = itype2loc(itype(i-2,1))
2988            endif
2989         else
2990           iti=nloctyp
2991         endif
2992 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2993         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2994            if (itype(i-1,1).eq.0) then
2995           iti1=nloctyp
2996            else
2997           iti1 = itype2loc(itype(i-1,1))
2998            endif
2999         else
3000           iti1=nloctyp
3001         endif
3002 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3003 !d        write (iout,*) '*******i',i,' iti1',iti
3004 !        write (iout,*) 'b1',b1(:,iti)
3005 !        write (iout,*) 'b2',b2(:,i-2)
3006 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3007 !        if (i .gt. iatel_s+2) then
3008         if (i .gt. nnt+2) then
3009           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3010 #ifdef NEWCORR
3011           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3012 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3013 #endif
3014
3015           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3016           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3017           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3018           then
3019           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3020           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3021           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3022           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3023           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3024           endif
3025         else
3026           do k=1,2
3027             Ub2(k,i-2)=0.0d0
3028             Ctobr(k,i-2)=0.0d0
3029             Dtobr2(k,i-2)=0.0d0
3030             do l=1,2
3031               EUg(l,k,i-2)=0.0d0
3032               CUg(l,k,i-2)=0.0d0
3033               DUg(l,k,i-2)=0.0d0
3034               DtUg2(l,k,i-2)=0.0d0
3035             enddo
3036           enddo
3037         endif
3038         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3039         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3040         do k=1,2
3041           muder(k,i-2)=Ub2der(k,i-2)
3042         enddo
3043 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3044         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3045           if (itype(i-1,1).eq.0) then
3046            iti1=nloctyp
3047           elseif (itype(i-1,1).le.ntyp) then
3048             iti1 = itype2loc(itype(i-1,1))
3049           else
3050             iti1=nloctyp
3051           endif
3052         else
3053           iti1=nloctyp
3054         endif
3055         do k=1,2
3056           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3057         enddo
3058         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3059         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3060         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3061 !d        write (iout,*) 'mu1',mu1(:,i-2)
3062 !d        write (iout,*) 'mu2',mu2(:,i-2)
3063         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3064         then
3065         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3066         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3067         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3068         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3069         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3070 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3071         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3072         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3073         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3074         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3075         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3076         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3077         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3078         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3079         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3080         endif
3081       enddo
3082 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3083 ! The order of matrices is from left to right.
3084       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3085       then
3086 !      do i=max0(ivec_start,2),ivec_end
3087       do i=2,nres-1
3088         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3089         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3090         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3091         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3092         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3093         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3094         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3095         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3096       enddo
3097       endif
3098 #if defined(MPI) && defined(PARMAT)
3099 #ifdef DEBUG
3100 !      if (fg_rank.eq.0) then
3101         write (iout,*) "Arrays UG and UGDER before GATHER"
3102         do i=1,nres-1
3103           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3104            ((ug(l,k,i),l=1,2),k=1,2),&
3105            ((ugder(l,k,i),l=1,2),k=1,2)
3106         enddo
3107         write (iout,*) "Arrays UG2 and UG2DER"
3108         do i=1,nres-1
3109           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3110            ((ug2(l,k,i),l=1,2),k=1,2),&
3111            ((ug2der(l,k,i),l=1,2),k=1,2)
3112         enddo
3113         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3114         do i=1,nres-1
3115           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3116            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3117            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3118         enddo
3119         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3120         do i=1,nres-1
3121           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3122            costab(i),sintab(i),costab2(i),sintab2(i)
3123         enddo
3124         write (iout,*) "Array MUDER"
3125         do i=1,nres-1
3126           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3127         enddo
3128 !      endif
3129 #endif
3130       if (nfgtasks.gt.1) then
3131         time00=MPI_Wtime()
3132 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3133 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3134 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3135 #ifdef MATGATHER
3136         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3137          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3138          FG_COMM1,IERR)
3139         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3140          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3141          FG_COMM1,IERR)
3142         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3143          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3144          FG_COMM1,IERR)
3145         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3146          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3147          FG_COMM1,IERR)
3148         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3149          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3150          FG_COMM1,IERR)
3151         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3152          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3153          FG_COMM1,IERR)
3154         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3155          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3156          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3157         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3158          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3159          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3160         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3161          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3162          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3163         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3164          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3165          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3166         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3167         then
3168         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3172          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3173          FG_COMM1,IERR)
3174         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3175          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3176          FG_COMM1,IERR)
3177        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3178          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3179          FG_COMM1,IERR)
3180         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3181          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3182          FG_COMM1,IERR)
3183         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3184          ivec_count(fg_rank1),&
3185          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3189          FG_COMM1,IERR)
3190         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3197          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3198          FG_COMM1,IERR)
3199         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3200          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3203          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3204          FG_COMM1,IERR)
3205         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3206          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3207          FG_COMM1,IERR)
3208         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3209          ivec_count(fg_rank1),&
3210          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3211          FG_COMM1,IERR)
3212         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3213          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3214          FG_COMM1,IERR)
3215        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3217          FG_COMM1,IERR)
3218         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3220          FG_COMM1,IERR)
3221        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3222          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3223          FG_COMM1,IERR)
3224         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3225          ivec_count(fg_rank1),&
3226          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3227          FG_COMM1,IERR)
3228         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3229          ivec_count(fg_rank1),&
3230          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3231          FG_COMM1,IERR)
3232         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3233          ivec_count(fg_rank1),&
3234          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3235          MPI_MAT2,FG_COMM1,IERR)
3236         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3237          ivec_count(fg_rank1),&
3238          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3239          MPI_MAT2,FG_COMM1,IERR)
3240         endif
3241 #else
3242 ! Passes matrix info through the ring
3243       isend=fg_rank1
3244       irecv=fg_rank1-1
3245       if (irecv.lt.0) irecv=nfgtasks1-1
3246       iprev=irecv
3247       inext=fg_rank1+1
3248       if (inext.ge.nfgtasks1) inext=0
3249       do i=1,nfgtasks1-1
3250 !        write (iout,*) "isend",isend," irecv",irecv
3251 !        call flush(iout)
3252         lensend=lentyp(isend)
3253         lenrecv=lentyp(irecv)
3254 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3255 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3256 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3257 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3258 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3259 !        write (iout,*) "Gather ROTAT1"
3260 !        call flush(iout)
3261 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3262 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3263 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3264 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3265 !        write (iout,*) "Gather ROTAT2"
3266 !        call flush(iout)
3267         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3268          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3269          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3270          iprev,4400+irecv,FG_COMM,status,IERR)
3271 !        write (iout,*) "Gather ROTAT_OLD"
3272 !        call flush(iout)
3273         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3274          MPI_PRECOMP11(lensend),inext,5500+isend,&
3275          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3276          iprev,5500+irecv,FG_COMM,status,IERR)
3277 !        write (iout,*) "Gather PRECOMP11"
3278 !        call flush(iout)
3279         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3280          MPI_PRECOMP12(lensend),inext,6600+isend,&
3281          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3282          iprev,6600+irecv,FG_COMM,status,IERR)
3283 !        write (iout,*) "Gather PRECOMP12"
3284 !        call flush(iout)
3285         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3286         then
3287         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3288          MPI_ROTAT2(lensend),inext,7700+isend,&
3289          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3290          iprev,7700+irecv,FG_COMM,status,IERR)
3291 !        write (iout,*) "Gather PRECOMP21"
3292 !        call flush(iout)
3293         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3294          MPI_PRECOMP22(lensend),inext,8800+isend,&
3295          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3296          iprev,8800+irecv,FG_COMM,status,IERR)
3297 !        write (iout,*) "Gather PRECOMP22"
3298 !        call flush(iout)
3299         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3300          MPI_PRECOMP23(lensend),inext,9900+isend,&
3301          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3302          MPI_PRECOMP23(lenrecv),&
3303          iprev,9900+irecv,FG_COMM,status,IERR)
3304 !        write (iout,*) "Gather PRECOMP23"
3305 !        call flush(iout)
3306         endif
3307         isend=irecv
3308         irecv=irecv-1
3309         if (irecv.lt.0) irecv=nfgtasks1-1
3310       enddo
3311 #endif
3312         time_gather=time_gather+MPI_Wtime()-time00
3313       endif
3314 #ifdef DEBUG
3315 !      if (fg_rank.eq.0) then
3316         write (iout,*) "Arrays UG and UGDER"
3317         do i=1,nres-1
3318           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3319            ((ug(l,k,i),l=1,2),k=1,2),&
3320            ((ugder(l,k,i),l=1,2),k=1,2)
3321         enddo
3322         write (iout,*) "Arrays UG2 and UG2DER"
3323         do i=1,nres-1
3324           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3325            ((ug2(l,k,i),l=1,2),k=1,2),&
3326            ((ug2der(l,k,i),l=1,2),k=1,2)
3327         enddo
3328         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3329         do i=1,nres-1
3330           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3331            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3332            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3333         enddo
3334         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3335         do i=1,nres-1
3336           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3337            costab(i),sintab(i),costab2(i),sintab2(i)
3338         enddo
3339         write (iout,*) "Array MUDER"
3340         do i=1,nres-1
3341           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3342         enddo
3343 !      endif
3344 #endif
3345 #endif
3346 !d      do i=1,nres
3347 !d        iti = itortyp(itype(i,1))
3348 !d        write (iout,*) i
3349 !d        do j=1,2
3350 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3351 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3352 !d        enddo
3353 !d      enddo
3354       return
3355       end subroutine set_matrices
3356 !-----------------------------------------------------------------------------
3357       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3358 !
3359 ! This subroutine calculates the average interaction energy and its gradient
3360 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3361 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3362 ! The potential depends both on the distance of peptide-group centers and on
3363 ! the orientation of the CA-CA virtual bonds.
3364 !
3365       use comm_locel
3366 !      implicit real*8 (a-h,o-z)
3367 #ifdef MPI
3368       include 'mpif.h'
3369 #endif
3370 !      include 'DIMENSIONS'
3371 !      include 'COMMON.CONTROL'
3372 !      include 'COMMON.SETUP'
3373 !      include 'COMMON.IOUNITS'
3374 !      include 'COMMON.GEO'
3375 !      include 'COMMON.VAR'
3376 !      include 'COMMON.LOCAL'
3377 !      include 'COMMON.CHAIN'
3378 !      include 'COMMON.DERIV'
3379 !      include 'COMMON.INTERACT'
3380 !      include 'COMMON.CONTACTS'
3381 !      include 'COMMON.TORSION'
3382 !      include 'COMMON.VECTORS'
3383 !      include 'COMMON.FFIELD'
3384 !      include 'COMMON.TIME1'
3385       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3386       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3387       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3388 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3389       real(kind=8),dimension(4) :: muij
3390 !el      integer :: num_conti,j1,j2
3391 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3392 !el        dz_normi,xmedi,ymedi,zmedi
3393
3394 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3395 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3396 !el          num_conti,j1,j2
3397
3398 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3399 #ifdef MOMENT
3400       real(kind=8) :: scal_el=1.0d0
3401 #else
3402       real(kind=8) :: scal_el=0.5d0
3403 #endif
3404 ! 12/13/98
3405 ! 13-go grudnia roku pamietnego...
3406       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3407                                              0.0d0,1.0d0,0.0d0,&
3408                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3409 !el local variables
3410       integer :: i,k,j
3411       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3412       real(kind=8) :: fac,t_eelecij,fracinbuf
3413
3414
3415 !d      write(iout,*) 'In EELEC'
3416 !        print *,"IN EELEC"
3417 !d      do i=1,nloctyp
3418 !d        write(iout,*) 'Type',i
3419 !d        write(iout,*) 'B1',B1(:,i)
3420 !d        write(iout,*) 'B2',B2(:,i)
3421 !d        write(iout,*) 'CC',CC(:,:,i)
3422 !d        write(iout,*) 'DD',DD(:,:,i)
3423 !d        write(iout,*) 'EE',EE(:,:,i)
3424 !d      enddo
3425 !d      call check_vecgrad
3426 !d      stop
3427 !      ees=0.0d0  !AS
3428 !      evdw1=0.0d0
3429 !      eel_loc=0.0d0
3430 !      eello_turn3=0.0d0
3431 !      eello_turn4=0.0d0
3432       t_eelecij=0.0d0
3433       ees=0.0D0
3434       evdw1=0.0D0
3435       eel_loc=0.0d0
3436       eello_turn3=0.0d0
3437       eello_turn4=0.0d0
3438 !
3439
3440       if (icheckgrad.eq.1) then
3441 !el
3442 !        do i=0,2*nres+2
3443 !          dc_norm(1,i)=0.0d0
3444 !          dc_norm(2,i)=0.0d0
3445 !          dc_norm(3,i)=0.0d0
3446 !        enddo
3447         do i=1,nres-1
3448           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3449           do k=1,3
3450             dc_norm(k,i)=dc(k,i)*fac
3451           enddo
3452 !          write (iout,*) 'i',i,' fac',fac
3453         enddo
3454       endif
3455 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3456 !        wturn6
3457       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3458           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3459           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3460 !        call vec_and_deriv
3461 #ifdef TIMING
3462         time01=MPI_Wtime()
3463 #endif
3464 !        print *, "before set matrices"
3465         call set_matrices
3466 !        print *, "after set matrices"
3467
3468 #ifdef TIMING
3469         time_mat=time_mat+MPI_Wtime()-time01
3470 #endif
3471       endif
3472 !       print *, "after set matrices"
3473 !d      do i=1,nres-1
3474 !d        write (iout,*) 'i=',i
3475 !d        do k=1,3
3476 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3477 !d        enddo
3478 !d        do k=1,3
3479 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3480 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3481 !d        enddo
3482 !d      enddo
3483       t_eelecij=0.0d0
3484       ees=0.0D0
3485       evdw1=0.0D0
3486       eel_loc=0.0d0
3487       eello_turn3=0.0d0
3488       eello_turn4=0.0d0
3489 !el      ind=0
3490       do i=1,nres
3491         num_cont_hb(i)=0
3492       enddo
3493 !d      print '(a)','Enter EELEC'
3494 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3495 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3496 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3497       do i=1,nres
3498         gel_loc_loc(i)=0.0d0
3499         gcorr_loc(i)=0.0d0
3500       enddo
3501 !
3502 !
3503 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3504 !
3505 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3506 !
3507
3508
3509 !        print *,"before iturn3 loop"
3510       do i=iturn3_start,iturn3_end
3511         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3512         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3513         dxi=dc(1,i)
3514         dyi=dc(2,i)
3515         dzi=dc(3,i)
3516         dx_normi=dc_norm(1,i)
3517         dy_normi=dc_norm(2,i)
3518         dz_normi=dc_norm(3,i)
3519         xmedi=c(1,i)+0.5d0*dxi
3520         ymedi=c(2,i)+0.5d0*dyi
3521         zmedi=c(3,i)+0.5d0*dzi
3522           xmedi=dmod(xmedi,boxxsize)
3523           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3524           ymedi=dmod(ymedi,boxysize)
3525           if (ymedi.lt.0) ymedi=ymedi+boxysize
3526           zmedi=dmod(zmedi,boxzsize)
3527           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3528         num_conti=0
3529        if ((zmedi.gt.bordlipbot) &
3530         .and.(zmedi.lt.bordliptop)) then
3531 !C the energy transfer exist
3532         if (zmedi.lt.buflipbot) then
3533 !C what fraction I am in
3534          fracinbuf=1.0d0- &
3535                ((zmedi-bordlipbot)/lipbufthick)
3536 !C lipbufthick is thickenes of lipid buffore
3537          sslipi=sscalelip(fracinbuf)
3538          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3539         elseif (zmedi.gt.bufliptop) then
3540          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3541          sslipi=sscalelip(fracinbuf)
3542          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3543         else
3544          sslipi=1.0d0
3545          ssgradlipi=0.0
3546         endif
3547        else
3548          sslipi=0.0d0
3549          ssgradlipi=0.0
3550        endif
3551 !       print *,i,sslipi,ssgradlipi
3552        call eelecij(i,i+2,ees,evdw1,eel_loc)
3553         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3554         num_cont_hb(i)=num_conti
3555       enddo
3556       do i=iturn4_start,iturn4_end
3557         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3558           .or. itype(i+3,1).eq.ntyp1 &
3559           .or. itype(i+4,1).eq.ntyp1) cycle
3560 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3561         dxi=dc(1,i)
3562         dyi=dc(2,i)
3563         dzi=dc(3,i)
3564         dx_normi=dc_norm(1,i)
3565         dy_normi=dc_norm(2,i)
3566         dz_normi=dc_norm(3,i)
3567         xmedi=c(1,i)+0.5d0*dxi
3568         ymedi=c(2,i)+0.5d0*dyi
3569         zmedi=c(3,i)+0.5d0*dzi
3570           xmedi=dmod(xmedi,boxxsize)
3571           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3572           ymedi=dmod(ymedi,boxysize)
3573           if (ymedi.lt.0) ymedi=ymedi+boxysize
3574           zmedi=dmod(zmedi,boxzsize)
3575           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3576        if ((zmedi.gt.bordlipbot)  &
3577        .and.(zmedi.lt.bordliptop)) then
3578 !C the energy transfer exist
3579         if (zmedi.lt.buflipbot) then
3580 !C what fraction I am in
3581          fracinbuf=1.0d0- &
3582              ((zmedi-bordlipbot)/lipbufthick)
3583 !C lipbufthick is thickenes of lipid buffore
3584          sslipi=sscalelip(fracinbuf)
3585          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3586         elseif (zmedi.gt.bufliptop) then
3587          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3588          sslipi=sscalelip(fracinbuf)
3589          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3590         else
3591          sslipi=1.0d0
3592          ssgradlipi=0.0
3593         endif
3594        else
3595          sslipi=0.0d0
3596          ssgradlipi=0.0
3597        endif
3598
3599         num_conti=num_cont_hb(i)
3600         call eelecij(i,i+3,ees,evdw1,eel_loc)
3601         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3602          call eturn4(i,eello_turn4)
3603 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3604         num_cont_hb(i)=num_conti
3605       enddo   ! i
3606 !
3607 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3608 !
3609 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3610       do i=iatel_s,iatel_e
3611         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3612         dxi=dc(1,i)
3613         dyi=dc(2,i)
3614         dzi=dc(3,i)
3615         dx_normi=dc_norm(1,i)
3616         dy_normi=dc_norm(2,i)
3617         dz_normi=dc_norm(3,i)
3618         xmedi=c(1,i)+0.5d0*dxi
3619         ymedi=c(2,i)+0.5d0*dyi
3620         zmedi=c(3,i)+0.5d0*dzi
3621           xmedi=dmod(xmedi,boxxsize)
3622           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3623           ymedi=dmod(ymedi,boxysize)
3624           if (ymedi.lt.0) ymedi=ymedi+boxysize
3625           zmedi=dmod(zmedi,boxzsize)
3626           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3627        if ((zmedi.gt.bordlipbot)  &
3628         .and.(zmedi.lt.bordliptop)) then
3629 !C the energy transfer exist
3630         if (zmedi.lt.buflipbot) then
3631 !C what fraction I am in
3632          fracinbuf=1.0d0- &
3633              ((zmedi-bordlipbot)/lipbufthick)
3634 !C lipbufthick is thickenes of lipid buffore
3635          sslipi=sscalelip(fracinbuf)
3636          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3637         elseif (zmedi.gt.bufliptop) then
3638          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3639          sslipi=sscalelip(fracinbuf)
3640          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3641         else
3642          sslipi=1.0d0
3643          ssgradlipi=0.0
3644         endif
3645        else
3646          sslipi=0.0d0
3647          ssgradlipi=0.0
3648        endif
3649
3650 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3651         num_conti=num_cont_hb(i)
3652         do j=ielstart(i),ielend(i)
3653 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3654           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3655           call eelecij(i,j,ees,evdw1,eel_loc)
3656         enddo ! j
3657         num_cont_hb(i)=num_conti
3658       enddo   ! i
3659 !      write (iout,*) "Number of loop steps in EELEC:",ind
3660 !d      do i=1,nres
3661 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3662 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3663 !d      enddo
3664 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3665 !cc      eel_loc=eel_loc+eello_turn3
3666 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3667       return
3668       end subroutine eelec
3669 !-----------------------------------------------------------------------------
3670       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3671
3672       use comm_locel
3673 !      implicit real*8 (a-h,o-z)
3674 !      include 'DIMENSIONS'
3675 #ifdef MPI
3676       include "mpif.h"
3677 #endif
3678 !      include 'COMMON.CONTROL'
3679 !      include 'COMMON.IOUNITS'
3680 !      include 'COMMON.GEO'
3681 !      include 'COMMON.VAR'
3682 !      include 'COMMON.LOCAL'
3683 !      include 'COMMON.CHAIN'
3684 !      include 'COMMON.DERIV'
3685 !      include 'COMMON.INTERACT'
3686 !      include 'COMMON.CONTACTS'
3687 !      include 'COMMON.TORSION'
3688 !      include 'COMMON.VECTORS'
3689 !      include 'COMMON.FFIELD'
3690 !      include 'COMMON.TIME1'
3691       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3692       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3693       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3694 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3695       real(kind=8),dimension(4) :: muij
3696       real(kind=8) :: geel_loc_ij,geel_loc_ji
3697       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3698                     dist_temp, dist_init,rlocshield,fracinbuf
3699       integer xshift,yshift,zshift,ilist,iresshield
3700 !el      integer :: num_conti,j1,j2
3701 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3702 !el        dz_normi,xmedi,ymedi,zmedi
3703
3704 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3705 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3706 !el          num_conti,j1,j2
3707
3708 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3709 #ifdef MOMENT
3710       real(kind=8) :: scal_el=1.0d0
3711 #else
3712       real(kind=8) :: scal_el=0.5d0
3713 #endif
3714 ! 12/13/98
3715 ! 13-go grudnia roku pamietnego...
3716       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3717                                              0.0d0,1.0d0,0.0d0,&
3718                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3719 !      integer :: maxconts=nres/4
3720 !el local variables
3721       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3722       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3723       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3724       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3725                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3726                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3727                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3728                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3729                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3730                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3731                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3732 !      maxconts=nres/4
3733 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3734 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3735
3736 !          time00=MPI_Wtime()
3737 !d      write (iout,*) "eelecij",i,j
3738 !          ind=ind+1
3739           iteli=itel(i)
3740           itelj=itel(j)
3741           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3742           aaa=app(iteli,itelj)
3743           bbb=bpp(iteli,itelj)
3744           ael6i=ael6(iteli,itelj)
3745           ael3i=ael3(iteli,itelj)
3746           dxj=dc(1,j)
3747           dyj=dc(2,j)
3748           dzj=dc(3,j)
3749           dx_normj=dc_norm(1,j)
3750           dy_normj=dc_norm(2,j)
3751           dz_normj=dc_norm(3,j)
3752 !          xj=c(1,j)+0.5D0*dxj-xmedi
3753 !          yj=c(2,j)+0.5D0*dyj-ymedi
3754 !          zj=c(3,j)+0.5D0*dzj-zmedi
3755           xj=c(1,j)+0.5D0*dxj
3756           yj=c(2,j)+0.5D0*dyj
3757           zj=c(3,j)+0.5D0*dzj
3758           xj=mod(xj,boxxsize)
3759           if (xj.lt.0) xj=xj+boxxsize
3760           yj=mod(yj,boxysize)
3761           if (yj.lt.0) yj=yj+boxysize
3762           zj=mod(zj,boxzsize)
3763           if (zj.lt.0) zj=zj+boxzsize
3764        if ((zj.gt.bordlipbot)  &
3765        .and.(zj.lt.bordliptop)) then
3766 !C the energy transfer exist
3767         if (zj.lt.buflipbot) then
3768 !C what fraction I am in
3769          fracinbuf=1.0d0-     &
3770              ((zj-bordlipbot)/lipbufthick)
3771 !C lipbufthick is thickenes of lipid buffore
3772          sslipj=sscalelip(fracinbuf)
3773          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3774         elseif (zj.gt.bufliptop) then
3775          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3776          sslipj=sscalelip(fracinbuf)
3777          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3778         else
3779          sslipj=1.0d0
3780          ssgradlipj=0.0
3781         endif
3782        else
3783          sslipj=0.0d0
3784          ssgradlipj=0.0
3785        endif
3786
3787       isubchap=0
3788       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3789       xj_safe=xj
3790       yj_safe=yj
3791       zj_safe=zj
3792       do xshift=-1,1
3793       do yshift=-1,1
3794       do zshift=-1,1
3795           xj=xj_safe+xshift*boxxsize
3796           yj=yj_safe+yshift*boxysize
3797           zj=zj_safe+zshift*boxzsize
3798           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3799           if(dist_temp.lt.dist_init) then
3800             dist_init=dist_temp
3801             xj_temp=xj
3802             yj_temp=yj
3803             zj_temp=zj
3804             isubchap=1
3805           endif
3806        enddo
3807        enddo
3808        enddo
3809        if (isubchap.eq.1) then
3810 !C          print *,i,j
3811           xj=xj_temp-xmedi
3812           yj=yj_temp-ymedi
3813           zj=zj_temp-zmedi
3814        else
3815           xj=xj_safe-xmedi
3816           yj=yj_safe-ymedi
3817           zj=zj_safe-zmedi
3818        endif
3819
3820           rij=xj*xj+yj*yj+zj*zj
3821           rrmij=1.0D0/rij
3822           rij=dsqrt(rij)
3823 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3824             sss_ele_cut=sscale_ele(rij)
3825             sss_ele_grad=sscagrad_ele(rij)
3826 !             sss_ele_cut=1.0d0
3827 !             sss_ele_grad=0.0d0
3828 !            print *,sss_ele_cut,sss_ele_grad,&
3829 !            (rij),r_cut_ele,rlamb_ele
3830 !            if (sss_ele_cut.le.0.0) go to 128
3831
3832           rmij=1.0D0/rij
3833           r3ij=rrmij*rmij
3834           r6ij=r3ij*r3ij
3835           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3836           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3837           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3838           fac=cosa-3.0D0*cosb*cosg
3839           ev1=aaa*r6ij*r6ij
3840 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3841           if (j.eq.i+2) ev1=scal_el*ev1
3842           ev2=bbb*r6ij
3843           fac3=ael6i*r6ij
3844           fac4=ael3i*r3ij
3845           evdwij=ev1+ev2
3846           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3847           el2=fac4*fac
3848 !          eesij=el1+el2
3849           if (shield_mode.gt.0) then
3850 !C          fac_shield(i)=0.4
3851 !C          fac_shield(j)=0.6
3852           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3853           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3854           eesij=(el1+el2)
3855           ees=ees+eesij*sss_ele_cut
3856 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3857 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3858           else
3859           fac_shield(i)=1.0
3860           fac_shield(j)=1.0
3861           eesij=(el1+el2)
3862           ees=ees+eesij   &
3863             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3864 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3865           endif
3866
3867 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3868           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3869 !          ees=ees+eesij*sss_ele_cut
3870           evdw1=evdw1+evdwij*sss_ele_cut  &
3871            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3872 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3873 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3874 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3875 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3876
3877           if (energy_dec) then
3878 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3879 !                  'evdw1',i,j,evdwij,&
3880 !                  iteli,itelj,aaa,evdw1
3881               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3882               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3883           endif
3884 !
3885 ! Calculate contributions to the Cartesian gradient.
3886 !
3887 #ifdef SPLITELE
3888           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3889               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3890           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3891              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3892           fac1=fac
3893           erij(1)=xj*rmij
3894           erij(2)=yj*rmij
3895           erij(3)=zj*rmij
3896 !
3897 ! Radial derivatives. First process both termini of the fragment (i,j)
3898 !
3899           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3900           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3901           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3902            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3903           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3904             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3905
3906           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3907           (shield_mode.gt.0)) then
3908 !C          print *,i,j
3909           do ilist=1,ishield_list(i)
3910            iresshield=shield_list(ilist,i)
3911            do k=1,3
3912            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3913            *2.0*sss_ele_cut
3914            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3915                    rlocshield &
3916             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3917             *sss_ele_cut
3918             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3919            enddo
3920           enddo
3921           do ilist=1,ishield_list(j)
3922            iresshield=shield_list(ilist,j)
3923            do k=1,3
3924            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3925           *2.0*sss_ele_cut
3926            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3927                    rlocshield &
3928            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3929            *sss_ele_cut
3930            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3931            enddo
3932           enddo
3933           do k=1,3
3934             gshieldc(k,i)=gshieldc(k,i)+ &
3935                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3936            *sss_ele_cut
3937
3938             gshieldc(k,j)=gshieldc(k,j)+ &
3939                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3940            *sss_ele_cut
3941
3942             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3943                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3944            *sss_ele_cut
3945
3946             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3947                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3948            *sss_ele_cut
3949
3950            enddo
3951            endif
3952
3953
3954 !          do k=1,3
3955 !            ghalf=0.5D0*ggg(k)
3956 !            gelc(k,i)=gelc(k,i)+ghalf
3957 !            gelc(k,j)=gelc(k,j)+ghalf
3958 !          enddo
3959 ! 9/28/08 AL Gradient compotents will be summed only at the end
3960           do k=1,3
3961             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3962             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3963           enddo
3964             gelc_long(3,j)=gelc_long(3,j)+  &
3965           ssgradlipj*eesij/2.0d0*lipscale**2&
3966            *sss_ele_cut
3967
3968             gelc_long(3,i)=gelc_long(3,i)+  &
3969           ssgradlipi*eesij/2.0d0*lipscale**2&
3970            *sss_ele_cut
3971
3972
3973 !
3974 ! Loop over residues i+1 thru j-1.
3975 !
3976 !grad          do k=i+1,j-1
3977 !grad            do l=1,3
3978 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3979 !grad            enddo
3980 !grad          enddo
3981           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3982            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3983           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3984            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3985           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3986            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3987
3988 !          do k=1,3
3989 !            ghalf=0.5D0*ggg(k)
3990 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3991 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3992 !          enddo
3993 ! 9/28/08 AL Gradient compotents will be summed only at the end
3994           do k=1,3
3995             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3996             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3997           enddo
3998
3999 !C Lipidic part for scaling weight
4000            gvdwpp(3,j)=gvdwpp(3,j)+ &
4001           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4002            gvdwpp(3,i)=gvdwpp(3,i)+ &
4003           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4004 !! Loop over residues i+1 thru j-1.
4005 !
4006 !grad          do k=i+1,j-1
4007 !grad            do l=1,3
4008 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4009 !grad            enddo
4010 !grad          enddo
4011 #else
4012           facvdw=(ev1+evdwij)*sss_ele_cut &
4013            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4014
4015           facel=(el1+eesij)*sss_ele_cut
4016           fac1=fac
4017           fac=-3*rrmij*(facvdw+facvdw+facel)
4018           erij(1)=xj*rmij
4019           erij(2)=yj*rmij
4020           erij(3)=zj*rmij
4021 !
4022 ! Radial derivatives. First process both termini of the fragment (i,j)
4023 !
4024           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4025           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4026           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4027 !          do k=1,3
4028 !            ghalf=0.5D0*ggg(k)
4029 !            gelc(k,i)=gelc(k,i)+ghalf
4030 !            gelc(k,j)=gelc(k,j)+ghalf
4031 !          enddo
4032 ! 9/28/08 AL Gradient compotents will be summed only at the end
4033           do k=1,3
4034             gelc_long(k,j)=gelc(k,j)+ggg(k)
4035             gelc_long(k,i)=gelc(k,i)-ggg(k)
4036           enddo
4037 !
4038 ! Loop over residues i+1 thru j-1.
4039 !
4040 !grad          do k=i+1,j-1
4041 !grad            do l=1,3
4042 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4043 !grad            enddo
4044 !grad          enddo
4045 ! 9/28/08 AL Gradient compotents will be summed only at the end
4046           ggg(1)=facvdw*xj &
4047            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4048           ggg(2)=facvdw*yj &
4049            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4050           ggg(3)=facvdw*zj &
4051            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4052
4053           do k=1,3
4054             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4056           enddo
4057            gvdwpp(3,j)=gvdwpp(3,j)+ &
4058           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4059            gvdwpp(3,i)=gvdwpp(3,i)+ &
4060           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4061
4062 #endif
4063 !
4064 ! Angular part
4065 !
4066           ecosa=2.0D0*fac3*fac1+fac4
4067           fac4=-3.0D0*fac4
4068           fac3=-6.0D0*fac3
4069           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4070           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4071           do k=1,3
4072             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4073             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4074           enddo
4075 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4076 !d   &          (dcosg(k),k=1,3)
4077           do k=1,3
4078             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4079              *fac_shield(i)**2*fac_shield(j)**2 &
4080              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4081
4082           enddo
4083 !          do k=1,3
4084 !            ghalf=0.5D0*ggg(k)
4085 !            gelc(k,i)=gelc(k,i)+ghalf
4086 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4087 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4088 !            gelc(k,j)=gelc(k,j)+ghalf
4089 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4090 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4091 !          enddo
4092 !grad          do k=i+1,j-1
4093 !grad            do l=1,3
4094 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4095 !grad            enddo
4096 !grad          enddo
4097           do k=1,3
4098             gelc(k,i)=gelc(k,i) &
4099                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4100                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4101                      *sss_ele_cut &
4102                      *fac_shield(i)**2*fac_shield(j)**2 &
4103                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4104
4105             gelc(k,j)=gelc(k,j) &
4106                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4107                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4108                      *sss_ele_cut  &
4109                      *fac_shield(i)**2*fac_shield(j)**2  &
4110                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4111
4112             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4113             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4114           enddo
4115
4116           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4117               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4118               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4119 !
4120 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4121 !   energy of a peptide unit is assumed in the form of a second-order
4122 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4123 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4124 !   are computed for EVERY pair of non-contiguous peptide groups.
4125 !
4126           if (j.lt.nres-1) then
4127             j1=j+1
4128             j2=j-1
4129           else
4130             j1=j-1
4131             j2=j-2
4132           endif
4133           kkk=0
4134           do k=1,2
4135             do l=1,2
4136               kkk=kkk+1
4137               muij(kkk)=mu(k,i)*mu(l,j)
4138 #ifdef NEWCORR
4139              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4140 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4141              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4142              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4143 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4144              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4145 #endif
4146
4147             enddo
4148           enddo
4149 !d         write (iout,*) 'EELEC: i',i,' j',j
4150 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4151 !d          write(iout,*) 'muij',muij
4152           ury=scalar(uy(1,i),erij)
4153           urz=scalar(uz(1,i),erij)
4154           vry=scalar(uy(1,j),erij)
4155           vrz=scalar(uz(1,j),erij)
4156           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4157           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4158           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4159           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4160           fac=dsqrt(-ael6i)*r3ij
4161           a22=a22*fac
4162           a23=a23*fac
4163           a32=a32*fac
4164           a33=a33*fac
4165 !d          write (iout,'(4i5,4f10.5)')
4166 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4167 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4168 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4169 !d     &      uy(:,j),uz(:,j)
4170 !d          write (iout,'(4f10.5)')
4171 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4172 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4173 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4174 !d           write (iout,'(9f10.5/)')
4175 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4176 ! Derivatives of the elements of A in virtual-bond vectors
4177           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4178           do k=1,3
4179             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4180             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4181             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4182             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4183             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4184             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4185             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4186             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4187             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4188             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4189             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4190             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4191           enddo
4192 ! Compute radial contributions to the gradient
4193           facr=-3.0d0*rrmij
4194           a22der=a22*facr
4195           a23der=a23*facr
4196           a32der=a32*facr
4197           a33der=a33*facr
4198           agg(1,1)=a22der*xj
4199           agg(2,1)=a22der*yj
4200           agg(3,1)=a22der*zj
4201           agg(1,2)=a23der*xj
4202           agg(2,2)=a23der*yj
4203           agg(3,2)=a23der*zj
4204           agg(1,3)=a32der*xj
4205           agg(2,3)=a32der*yj
4206           agg(3,3)=a32der*zj
4207           agg(1,4)=a33der*xj
4208           agg(2,4)=a33der*yj
4209           agg(3,4)=a33der*zj
4210 ! Add the contributions coming from er
4211           fac3=-3.0d0*fac
4212           do k=1,3
4213             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4214             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4215             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4216             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4217           enddo
4218           do k=1,3
4219 ! Derivatives in DC(i)
4220 !grad            ghalf1=0.5d0*agg(k,1)
4221 !grad            ghalf2=0.5d0*agg(k,2)
4222 !grad            ghalf3=0.5d0*agg(k,3)
4223 !grad            ghalf4=0.5d0*agg(k,4)
4224             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4225             -3.0d0*uryg(k,2)*vry)!+ghalf1
4226             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4227             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4228             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4229             -3.0d0*urzg(k,2)*vry)!+ghalf3
4230             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4231             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4232 ! Derivatives in DC(i+1)
4233             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4234             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4235             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4236             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4237             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4238             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4239             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4240             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4241 ! Derivatives in DC(j)
4242             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4243             -3.0d0*vryg(k,2)*ury)!+ghalf1
4244             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4245             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4246             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4247             -3.0d0*vryg(k,2)*urz)!+ghalf3
4248             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4249             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4250 ! Derivatives in DC(j+1) or DC(nres-1)
4251             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4252             -3.0d0*vryg(k,3)*ury)
4253             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4254             -3.0d0*vrzg(k,3)*ury)
4255             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4256             -3.0d0*vryg(k,3)*urz)
4257             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4258             -3.0d0*vrzg(k,3)*urz)
4259 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4260 !grad              do l=1,4
4261 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4262 !grad              enddo
4263 !grad            endif
4264           enddo
4265           acipa(1,1)=a22
4266           acipa(1,2)=a23
4267           acipa(2,1)=a32
4268           acipa(2,2)=a33
4269           a22=-a22
4270           a23=-a23
4271           do l=1,2
4272             do k=1,3
4273               agg(k,l)=-agg(k,l)
4274               aggi(k,l)=-aggi(k,l)
4275               aggi1(k,l)=-aggi1(k,l)
4276               aggj(k,l)=-aggj(k,l)
4277               aggj1(k,l)=-aggj1(k,l)
4278             enddo
4279           enddo
4280           if (j.lt.nres-1) then
4281             a22=-a22
4282             a32=-a32
4283             do l=1,3,2
4284               do k=1,3
4285                 agg(k,l)=-agg(k,l)
4286                 aggi(k,l)=-aggi(k,l)
4287                 aggi1(k,l)=-aggi1(k,l)
4288                 aggj(k,l)=-aggj(k,l)
4289                 aggj1(k,l)=-aggj1(k,l)
4290               enddo
4291             enddo
4292           else
4293             a22=-a22
4294             a23=-a23
4295             a32=-a32
4296             a33=-a33
4297             do l=1,4
4298               do k=1,3
4299                 agg(k,l)=-agg(k,l)
4300                 aggi(k,l)=-aggi(k,l)
4301                 aggi1(k,l)=-aggi1(k,l)
4302                 aggj(k,l)=-aggj(k,l)
4303                 aggj1(k,l)=-aggj1(k,l)
4304               enddo
4305             enddo
4306           endif
4307           ENDIF ! WCORR
4308           IF (wel_loc.gt.0.0d0) THEN
4309 ! Contribution to the local-electrostatic energy coming from the i-j pair
4310           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4311            +a33*muij(4)
4312           if (shield_mode.eq.0) then
4313            fac_shield(i)=1.0
4314            fac_shield(j)=1.0
4315           endif
4316           eel_loc_ij=eel_loc_ij &
4317          *fac_shield(i)*fac_shield(j) &
4318          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4319 !C Now derivative over eel_loc
4320           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4321          (shield_mode.gt.0)) then
4322 !C          print *,i,j
4323
4324           do ilist=1,ishield_list(i)
4325            iresshield=shield_list(ilist,i)
4326            do k=1,3
4327            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4328                                                 /fac_shield(i)&
4329            *sss_ele_cut
4330            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4331                    rlocshield  &
4332           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4333           *sss_ele_cut
4334
4335             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4336            +rlocshield
4337            enddo
4338           enddo
4339           do ilist=1,ishield_list(j)
4340            iresshield=shield_list(ilist,j)
4341            do k=1,3
4342            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4343                                             /fac_shield(j)   &
4344             *sss_ele_cut
4345            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4346                    rlocshield  &
4347       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4348        *sss_ele_cut
4349
4350            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4351                   +rlocshield
4352
4353            enddo
4354           enddo
4355
4356           do k=1,3
4357             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4358                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4359                     *sss_ele_cut
4360             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4361                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4362                     *sss_ele_cut
4363             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4364                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4365                     *sss_ele_cut
4366             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4367                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4368                     *sss_ele_cut
4369
4370            enddo
4371            endif
4372
4373 #ifdef NEWCORR
4374          geel_loc_ij=(a22*gmuij1(1)&
4375           +a23*gmuij1(2)&
4376           +a32*gmuij1(3)&
4377           +a33*gmuij1(4))&
4378          *fac_shield(i)*fac_shield(j)&
4379                     *sss_ele_cut
4380
4381 !c         write(iout,*) "derivative over thatai"
4382 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4383 !c     &   a33*gmuij1(4)
4384          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4385            geel_loc_ij*wel_loc
4386 !c         write(iout,*) "derivative over thatai-1"
4387 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4388 !c     &   a33*gmuij2(4)
4389          geel_loc_ij=&
4390           a22*gmuij2(1)&
4391           +a23*gmuij2(2)&
4392           +a32*gmuij2(3)&
4393           +a33*gmuij2(4)
4394          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4395            geel_loc_ij*wel_loc&
4396          *fac_shield(i)*fac_shield(j)&
4397                     *sss_ele_cut
4398
4399
4400 !c  Derivative over j residue
4401          geel_loc_ji=a22*gmuji1(1)&
4402           +a23*gmuji1(2)&
4403           +a32*gmuji1(3)&
4404           +a33*gmuji1(4)
4405 !c         write(iout,*) "derivative over thataj"
4406 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4407 !c     &   a33*gmuji1(4)
4408
4409         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4410            geel_loc_ji*wel_loc&
4411          *fac_shield(i)*fac_shield(j)&
4412                     *sss_ele_cut
4413
4414
4415          geel_loc_ji=&
4416           +a22*gmuji2(1)&
4417           +a23*gmuji2(2)&
4418           +a32*gmuji2(3)&
4419           +a33*gmuji2(4)
4420 !c         write(iout,*) "derivative over thataj-1"
4421 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4422 !c     &   a33*gmuji2(4)
4423          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4424            geel_loc_ji*wel_loc&
4425          *fac_shield(i)*fac_shield(j)&
4426                     *sss_ele_cut
4427 #endif
4428
4429 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4430 !           eel_loc_ij=0.0
4431 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4432 !                  'eelloc',i,j,eel_loc_ij
4433           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4434                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4435 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4436
4437 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4438 !          if (energy_dec) write (iout,*) "muij",muij
4439 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4440
4441           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4442 ! Partial derivatives in virtual-bond dihedral angles gamma
4443           if (i.gt.1) &
4444           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4445                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4446                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4447                  *sss_ele_cut  &
4448           *fac_shield(i)*fac_shield(j) &
4449           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4450
4451           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4452                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4453                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4454                  *sss_ele_cut &
4455           *fac_shield(i)*fac_shield(j) &
4456           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4458 !          do l=1,3
4459 !            ggg(1)=(agg(1,1)*muij(1)+ &
4460 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4461 !            *sss_ele_cut &
4462 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4463 !            ggg(2)=(agg(2,1)*muij(1)+ &
4464 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4465 !            *sss_ele_cut &
4466 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4467 !            ggg(3)=(agg(3,1)*muij(1)+ &
4468 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4469 !            *sss_ele_cut &
4470 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4471            xtemp(1)=xj
4472            xtemp(2)=yj
4473            xtemp(3)=zj
4474
4475            do l=1,3
4476             ggg(l)=(agg(l,1)*muij(1)+ &
4477                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4478             *sss_ele_cut &
4479           *fac_shield(i)*fac_shield(j) &
4480           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4481              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4482
4483
4484             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4485             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4486 !grad            ghalf=0.5d0*ggg(l)
4487 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4488 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4489           enddo
4490             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4491           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4492           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4493
4494             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4495           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4496           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4497
4498 !grad          do k=i+1,j2
4499 !grad            do l=1,3
4500 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4501 !grad            enddo
4502 !grad          enddo
4503 ! Remaining derivatives of eello
4504           do l=1,3
4505             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4506                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4507             *sss_ele_cut &
4508           *fac_shield(i)*fac_shield(j) &
4509           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4510
4511 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4512             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4513                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4514             +aggi1(l,4)*muij(4))&
4515             *sss_ele_cut &
4516           *fac_shield(i)*fac_shield(j) &
4517           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4518
4519 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4520             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4521                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4522             *sss_ele_cut &
4523           *fac_shield(i)*fac_shield(j) &
4524           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4525
4526 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4527             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4528                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4529             +aggj1(l,4)*muij(4))&
4530             *sss_ele_cut &
4531           *fac_shield(i)*fac_shield(j) &
4532          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4533
4534 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4535           enddo
4536           ENDIF
4537 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4538 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4539           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4540              .and. num_conti.le.maxconts) then
4541 !            write (iout,*) i,j," entered corr"
4542 !
4543 ! Calculate the contact function. The ith column of the array JCONT will
4544 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4545 ! greater than I). The arrays FACONT and GACONT will contain the values of
4546 ! the contact function and its derivative.
4547 !           r0ij=1.02D0*rpp(iteli,itelj)
4548 !           r0ij=1.11D0*rpp(iteli,itelj)
4549             r0ij=2.20D0*rpp(iteli,itelj)
4550 !           r0ij=1.55D0*rpp(iteli,itelj)
4551             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4552 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4553             if (fcont.gt.0.0D0) then
4554               num_conti=num_conti+1
4555               if (num_conti.gt.maxconts) then
4556 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4557 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4558                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4559                                ' will skip next contacts for this conf.', num_conti
4560               else
4561                 jcont_hb(num_conti,i)=j
4562 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4563 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4564                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4565                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4566 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4567 !  terms.
4568                 d_cont(num_conti,i)=rij
4569 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4570 !     --- Electrostatic-interaction matrix ---
4571                 a_chuj(1,1,num_conti,i)=a22
4572                 a_chuj(1,2,num_conti,i)=a23
4573                 a_chuj(2,1,num_conti,i)=a32
4574                 a_chuj(2,2,num_conti,i)=a33
4575 !     --- Gradient of rij
4576                 do kkk=1,3
4577                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4578                 enddo
4579                 kkll=0
4580                 do k=1,2
4581                   do l=1,2
4582                     kkll=kkll+1
4583                     do m=1,3
4584                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4585                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4586                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4587                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4588                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4589                     enddo
4590                   enddo
4591                 enddo
4592                 ENDIF
4593                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4594 ! Calculate contact energies
4595                 cosa4=4.0D0*cosa
4596                 wij=cosa-3.0D0*cosb*cosg
4597                 cosbg1=cosb+cosg
4598                 cosbg2=cosb-cosg
4599 !               fac3=dsqrt(-ael6i)/r0ij**3
4600                 fac3=dsqrt(-ael6i)*r3ij
4601 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4602                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4603                 if (ees0tmp.gt.0) then
4604                   ees0pij=dsqrt(ees0tmp)
4605                 else
4606                   ees0pij=0
4607                 endif
4608                 if (shield_mode.eq.0) then
4609                 fac_shield(i)=1.0d0
4610                 fac_shield(j)=1.0d0
4611                 else
4612                 ees0plist(num_conti,i)=j
4613                 endif
4614 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4615                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4616                 if (ees0tmp.gt.0) then
4617                   ees0mij=dsqrt(ees0tmp)
4618                 else
4619                   ees0mij=0
4620                 endif
4621 !               ees0mij=0.0D0
4622                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4623                      *sss_ele_cut &
4624                      *fac_shield(i)*fac_shield(j)
4625
4626                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4627                      *sss_ele_cut &
4628                      *fac_shield(i)*fac_shield(j)
4629
4630 ! Diagnostics. Comment out or remove after debugging!
4631 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4632 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4633 !               ees0m(num_conti,i)=0.0D0
4634 ! End diagnostics.
4635 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4636 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4637 ! Angular derivatives of the contact function
4638                 ees0pij1=fac3/ees0pij
4639                 ees0mij1=fac3/ees0mij
4640                 fac3p=-3.0D0*fac3*rrmij
4641                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4642                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4643 !               ees0mij1=0.0D0
4644                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4645                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4646                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4647                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4648                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4649                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4650                 ecosap=ecosa1+ecosa2
4651                 ecosbp=ecosb1+ecosb2
4652                 ecosgp=ecosg1+ecosg2
4653                 ecosam=ecosa1-ecosa2
4654                 ecosbm=ecosb1-ecosb2
4655                 ecosgm=ecosg1-ecosg2
4656 ! Diagnostics
4657 !               ecosap=ecosa1
4658 !               ecosbp=ecosb1
4659 !               ecosgp=ecosg1
4660 !               ecosam=0.0D0
4661 !               ecosbm=0.0D0
4662 !               ecosgm=0.0D0
4663 ! End diagnostics
4664                 facont_hb(num_conti,i)=fcont
4665                 fprimcont=fprimcont/rij
4666 !d              facont_hb(num_conti,i)=1.0D0
4667 ! Following line is for diagnostics.
4668 !d              fprimcont=0.0D0
4669                 do k=1,3
4670                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4671                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4672                 enddo
4673                 do k=1,3
4674                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4675                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4676                 enddo
4677                 gggp(1)=gggp(1)+ees0pijp*xj &
4678                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4679                 gggp(2)=gggp(2)+ees0pijp*yj &
4680                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4681                 gggp(3)=gggp(3)+ees0pijp*zj &
4682                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4683
4684                 gggm(1)=gggm(1)+ees0mijp*xj &
4685                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4686
4687                 gggm(2)=gggm(2)+ees0mijp*yj &
4688                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4689
4690                 gggm(3)=gggm(3)+ees0mijp*zj &
4691                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4692
4693 ! Derivatives due to the contact function
4694                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4695                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4696                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4697                 do k=1,3
4698 !
4699 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4700 !          following the change of gradient-summation algorithm.
4701 !
4702 !grad                  ghalfp=0.5D0*gggp(k)
4703 !grad                  ghalfm=0.5D0*gggm(k)
4704                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4705                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4706                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4707                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4708
4709                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4710                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4711                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4712                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4713
4714                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4715                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4716
4717                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4718                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4719                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4720                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4721
4722                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4723                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4724                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4725                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4726
4727                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4728                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4729
4730                 enddo
4731 ! Diagnostics. Comment out or remove after debugging!
4732 !diag           do k=1,3
4733 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4734 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4735 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4736 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4737 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4738 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4739 !diag           enddo
4740               ENDIF ! wcorr
4741               endif  ! num_conti.le.maxconts
4742             endif  ! fcont.gt.0
4743           endif    ! j.gt.i+1
4744           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4745             do k=1,4
4746               do l=1,3
4747                 ghalf=0.5d0*agg(l,k)
4748                 aggi(l,k)=aggi(l,k)+ghalf
4749                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4750                 aggj(l,k)=aggj(l,k)+ghalf
4751               enddo
4752             enddo
4753             if (j.eq.nres-1 .and. i.lt.j-2) then
4754               do k=1,4
4755                 do l=1,3
4756                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4757                 enddo
4758               enddo
4759             endif
4760           endif
4761  128  continue
4762 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4763       return
4764       end subroutine eelecij
4765 !-----------------------------------------------------------------------------
4766       subroutine eturn3(i,eello_turn3)
4767 ! Third- and fourth-order contributions from turns
4768
4769       use comm_locel
4770 !      implicit real*8 (a-h,o-z)
4771 !      include 'DIMENSIONS'
4772 !      include 'COMMON.IOUNITS'
4773 !      include 'COMMON.GEO'
4774 !      include 'COMMON.VAR'
4775 !      include 'COMMON.LOCAL'
4776 !      include 'COMMON.CHAIN'
4777 !      include 'COMMON.DERIV'
4778 !      include 'COMMON.INTERACT'
4779 !      include 'COMMON.CONTACTS'
4780 !      include 'COMMON.TORSION'
4781 !      include 'COMMON.VECTORS'
4782 !      include 'COMMON.FFIELD'
4783 !      include 'COMMON.CONTROL'
4784       real(kind=8),dimension(3) :: ggg
4785       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4786         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4787        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4788
4789       real(kind=8),dimension(2) :: auxvec,auxvec1
4790 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4791       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4792 !el      integer :: num_conti,j1,j2
4793 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4794 !el        dz_normi,xmedi,ymedi,zmedi
4795
4796 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4797 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4798 !el         num_conti,j1,j2
4799 !el local variables
4800       integer :: i,j,l,k,ilist,iresshield
4801       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4802
4803       j=i+2
4804 !      write (iout,*) "eturn3",i,j,j1,j2
4805           zj=(c(3,j)+c(3,j+1))/2.0d0
4806           zj=mod(zj,boxzsize)
4807           if (zj.lt.0) zj=zj+boxzsize
4808           if ((zj.lt.0)) write (*,*) "CHUJ"
4809        if ((zj.gt.bordlipbot)  &
4810         .and.(zj.lt.bordliptop)) then
4811 !C the energy transfer exist
4812         if (zj.lt.buflipbot) then
4813 !C what fraction I am in
4814          fracinbuf=1.0d0-     &
4815              ((zj-bordlipbot)/lipbufthick)
4816 !C lipbufthick is thickenes of lipid buffore
4817          sslipj=sscalelip(fracinbuf)
4818          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4819         elseif (zj.gt.bufliptop) then
4820          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4821          sslipj=sscalelip(fracinbuf)
4822          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4823         else
4824          sslipj=1.0d0
4825          ssgradlipj=0.0
4826         endif
4827        else
4828          sslipj=0.0d0
4829          ssgradlipj=0.0
4830        endif
4831
4832       a_temp(1,1)=a22
4833       a_temp(1,2)=a23
4834       a_temp(2,1)=a32
4835       a_temp(2,2)=a33
4836 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4837 !
4838 !               Third-order contributions
4839 !
4840 !                 (i+2)o----(i+3)
4841 !                      | |
4842 !                      | |
4843 !                 (i+1)o----i
4844 !
4845 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4846 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4847         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4848         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4849         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4850         call transpose2(auxmat(1,1),auxmat1(1,1))
4851         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4852         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4853         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4854         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4855         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4856
4857         if (shield_mode.eq.0) then
4858         fac_shield(i)=1.0d0
4859         fac_shield(j)=1.0d0
4860         endif
4861
4862         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4863          *fac_shield(i)*fac_shield(j)  &
4864          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4865         eello_t3= &
4866         0.5d0*(pizda(1,1)+pizda(2,2)) &
4867         *fac_shield(i)*fac_shield(j)
4868
4869         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4870                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4871 !C#ifdef NEWCORR
4872 !C Derivatives in theta
4873         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4874        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4875         *fac_shield(i)*fac_shield(j)
4876         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4877        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4878         *fac_shield(i)*fac_shield(j)
4879 !C#endif
4880
4881
4882
4883           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4884        (shield_mode.gt.0)) then
4885 !C          print *,i,j
4886
4887           do ilist=1,ishield_list(i)
4888            iresshield=shield_list(ilist,i)
4889            do k=1,3
4890            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4891            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4892                    rlocshield &
4893            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4894             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4895              +rlocshield
4896            enddo
4897           enddo
4898           do ilist=1,ishield_list(j)
4899            iresshield=shield_list(ilist,j)
4900            do k=1,3
4901            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4902            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4903                    rlocshield &
4904            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4905            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4906                   +rlocshield
4907
4908            enddo
4909           enddo
4910
4911           do k=1,3
4912             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4913                    grad_shield(k,i)*eello_t3/fac_shield(i)
4914             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4915                    grad_shield(k,j)*eello_t3/fac_shield(j)
4916             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4917                    grad_shield(k,i)*eello_t3/fac_shield(i)
4918             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4919                    grad_shield(k,j)*eello_t3/fac_shield(j)
4920            enddo
4921            endif
4922
4923 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4924 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4925 !d     &    ' eello_turn3_num',4*eello_turn3_num
4926 ! Derivatives in gamma(i)
4927         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4928         call transpose2(auxmat2(1,1),auxmat3(1,1))
4929         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4930         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4931           *fac_shield(i)*fac_shield(j)        &
4932           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4933 ! Derivatives in gamma(i+1)
4934         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4935         call transpose2(auxmat2(1,1),auxmat3(1,1))
4936         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4937         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4938           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4939           *fac_shield(i)*fac_shield(j)        &
4940           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4941
4942 ! Cartesian derivatives
4943         do l=1,3
4944 !            ghalf1=0.5d0*agg(l,1)
4945 !            ghalf2=0.5d0*agg(l,2)
4946 !            ghalf3=0.5d0*agg(l,3)
4947 !            ghalf4=0.5d0*agg(l,4)
4948           a_temp(1,1)=aggi(l,1)!+ghalf1
4949           a_temp(1,2)=aggi(l,2)!+ghalf2
4950           a_temp(2,1)=aggi(l,3)!+ghalf3
4951           a_temp(2,2)=aggi(l,4)!+ghalf4
4952           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4953           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4954             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4955           *fac_shield(i)*fac_shield(j)      &
4956           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4957
4958           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4959           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4960           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4961           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4962           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4963           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4964             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4965           *fac_shield(i)*fac_shield(j)        &
4966           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4967
4968           a_temp(1,1)=aggj(l,1)!+ghalf1
4969           a_temp(1,2)=aggj(l,2)!+ghalf2
4970           a_temp(2,1)=aggj(l,3)!+ghalf3
4971           a_temp(2,2)=aggj(l,4)!+ghalf4
4972           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4973           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4974             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4975           *fac_shield(i)*fac_shield(j)      &
4976           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4977
4978           a_temp(1,1)=aggj1(l,1)
4979           a_temp(1,2)=aggj1(l,2)
4980           a_temp(2,1)=aggj1(l,3)
4981           a_temp(2,2)=aggj1(l,4)
4982           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4983           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4984             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4985           *fac_shield(i)*fac_shield(j)        &
4986           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4987         enddo
4988          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4989           ssgradlipi*eello_t3/4.0d0*lipscale
4990          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4991           ssgradlipj*eello_t3/4.0d0*lipscale
4992          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4993           ssgradlipi*eello_t3/4.0d0*lipscale
4994          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4995           ssgradlipj*eello_t3/4.0d0*lipscale
4996
4997       return
4998       end subroutine eturn3
4999 !-----------------------------------------------------------------------------
5000       subroutine eturn4(i,eello_turn4)
5001 ! Third- and fourth-order contributions from turns
5002
5003       use comm_locel
5004 !      implicit real*8 (a-h,o-z)
5005 !      include 'DIMENSIONS'
5006 !      include 'COMMON.IOUNITS'
5007 !      include 'COMMON.GEO'
5008 !      include 'COMMON.VAR'
5009 !      include 'COMMON.LOCAL'
5010 !      include 'COMMON.CHAIN'
5011 !      include 'COMMON.DERIV'
5012 !      include 'COMMON.INTERACT'
5013 !      include 'COMMON.CONTACTS'
5014 !      include 'COMMON.TORSION'
5015 !      include 'COMMON.VECTORS'
5016 !      include 'COMMON.FFIELD'
5017 !      include 'COMMON.CONTROL'
5018       real(kind=8),dimension(3) :: ggg
5019       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5020         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5021         gte1t,gte2t,gte3t,&
5022         gte1a,gtae3,gtae3e2, ae3gte2,&
5023         gtEpizda1,gtEpizda2,gtEpizda3
5024
5025       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5026        auxgEvec3,auxgvec
5027
5028 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5029       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5030 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5031 !el        dz_normi,xmedi,ymedi,zmedi
5032 !el      integer :: num_conti,j1,j2
5033 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5034 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5035 !el          num_conti,j1,j2
5036 !el local variables
5037       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5038       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5039          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5040
5041       j=i+3
5042 !      if (j.ne.20) return
5043 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5044 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5045 !
5046 !               Fourth-order contributions
5047 !
5048 !                 (i+3)o----(i+4)
5049 !                     /  |
5050 !               (i+2)o   |
5051 !                     \  |
5052 !                 (i+1)o----i
5053 !
5054 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5055 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5056 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5057           zj=(c(3,j)+c(3,j+1))/2.0d0
5058           zj=mod(zj,boxzsize)
5059           if (zj.lt.0) zj=zj+boxzsize
5060        if ((zj.gt.bordlipbot)  &
5061         .and.(zj.lt.bordliptop)) then
5062 !C the energy transfer exist
5063         if (zj.lt.buflipbot) then
5064 !C what fraction I am in
5065          fracinbuf=1.0d0-     &
5066              ((zj-bordlipbot)/lipbufthick)
5067 !C lipbufthick is thickenes of lipid buffore
5068          sslipj=sscalelip(fracinbuf)
5069          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5070         elseif (zj.gt.bufliptop) then
5071          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5072          sslipj=sscalelip(fracinbuf)
5073          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5074         else
5075          sslipj=1.0d0
5076          ssgradlipj=0.0
5077         endif
5078        else
5079          sslipj=0.0d0
5080          ssgradlipj=0.0
5081        endif
5082
5083         a_temp(1,1)=a22
5084         a_temp(1,2)=a23
5085         a_temp(2,1)=a32
5086         a_temp(2,2)=a33
5087         iti1=i+1
5088         iti2=i+2
5089         iti3=i+3
5090 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5091         call transpose2(EUg(1,1,i+1),e1t(1,1))
5092         call transpose2(Eug(1,1,i+2),e2t(1,1))
5093         call transpose2(Eug(1,1,i+3),e3t(1,1))
5094 !C Ematrix derivative in theta
5095         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5096         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5097         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5098
5099         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5100         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5101         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5102         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5103 !c       auxalary matrix of E i+1
5104         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5105         s1=scalar2(b1(1,iti2),auxvec(1))
5106 !c derivative of theta i+2 with constant i+3
5107         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5108 !c derivative of theta i+2 with constant i+2
5109         gs32=scalar2(b1(1,i+2),auxgvec(1))
5110 !c derivative of E matix in theta of i+1
5111         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5112
5113         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5114         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5115         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5116 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5117         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5118 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5119         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5120         s2=scalar2(b1(1,i+1),auxvec(1))
5121 !c derivative of theta i+1 with constant i+3
5122         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5123 !c derivative of theta i+2 with constant i+1
5124         gs21=scalar2(b1(1,i+1),auxgvec(1))
5125 !c derivative of theta i+3 with constant i+1
5126         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5127
5128         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5129         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5130 !c ae3gte2 is derivative over i+2
5131         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5132
5133         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5134         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5135 !c i+2
5136         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5137 !c i+3
5138         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5139
5140         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5141         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5142         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5143         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5144         if (shield_mode.eq.0) then
5145         fac_shield(i)=1.0
5146         fac_shield(j)=1.0
5147         endif
5148
5149         eello_turn4=eello_turn4-(s1+s2+s3) &
5150         *fac_shield(i)*fac_shield(j)       &
5151         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5152         eello_t4=-(s1+s2+s3)  &
5153           *fac_shield(i)*fac_shield(j)
5154 !C Now derivative over shield:
5155           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5156          (shield_mode.gt.0)) then
5157 !C          print *,i,j
5158
5159           do ilist=1,ishield_list(i)
5160            iresshield=shield_list(ilist,i)
5161            do k=1,3
5162            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5163 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5164            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5165                    rlocshield &
5166             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5167             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5168            +rlocshield
5169            enddo
5170           enddo
5171           do ilist=1,ishield_list(j)
5172            iresshield=shield_list(ilist,j)
5173            do k=1,3
5174 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5175            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5176            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5177                    rlocshield  &
5178            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5179            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5180                   +rlocshield
5181 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5182
5183            enddo
5184           enddo
5185           do k=1,3
5186             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5187                    grad_shield(k,i)*eello_t4/fac_shield(i)
5188             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5189                    grad_shield(k,j)*eello_t4/fac_shield(j)
5190             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5191                    grad_shield(k,i)*eello_t4/fac_shield(i)
5192             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5193                    grad_shield(k,j)*eello_t4/fac_shield(j)
5194 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5195            enddo
5196            endif
5197 #ifdef NEWCORR
5198         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5199                        -(gs13+gsE13+gsEE1)*wturn4&
5200        *fac_shield(i)*fac_shield(j)
5201         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5202                          -(gs23+gs21+gsEE2)*wturn4&
5203        *fac_shield(i)*fac_shield(j)
5204
5205         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5206                          -(gs32+gsE31+gsEE3)*wturn4&
5207        *fac_shield(i)*fac_shield(j)
5208
5209 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5210 !c     &   gs2
5211 #endif
5212         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5213            'eturn4',i,j,-(s1+s2+s3)
5214 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5215 !d     &    ' eello_turn4_num',8*eello_turn4_num
5216 ! Derivatives in gamma(i)
5217         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5218         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5219         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5220         s1=scalar2(b1(1,i+1),auxvec(1))
5221         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5222         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5223         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5224        *fac_shield(i)*fac_shield(j)  &
5225        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5226
5227 ! Derivatives in gamma(i+1)
5228         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5229         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5230         s2=scalar2(b1(1,iti1),auxvec(1))
5231         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5232         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5233         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5234         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5235        *fac_shield(i)*fac_shield(j)  &
5236        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5237
5238 ! Derivatives in gamma(i+2)
5239         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5240         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5241         s1=scalar2(b1(1,iti2),auxvec(1))
5242         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5243         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5244         s2=scalar2(b1(1,iti1),auxvec(1))
5245         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5246         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5247         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5248         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5249        *fac_shield(i)*fac_shield(j)  &
5250        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5251
5252 ! Cartesian derivatives
5253 ! Derivatives of this turn contributions in DC(i+2)
5254         if (j.lt.nres-1) then
5255           do l=1,3
5256             a_temp(1,1)=agg(l,1)
5257             a_temp(1,2)=agg(l,2)
5258             a_temp(2,1)=agg(l,3)
5259             a_temp(2,2)=agg(l,4)
5260             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5261             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5262             s1=scalar2(b1(1,iti2),auxvec(1))
5263             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5264             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5265             s2=scalar2(b1(1,iti1),auxvec(1))
5266             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5267             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5268             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269             ggg(l)=-(s1+s2+s3)
5270             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5271        *fac_shield(i)*fac_shield(j)  &
5272        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5273
5274           enddo
5275         endif
5276 ! Remaining derivatives of this turn contribution
5277         do l=1,3
5278           a_temp(1,1)=aggi(l,1)
5279           a_temp(1,2)=aggi(l,2)
5280           a_temp(2,1)=aggi(l,3)
5281           a_temp(2,2)=aggi(l,4)
5282           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5283           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5284           s1=scalar2(b1(1,iti2),auxvec(1))
5285           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5286           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5287           s2=scalar2(b1(1,iti1),auxvec(1))
5288           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5289           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5290           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5291           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5292          *fac_shield(i)*fac_shield(j)  &
5293          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5294
5295
5296           a_temp(1,1)=aggi1(l,1)
5297           a_temp(1,2)=aggi1(l,2)
5298           a_temp(2,1)=aggi1(l,3)
5299           a_temp(2,2)=aggi1(l,4)
5300           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5301           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5302           s1=scalar2(b1(1,iti2),auxvec(1))
5303           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5304           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5305           s2=scalar2(b1(1,iti1),auxvec(1))
5306           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5307           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5308           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5310          *fac_shield(i)*fac_shield(j)  &
5311          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5312
5313
5314           a_temp(1,1)=aggj(l,1)
5315           a_temp(1,2)=aggj(l,2)
5316           a_temp(2,1)=aggj(l,3)
5317           a_temp(2,2)=aggj(l,4)
5318           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5319           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5320           s1=scalar2(b1(1,iti2),auxvec(1))
5321           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5322           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5323           s2=scalar2(b1(1,iti1),auxvec(1))
5324           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5325           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5326           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5327 !        if (j.lt.nres-1) then
5328           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5329          *fac_shield(i)*fac_shield(j)  &
5330          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5331 !        endif
5332
5333           a_temp(1,1)=aggj1(l,1)
5334           a_temp(1,2)=aggj1(l,2)
5335           a_temp(2,1)=aggj1(l,3)
5336           a_temp(2,2)=aggj1(l,4)
5337           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5338           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5339           s1=scalar2(b1(1,iti2),auxvec(1))
5340           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5341           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5342           s2=scalar2(b1(1,iti1),auxvec(1))
5343           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5344           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5345           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5346 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5347 !        if (j.lt.nres-1) then
5348 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5349           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5350          *fac_shield(i)*fac_shield(j)  &
5351          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5352 !            if (shield_mode.gt.0) then
5353 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5354 !            else
5355 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5356 !            endif
5357 !         endif
5358         enddo
5359          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5360           ssgradlipi*eello_t4/4.0d0*lipscale
5361          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5362           ssgradlipj*eello_t4/4.0d0*lipscale
5363          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5364           ssgradlipi*eello_t4/4.0d0*lipscale
5365          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5366           ssgradlipj*eello_t4/4.0d0*lipscale
5367
5368       return
5369       end subroutine eturn4
5370 !-----------------------------------------------------------------------------
5371       subroutine unormderiv(u,ugrad,unorm,ungrad)
5372 ! This subroutine computes the derivatives of a normalized vector u, given
5373 ! the derivatives computed without normalization conditions, ugrad. Returns
5374 ! ungrad.
5375 !      implicit none
5376       real(kind=8),dimension(3) :: u,vec
5377       real(kind=8),dimension(3,3) ::ugrad,ungrad
5378       real(kind=8) :: unorm      !,scalar
5379       integer :: i,j
5380 !      write (2,*) 'ugrad',ugrad
5381 !      write (2,*) 'u',u
5382       do i=1,3
5383         vec(i)=scalar(ugrad(1,i),u(1))
5384       enddo
5385 !      write (2,*) 'vec',vec
5386       do i=1,3
5387         do j=1,3
5388           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5389         enddo
5390       enddo
5391 !      write (2,*) 'ungrad',ungrad
5392       return
5393       end subroutine unormderiv
5394 !-----------------------------------------------------------------------------
5395       subroutine escp_soft_sphere(evdw2,evdw2_14)
5396 !
5397 ! This subroutine calculates the excluded-volume interaction energy between
5398 ! peptide-group centers and side chains and its gradient in virtual-bond and
5399 ! side-chain vectors.
5400 !
5401 !      implicit real*8 (a-h,o-z)
5402 !      include 'DIMENSIONS'
5403 !      include 'COMMON.GEO'
5404 !      include 'COMMON.VAR'
5405 !      include 'COMMON.LOCAL'
5406 !      include 'COMMON.CHAIN'
5407 !      include 'COMMON.DERIV'
5408 !      include 'COMMON.INTERACT'
5409 !      include 'COMMON.FFIELD'
5410 !      include 'COMMON.IOUNITS'
5411 !      include 'COMMON.CONTROL'
5412       real(kind=8),dimension(3) :: ggg
5413 !el local variables
5414       integer :: i,iint,j,k,iteli,itypj
5415       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5416                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5417
5418       evdw2=0.0D0
5419       evdw2_14=0.0d0
5420       r0_scp=4.5d0
5421 !d    print '(a)','Enter ESCP'
5422 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5423       do i=iatscp_s,iatscp_e
5424         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5425         iteli=itel(i)
5426         xi=0.5D0*(c(1,i)+c(1,i+1))
5427         yi=0.5D0*(c(2,i)+c(2,i+1))
5428         zi=0.5D0*(c(3,i)+c(3,i+1))
5429
5430         do iint=1,nscp_gr(i)
5431
5432         do j=iscpstart(i,iint),iscpend(i,iint)
5433           if (itype(j,1).eq.ntyp1) cycle
5434           itypj=iabs(itype(j,1))
5435 ! Uncomment following three lines for SC-p interactions
5436 !         xj=c(1,nres+j)-xi
5437 !         yj=c(2,nres+j)-yi
5438 !         zj=c(3,nres+j)-zi
5439 ! Uncomment following three lines for Ca-p interactions
5440           xj=c(1,j)-xi
5441           yj=c(2,j)-yi
5442           zj=c(3,j)-zi
5443           rij=xj*xj+yj*yj+zj*zj
5444           r0ij=r0_scp
5445           r0ijsq=r0ij*r0ij
5446           if (rij.lt.r0ijsq) then
5447             evdwij=0.25d0*(rij-r0ijsq)**2
5448             fac=rij-r0ijsq
5449           else
5450             evdwij=0.0d0
5451             fac=0.0d0
5452           endif
5453           evdw2=evdw2+evdwij
5454 !
5455 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5456 !
5457           ggg(1)=xj*fac
5458           ggg(2)=yj*fac
5459           ggg(3)=zj*fac
5460 !grad          if (j.lt.i) then
5461 !d          write (iout,*) 'j<i'
5462 ! Uncomment following three lines for SC-p interactions
5463 !           do k=1,3
5464 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5465 !           enddo
5466 !grad          else
5467 !d          write (iout,*) 'j>i'
5468 !grad            do k=1,3
5469 !grad              ggg(k)=-ggg(k)
5470 ! Uncomment following line for SC-p interactions
5471 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5472 !grad            enddo
5473 !grad          endif
5474 !grad          do k=1,3
5475 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5476 !grad          enddo
5477 !grad          kstart=min0(i+1,j)
5478 !grad          kend=max0(i-1,j-1)
5479 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5480 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5481 !grad          do k=kstart,kend
5482 !grad            do l=1,3
5483 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5484 !grad            enddo
5485 !grad          enddo
5486           do k=1,3
5487             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5488             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5489           enddo
5490         enddo
5491
5492         enddo ! iint
5493       enddo ! i
5494       return
5495       end subroutine escp_soft_sphere
5496 !-----------------------------------------------------------------------------
5497       subroutine escp(evdw2,evdw2_14)
5498 !
5499 ! This subroutine calculates the excluded-volume interaction energy between
5500 ! peptide-group centers and side chains and its gradient in virtual-bond and
5501 ! side-chain vectors.
5502 !
5503 !      implicit real*8 (a-h,o-z)
5504 !      include 'DIMENSIONS'
5505 !      include 'COMMON.GEO'
5506 !      include 'COMMON.VAR'
5507 !      include 'COMMON.LOCAL'
5508 !      include 'COMMON.CHAIN'
5509 !      include 'COMMON.DERIV'
5510 !      include 'COMMON.INTERACT'
5511 !      include 'COMMON.FFIELD'
5512 !      include 'COMMON.IOUNITS'
5513 !      include 'COMMON.CONTROL'
5514       real(kind=8),dimension(3) :: ggg
5515 !el local variables
5516       integer :: i,iint,j,k,iteli,itypj,subchap
5517       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5518                    e1,e2,evdwij,rij
5519       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5520                     dist_temp, dist_init
5521       integer xshift,yshift,zshift
5522
5523       evdw2=0.0D0
5524       evdw2_14=0.0d0
5525 !d    print '(a)','Enter ESCP'
5526 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5527       do i=iatscp_s,iatscp_e
5528         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5529         iteli=itel(i)
5530         xi=0.5D0*(c(1,i)+c(1,i+1))
5531         yi=0.5D0*(c(2,i)+c(2,i+1))
5532         zi=0.5D0*(c(3,i)+c(3,i+1))
5533           xi=mod(xi,boxxsize)
5534           if (xi.lt.0) xi=xi+boxxsize
5535           yi=mod(yi,boxysize)
5536           if (yi.lt.0) yi=yi+boxysize
5537           zi=mod(zi,boxzsize)
5538           if (zi.lt.0) zi=zi+boxzsize
5539
5540         do iint=1,nscp_gr(i)
5541
5542         do j=iscpstart(i,iint),iscpend(i,iint)
5543           itypj=iabs(itype(j,1))
5544           if (itypj.eq.ntyp1) cycle
5545 ! Uncomment following three lines for SC-p interactions
5546 !         xj=c(1,nres+j)-xi
5547 !         yj=c(2,nres+j)-yi
5548 !         zj=c(3,nres+j)-zi
5549 ! Uncomment following three lines for Ca-p interactions
5550 !          xj=c(1,j)-xi
5551 !          yj=c(2,j)-yi
5552 !          zj=c(3,j)-zi
5553           xj=c(1,j)
5554           yj=c(2,j)
5555           zj=c(3,j)
5556           xj=mod(xj,boxxsize)
5557           if (xj.lt.0) xj=xj+boxxsize
5558           yj=mod(yj,boxysize)
5559           if (yj.lt.0) yj=yj+boxysize
5560           zj=mod(zj,boxzsize)
5561           if (zj.lt.0) zj=zj+boxzsize
5562       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5563       xj_safe=xj
5564       yj_safe=yj
5565       zj_safe=zj
5566       subchap=0
5567       do xshift=-1,1
5568       do yshift=-1,1
5569       do zshift=-1,1
5570           xj=xj_safe+xshift*boxxsize
5571           yj=yj_safe+yshift*boxysize
5572           zj=zj_safe+zshift*boxzsize
5573           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5574           if(dist_temp.lt.dist_init) then
5575             dist_init=dist_temp
5576             xj_temp=xj
5577             yj_temp=yj
5578             zj_temp=zj
5579             subchap=1
5580           endif
5581        enddo
5582        enddo
5583        enddo
5584        if (subchap.eq.1) then
5585           xj=xj_temp-xi
5586           yj=yj_temp-yi
5587           zj=zj_temp-zi
5588        else
5589           xj=xj_safe-xi
5590           yj=yj_safe-yi
5591           zj=zj_safe-zi
5592        endif
5593
5594           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5595           rij=dsqrt(1.0d0/rrij)
5596             sss_ele_cut=sscale_ele(rij)
5597             sss_ele_grad=sscagrad_ele(rij)
5598 !            print *,sss_ele_cut,sss_ele_grad,&
5599 !            (rij),r_cut_ele,rlamb_ele
5600             if (sss_ele_cut.le.0.0) cycle
5601           fac=rrij**expon2
5602           e1=fac*fac*aad(itypj,iteli)
5603           e2=fac*bad(itypj,iteli)
5604           if (iabs(j-i) .le. 2) then
5605             e1=scal14*e1
5606             e2=scal14*e2
5607             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5608           endif
5609           evdwij=e1+e2
5610           evdw2=evdw2+evdwij*sss_ele_cut
5611 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5612 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5613           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5614              'evdw2',i,j,evdwij
5615 !
5616 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5617 !
5618           fac=-(evdwij+e1)*rrij*sss_ele_cut
5619           fac=fac+evdwij*sss_ele_grad/rij/expon
5620           ggg(1)=xj*fac
5621           ggg(2)=yj*fac
5622           ggg(3)=zj*fac
5623 !grad          if (j.lt.i) then
5624 !d          write (iout,*) 'j<i'
5625 ! Uncomment following three lines for SC-p interactions
5626 !           do k=1,3
5627 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5628 !           enddo
5629 !grad          else
5630 !d          write (iout,*) 'j>i'
5631 !grad            do k=1,3
5632 !grad              ggg(k)=-ggg(k)
5633 ! Uncomment following line for SC-p interactions
5634 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5635 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5636 !grad            enddo
5637 !grad          endif
5638 !grad          do k=1,3
5639 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5640 !grad          enddo
5641 !grad          kstart=min0(i+1,j)
5642 !grad          kend=max0(i-1,j-1)
5643 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5644 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5645 !grad          do k=kstart,kend
5646 !grad            do l=1,3
5647 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5648 !grad            enddo
5649 !grad          enddo
5650           do k=1,3
5651             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5652             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5653           enddo
5654         enddo
5655
5656         enddo ! iint
5657       enddo ! i
5658       do i=1,nct
5659         do j=1,3
5660           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5661           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5662           gradx_scp(j,i)=expon*gradx_scp(j,i)
5663         enddo
5664       enddo
5665 !******************************************************************************
5666 !
5667 !                              N O T E !!!
5668 !
5669 ! To save time the factor EXPON has been extracted from ALL components
5670 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5671 ! use!
5672 !
5673 !******************************************************************************
5674       return
5675       end subroutine escp
5676 !-----------------------------------------------------------------------------
5677       subroutine edis(ehpb)
5678 !
5679 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5680 !
5681 !      implicit real*8 (a-h,o-z)
5682 !      include 'DIMENSIONS'
5683 !      include 'COMMON.SBRIDGE'
5684 !      include 'COMMON.CHAIN'
5685 !      include 'COMMON.DERIV'
5686 !      include 'COMMON.VAR'
5687 !      include 'COMMON.INTERACT'
5688 !      include 'COMMON.IOUNITS'
5689       real(kind=8),dimension(3) :: ggg
5690 !el local variables
5691       integer :: i,j,ii,jj,iii,jjj,k
5692       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5693
5694       ehpb=0.0D0
5695 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5696 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5697       if (link_end.eq.0) return
5698       do i=link_start,link_end
5699 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5700 ! CA-CA distance used in regularization of structure.
5701         ii=ihpb(i)
5702         jj=jhpb(i)
5703 ! iii and jjj point to the residues for which the distance is assigned.
5704         if (ii.gt.nres) then
5705           iii=ii-nres
5706           jjj=jj-nres
5707         else
5708           iii=ii
5709           jjj=jj
5710         endif
5711 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5712 !     &    dhpb(i),dhpb1(i),forcon(i)
5713 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5714 !    distance and angle dependent SS bond potential.
5715 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5716 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5717         if (.not.dyn_ss .and. i.le.nss) then
5718 ! 15/02/13 CC dynamic SSbond - additional check
5719          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5720         iabs(itype(jjj,1)).eq.1) then
5721           call ssbond_ene(iii,jjj,eij)
5722           ehpb=ehpb+2*eij
5723 !d          write (iout,*) "eij",eij
5724          endif
5725         else if (ii.gt.nres .and. jj.gt.nres) then
5726 !c Restraints from contact prediction
5727           dd=dist(ii,jj)
5728           if (constr_dist.eq.11) then
5729             ehpb=ehpb+fordepth(i)**4.0d0 &
5730                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5731             fac=fordepth(i)**4.0d0 &
5732                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5733           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5734             ehpb,fordepth(i),dd
5735            else
5736           if (dhpb1(i).gt.0.0d0) then
5737             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5738             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5739 !c            write (iout,*) "beta nmr",
5740 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5741           else
5742             dd=dist(ii,jj)
5743             rdis=dd-dhpb(i)
5744 !C Get the force constant corresponding to this distance.
5745             waga=forcon(i)
5746 !C Calculate the contribution to energy.
5747             ehpb=ehpb+waga*rdis*rdis
5748 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5749 !C
5750 !C Evaluate gradient.
5751 !C
5752             fac=waga*rdis/dd
5753           endif
5754           endif
5755           do j=1,3
5756             ggg(j)=fac*(c(j,jj)-c(j,ii))
5757           enddo
5758           do j=1,3
5759             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5760             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5761           enddo
5762           do k=1,3
5763             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5764             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5765           enddo
5766         else
5767           dd=dist(ii,jj)
5768           if (constr_dist.eq.11) then
5769             ehpb=ehpb+fordepth(i)**4.0d0 &
5770                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5771             fac=fordepth(i)**4.0d0 &
5772                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5773           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5774          ehpb,fordepth(i),dd
5775            else
5776           if (dhpb1(i).gt.0.0d0) then
5777             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5778             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5779 !c            write (iout,*) "alph nmr",
5780 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5781           else
5782             rdis=dd-dhpb(i)
5783 !C Get the force constant corresponding to this distance.
5784             waga=forcon(i)
5785 !C Calculate the contribution to energy.
5786             ehpb=ehpb+waga*rdis*rdis
5787 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5788 !C
5789 !C Evaluate gradient.
5790 !C
5791             fac=waga*rdis/dd
5792           endif
5793           endif
5794
5795             do j=1,3
5796               ggg(j)=fac*(c(j,jj)-c(j,ii))
5797             enddo
5798 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5799 !C If this is a SC-SC distance, we need to calculate the contributions to the
5800 !C Cartesian gradient in the SC vectors (ghpbx).
5801           if (iii.lt.ii) then
5802           do j=1,3
5803             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5804             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5805           enddo
5806           endif
5807 !cgrad        do j=iii,jjj-1
5808 !cgrad          do k=1,3
5809 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5810 !cgrad          enddo
5811 !cgrad        enddo
5812           do k=1,3
5813             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5814             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5815           enddo
5816         endif
5817       enddo
5818       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5819
5820       return
5821       end subroutine edis
5822 !-----------------------------------------------------------------------------
5823       subroutine ssbond_ene(i,j,eij)
5824 !
5825 ! Calculate the distance and angle dependent SS-bond potential energy
5826 ! using a free-energy function derived based on RHF/6-31G** ab initio
5827 ! calculations of diethyl disulfide.
5828 !
5829 ! A. Liwo and U. Kozlowska, 11/24/03
5830 !
5831 !      implicit real*8 (a-h,o-z)
5832 !      include 'DIMENSIONS'
5833 !      include 'COMMON.SBRIDGE'
5834 !      include 'COMMON.CHAIN'
5835 !      include 'COMMON.DERIV'
5836 !      include 'COMMON.LOCAL'
5837 !      include 'COMMON.INTERACT'
5838 !      include 'COMMON.VAR'
5839 !      include 'COMMON.IOUNITS'
5840       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5841 !el local variables
5842       integer :: i,j,itypi,itypj,k
5843       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5844                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5845                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5846                    cosphi,ggk
5847
5848       itypi=iabs(itype(i,1))
5849       xi=c(1,nres+i)
5850       yi=c(2,nres+i)
5851       zi=c(3,nres+i)
5852       dxi=dc_norm(1,nres+i)
5853       dyi=dc_norm(2,nres+i)
5854       dzi=dc_norm(3,nres+i)
5855 !      dsci_inv=dsc_inv(itypi)
5856       dsci_inv=vbld_inv(nres+i)
5857       itypj=iabs(itype(j,1))
5858 !      dscj_inv=dsc_inv(itypj)
5859       dscj_inv=vbld_inv(nres+j)
5860       xj=c(1,nres+j)-xi
5861       yj=c(2,nres+j)-yi
5862       zj=c(3,nres+j)-zi
5863       dxj=dc_norm(1,nres+j)
5864       dyj=dc_norm(2,nres+j)
5865       dzj=dc_norm(3,nres+j)
5866       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5867       rij=dsqrt(rrij)
5868       erij(1)=xj*rij
5869       erij(2)=yj*rij
5870       erij(3)=zj*rij
5871       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5872       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5873       om12=dxi*dxj+dyi*dyj+dzi*dzj
5874       do k=1,3
5875         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5876         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5877       enddo
5878       rij=1.0d0/rij
5879       deltad=rij-d0cm
5880       deltat1=1.0d0-om1
5881       deltat2=1.0d0+om2
5882       deltat12=om2-om1+2.0d0
5883       cosphi=om12-om1*om2
5884       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5885         +akct*deltad*deltat12 &
5886         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5887 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5888 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5889 !     &  " deltat12",deltat12," eij",eij
5890       ed=2*akcm*deltad+akct*deltat12
5891       pom1=akct*deltad
5892       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5893       eom1=-2*akth*deltat1-pom1-om2*pom2
5894       eom2= 2*akth*deltat2+pom1-om1*pom2
5895       eom12=pom2
5896       do k=1,3
5897         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5898         ghpbx(k,i)=ghpbx(k,i)-ggk &
5899                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5900                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5901         ghpbx(k,j)=ghpbx(k,j)+ggk &
5902                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5903                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5904         ghpbc(k,i)=ghpbc(k,i)-ggk
5905         ghpbc(k,j)=ghpbc(k,j)+ggk
5906       enddo
5907 !
5908 ! Calculate the components of the gradient in DC and X
5909 !
5910 !grad      do k=i,j-1
5911 !grad        do l=1,3
5912 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5913 !grad        enddo
5914 !grad      enddo
5915       return
5916       end subroutine ssbond_ene
5917 !-----------------------------------------------------------------------------
5918       subroutine ebond(estr)
5919 !
5920 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5921 !
5922 !      implicit real*8 (a-h,o-z)
5923 !      include 'DIMENSIONS'
5924 !      include 'COMMON.LOCAL'
5925 !      include 'COMMON.GEO'
5926 !      include 'COMMON.INTERACT'
5927 !      include 'COMMON.DERIV'
5928 !      include 'COMMON.VAR'
5929 !      include 'COMMON.CHAIN'
5930 !      include 'COMMON.IOUNITS'
5931 !      include 'COMMON.NAMES'
5932 !      include 'COMMON.FFIELD'
5933 !      include 'COMMON.CONTROL'
5934 !      include 'COMMON.SETUP'
5935       real(kind=8),dimension(3) :: u,ud
5936 !el local variables
5937       integer :: i,j,iti,nbi,k
5938       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5939                    uprod1,uprod2
5940
5941       estr=0.0d0
5942       estr1=0.0d0
5943 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5944 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5945
5946       do i=ibondp_start,ibondp_end
5947         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5948         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5949 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5950 !C          do j=1,3
5951 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5952 !C            *dc(j,i-1)/vbld(i)
5953 !C          enddo
5954 !C          if (energy_dec) write(iout,*) &
5955 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5956         diff = vbld(i)-vbldpDUM
5957         else
5958         diff = vbld(i)-vbldp0
5959         endif
5960         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5961            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5962         estr=estr+diff*diff
5963         do j=1,3
5964           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5965         enddo
5966 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5967 !        endif
5968       enddo
5969       estr=0.5d0*AKP*estr+estr1
5970 !      print *,"estr_bb",estr,AKP
5971 !
5972 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5973 !
5974       do i=ibond_start,ibond_end
5975         iti=iabs(itype(i,1))
5976         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5977         if (iti.ne.10 .and. iti.ne.ntyp1) then
5978           nbi=nbondterm(iti)
5979           if (nbi.eq.1) then
5980             diff=vbld(i+nres)-vbldsc0(1,iti)
5981             if (energy_dec) write (iout,*) &
5982             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5983             AKSC(1,iti),AKSC(1,iti)*diff*diff
5984             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5985 !            print *,"estr_sc",estr
5986             do j=1,3
5987               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5988             enddo
5989           else
5990             do j=1,nbi
5991               diff=vbld(i+nres)-vbldsc0(j,iti)
5992               ud(j)=aksc(j,iti)*diff
5993               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5994             enddo
5995             uprod=u(1)
5996             do j=2,nbi
5997               uprod=uprod*u(j)
5998             enddo
5999             usum=0.0d0
6000             usumsqder=0.0d0
6001             do j=1,nbi
6002               uprod1=1.0d0
6003               uprod2=1.0d0
6004               do k=1,nbi
6005                 if (k.ne.j) then
6006                   uprod1=uprod1*u(k)
6007                   uprod2=uprod2*u(k)*u(k)
6008                 endif
6009               enddo
6010               usum=usum+uprod1
6011               usumsqder=usumsqder+ud(j)*uprod2
6012             enddo
6013             estr=estr+uprod/usum
6014 !            print *,"estr_sc",estr,i
6015
6016              if (energy_dec) write (iout,*) &
6017             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6018             AKSC(1,iti),uprod/usum
6019             do j=1,3
6020              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6021             enddo
6022           endif
6023         endif
6024       enddo
6025       return
6026       end subroutine ebond
6027 #ifdef CRYST_THETA
6028 !-----------------------------------------------------------------------------
6029       subroutine ebend(etheta)
6030 !
6031 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6032 ! angles gamma and its derivatives in consecutive thetas and gammas.
6033 !
6034       use comm_calcthet
6035 !      implicit real*8 (a-h,o-z)
6036 !      include 'DIMENSIONS'
6037 !      include 'COMMON.LOCAL'
6038 !      include 'COMMON.GEO'
6039 !      include 'COMMON.INTERACT'
6040 !      include 'COMMON.DERIV'
6041 !      include 'COMMON.VAR'
6042 !      include 'COMMON.CHAIN'
6043 !      include 'COMMON.IOUNITS'
6044 !      include 'COMMON.NAMES'
6045 !      include 'COMMON.FFIELD'
6046 !      include 'COMMON.CONTROL'
6047 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6048 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6049 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6050 !el      integer :: it
6051 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6052 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6053 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6054 !el local variables
6055       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6056        ichir21,ichir22
6057       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6058        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6059        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6060       real(kind=8),dimension(2) :: y,z
6061
6062       delta=0.02d0*pi
6063 !      time11=dexp(-2*time)
6064 !      time12=1.0d0
6065       etheta=0.0D0
6066 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6067       do i=ithet_start,ithet_end
6068         if (itype(i-1,1).eq.ntyp1) cycle
6069 ! Zero the energy function and its derivative at 0 or pi.
6070         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6071         it=itype(i-1,1)
6072         ichir1=isign(1,itype(i-2,1))
6073         ichir2=isign(1,itype(i,1))
6074          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6075          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6076          if (itype(i-1,1).eq.10) then
6077           itype1=isign(10,itype(i-2,1))
6078           ichir11=isign(1,itype(i-2,1))
6079           ichir12=isign(1,itype(i-2,1))
6080           itype2=isign(10,itype(i,1))
6081           ichir21=isign(1,itype(i,1))
6082           ichir22=isign(1,itype(i,1))
6083          endif
6084
6085         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6086 #ifdef OSF
6087           phii=phi(i)
6088           if (phii.ne.phii) phii=150.0
6089 #else
6090           phii=phi(i)
6091 #endif
6092           y(1)=dcos(phii)
6093           y(2)=dsin(phii)
6094         else
6095           y(1)=0.0D0
6096           y(2)=0.0D0
6097         endif
6098         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6099 #ifdef OSF
6100           phii1=phi(i+1)
6101           if (phii1.ne.phii1) phii1=150.0
6102           phii1=pinorm(phii1)
6103           z(1)=cos(phii1)
6104 #else
6105           phii1=phi(i+1)
6106           z(1)=dcos(phii1)
6107 #endif
6108           z(2)=dsin(phii1)
6109         else
6110           z(1)=0.0D0
6111           z(2)=0.0D0
6112         endif
6113 ! Calculate the "mean" value of theta from the part of the distribution
6114 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6115 ! In following comments this theta will be referred to as t_c.
6116         thet_pred_mean=0.0d0
6117         do k=1,2
6118             athetk=athet(k,it,ichir1,ichir2)
6119             bthetk=bthet(k,it,ichir1,ichir2)
6120           if (it.eq.10) then
6121              athetk=athet(k,itype1,ichir11,ichir12)
6122              bthetk=bthet(k,itype2,ichir21,ichir22)
6123           endif
6124          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6125         enddo
6126         dthett=thet_pred_mean*ssd
6127         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6128 ! Derivatives of the "mean" values in gamma1 and gamma2.
6129         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6130                +athet(2,it,ichir1,ichir2)*y(1))*ss
6131         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6132                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6133          if (it.eq.10) then
6134         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6135              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6136         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6137                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6138          endif
6139         if (theta(i).gt.pi-delta) then
6140           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6141                E_tc0)
6142           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6143           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6144           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6145               E_theta)
6146           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6147               E_tc)
6148         else if (theta(i).lt.delta) then
6149           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6150           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6151           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6152               E_theta)
6153           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6154           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6155               E_tc)
6156         else
6157           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6158               E_theta,E_tc)
6159         endif
6160         etheta=etheta+ethetai
6161         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6162             'ebend',i,ethetai
6163         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6164         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6165         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6166       enddo
6167 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6168
6169 ! Ufff.... We've done all this!!!
6170       return
6171       end subroutine ebend
6172 !-----------------------------------------------------------------------------
6173       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6174
6175       use comm_calcthet
6176 !      implicit real*8 (a-h,o-z)
6177 !      include 'DIMENSIONS'
6178 !      include 'COMMON.LOCAL'
6179 !      include 'COMMON.IOUNITS'
6180 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6181 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6182 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6183       integer :: i,j,k
6184       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6185 !el      integer :: it
6186 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6187 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6188 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6189 !el local variables
6190       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6191        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6192
6193 ! Calculate the contributions to both Gaussian lobes.
6194 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6195 ! The "polynomial part" of the "standard deviation" of this part of
6196 ! the distribution.
6197         sig=polthet(3,it)
6198         do j=2,0,-1
6199           sig=sig*thet_pred_mean+polthet(j,it)
6200         enddo
6201 ! Derivative of the "interior part" of the "standard deviation of the"
6202 ! gamma-dependent Gaussian lobe in t_c.
6203         sigtc=3*polthet(3,it)
6204         do j=2,1,-1
6205           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6206         enddo
6207         sigtc=sig*sigtc
6208 ! Set the parameters of both Gaussian lobes of the distribution.
6209 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6210         fac=sig*sig+sigc0(it)
6211         sigcsq=fac+fac
6212         sigc=1.0D0/sigcsq
6213 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6214         sigsqtc=-4.0D0*sigcsq*sigtc
6215 !       print *,i,sig,sigtc,sigsqtc
6216 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6217         sigtc=-sigtc/(fac*fac)
6218 ! Following variable is sigma(t_c)**(-2)
6219         sigcsq=sigcsq*sigcsq
6220         sig0i=sig0(it)
6221         sig0inv=1.0D0/sig0i**2
6222         delthec=thetai-thet_pred_mean
6223         delthe0=thetai-theta0i
6224         term1=-0.5D0*sigcsq*delthec*delthec
6225         term2=-0.5D0*sig0inv*delthe0*delthe0
6226 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6227 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6228 ! to the energy (this being the log of the distribution) at the end of energy
6229 ! term evaluation for this virtual-bond angle.
6230         if (term1.gt.term2) then
6231           termm=term1
6232           term2=dexp(term2-termm)
6233           term1=1.0d0
6234         else
6235           termm=term2
6236           term1=dexp(term1-termm)
6237           term2=1.0d0
6238         endif
6239 ! The ratio between the gamma-independent and gamma-dependent lobes of
6240 ! the distribution is a Gaussian function of thet_pred_mean too.
6241         diffak=gthet(2,it)-thet_pred_mean
6242         ratak=diffak/gthet(3,it)**2
6243         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6244 ! Let's differentiate it in thet_pred_mean NOW.
6245         aktc=ak*ratak
6246 ! Now put together the distribution terms to make complete distribution.
6247         termexp=term1+ak*term2
6248         termpre=sigc+ak*sig0i
6249 ! Contribution of the bending energy from this theta is just the -log of
6250 ! the sum of the contributions from the two lobes and the pre-exponential
6251 ! factor. Simple enough, isn't it?
6252         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6253 ! NOW the derivatives!!!
6254 ! 6/6/97 Take into account the deformation.
6255         E_theta=(delthec*sigcsq*term1 &
6256              +ak*delthe0*sig0inv*term2)/termexp
6257         E_tc=((sigtc+aktc*sig0i)/termpre &
6258             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6259              aktc*term2)/termexp)
6260       return
6261       end subroutine theteng
6262 #else
6263 !-----------------------------------------------------------------------------
6264       subroutine ebend(etheta)
6265 !
6266 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6267 ! angles gamma and its derivatives in consecutive thetas and gammas.
6268 ! ab initio-derived potentials from
6269 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6270 !
6271 !      implicit real*8 (a-h,o-z)
6272 !      include 'DIMENSIONS'
6273 !      include 'COMMON.LOCAL'
6274 !      include 'COMMON.GEO'
6275 !      include 'COMMON.INTERACT'
6276 !      include 'COMMON.DERIV'
6277 !      include 'COMMON.VAR'
6278 !      include 'COMMON.CHAIN'
6279 !      include 'COMMON.IOUNITS'
6280 !      include 'COMMON.NAMES'
6281 !      include 'COMMON.FFIELD'
6282 !      include 'COMMON.CONTROL'
6283       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6284       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6285       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6286       logical :: lprn=.false., lprn1=.false.
6287 !el local variables
6288       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6289       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6290       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6291 ! local variables for constrains
6292       real(kind=8) :: difi,thetiii
6293        integer itheta
6294 !      write(iout,*) "in ebend",ithet_start,ithet_end
6295       call flush(iout)
6296       etheta=0.0D0
6297       do i=ithet_start,ithet_end
6298         if (itype(i-1,1).eq.ntyp1) cycle
6299         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6300         if (iabs(itype(i+1,1)).eq.20) iblock=2
6301         if (iabs(itype(i+1,1)).ne.20) iblock=1
6302         dethetai=0.0d0
6303         dephii=0.0d0
6304         dephii1=0.0d0
6305         theti2=0.5d0*theta(i)
6306         ityp2=ithetyp((itype(i-1,1)))
6307         do k=1,nntheterm
6308           coskt(k)=dcos(k*theti2)
6309           sinkt(k)=dsin(k*theti2)
6310         enddo
6311         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6312 #ifdef OSF
6313           phii=phi(i)
6314           if (phii.ne.phii) phii=150.0
6315 #else
6316           phii=phi(i)
6317 #endif
6318           ityp1=ithetyp((itype(i-2,1)))
6319 ! propagation of chirality for glycine type
6320           do k=1,nsingle
6321             cosph1(k)=dcos(k*phii)
6322             sinph1(k)=dsin(k*phii)
6323           enddo
6324         else
6325           phii=0.0d0
6326           ityp1=ithetyp(itype(i-2,1))
6327           do k=1,nsingle
6328             cosph1(k)=0.0d0
6329             sinph1(k)=0.0d0
6330           enddo
6331         endif
6332         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6333 #ifdef OSF
6334           phii1=phi(i+1)
6335           if (phii1.ne.phii1) phii1=150.0
6336           phii1=pinorm(phii1)
6337 #else
6338           phii1=phi(i+1)
6339 #endif
6340           ityp3=ithetyp((itype(i,1)))
6341           do k=1,nsingle
6342             cosph2(k)=dcos(k*phii1)
6343             sinph2(k)=dsin(k*phii1)
6344           enddo
6345         else
6346           phii1=0.0d0
6347           ityp3=ithetyp(itype(i,1))
6348           do k=1,nsingle
6349             cosph2(k)=0.0d0
6350             sinph2(k)=0.0d0
6351           enddo
6352         endif
6353         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6354         do k=1,ndouble
6355           do l=1,k-1
6356             ccl=cosph1(l)*cosph2(k-l)
6357             ssl=sinph1(l)*sinph2(k-l)
6358             scl=sinph1(l)*cosph2(k-l)
6359             csl=cosph1(l)*sinph2(k-l)
6360             cosph1ph2(l,k)=ccl-ssl
6361             cosph1ph2(k,l)=ccl+ssl
6362             sinph1ph2(l,k)=scl+csl
6363             sinph1ph2(k,l)=scl-csl
6364           enddo
6365         enddo
6366         if (lprn) then
6367         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6368           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6369         write (iout,*) "coskt and sinkt"
6370         do k=1,nntheterm
6371           write (iout,*) k,coskt(k),sinkt(k)
6372         enddo
6373         endif
6374         do k=1,ntheterm
6375           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6376           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6377             *coskt(k)
6378           if (lprn) &
6379           write (iout,*) "k",k,&
6380            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6381            " ethetai",ethetai
6382         enddo
6383         if (lprn) then
6384         write (iout,*) "cosph and sinph"
6385         do k=1,nsingle
6386           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6387         enddo
6388         write (iout,*) "cosph1ph2 and sinph2ph2"
6389         do k=2,ndouble
6390           do l=1,k-1
6391             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6392                sinph1ph2(l,k),sinph1ph2(k,l)
6393           enddo
6394         enddo
6395         write(iout,*) "ethetai",ethetai
6396         endif
6397         do m=1,ntheterm2
6398           do k=1,nsingle
6399             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6400                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6401                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6402                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6403             ethetai=ethetai+sinkt(m)*aux
6404             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6405             dephii=dephii+k*sinkt(m)* &
6406                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6407                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6408             dephii1=dephii1+k*sinkt(m)* &
6409                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6410                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6411             if (lprn) &
6412             write (iout,*) "m",m," k",k," bbthet", &
6413                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6414                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6415                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6416                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6417           enddo
6418         enddo
6419         if (lprn) &
6420         write(iout,*) "ethetai",ethetai
6421         do m=1,ntheterm3
6422           do k=2,ndouble
6423             do l=1,k-1
6424               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6425                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6426                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6427                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6428               ethetai=ethetai+sinkt(m)*aux
6429               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6430               dephii=dephii+l*sinkt(m)* &
6431                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6432                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6433                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6434                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6435               dephii1=dephii1+(k-l)*sinkt(m)* &
6436                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6437                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6438                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6439                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6440               if (lprn) then
6441               write (iout,*) "m",m," k",k," l",l," ffthet",&
6442                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6443                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6444                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6445                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6446                   " ethetai",ethetai
6447               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6448                   cosph1ph2(k,l)*sinkt(m),&
6449                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6450               endif
6451             enddo
6452           enddo
6453         enddo
6454 10      continue
6455 !        lprn1=.true.
6456         if (lprn1) &
6457           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6458          i,theta(i)*rad2deg,phii*rad2deg,&
6459          phii1*rad2deg,ethetai
6460 !        lprn1=.false.
6461         etheta=etheta+ethetai
6462         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6463                                     'ebend',i,ethetai
6464         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6465         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6466         gloc(nphi+i-2,icg)=wang*dethetai
6467       enddo
6468 !-----------thete constrains
6469 !      if (tor_mode.ne.2) then
6470
6471       return
6472       end subroutine ebend
6473 #endif
6474 #ifdef CRYST_SC
6475 !-----------------------------------------------------------------------------
6476       subroutine esc(escloc)
6477 ! Calculate the local energy of a side chain and its derivatives in the
6478 ! corresponding virtual-bond valence angles THETA and the spherical angles
6479 ! ALPHA and OMEGA.
6480 !
6481       use comm_sccalc
6482 !      implicit real*8 (a-h,o-z)
6483 !      include 'DIMENSIONS'
6484 !      include 'COMMON.GEO'
6485 !      include 'COMMON.LOCAL'
6486 !      include 'COMMON.VAR'
6487 !      include 'COMMON.INTERACT'
6488 !      include 'COMMON.DERIV'
6489 !      include 'COMMON.CHAIN'
6490 !      include 'COMMON.IOUNITS'
6491 !      include 'COMMON.NAMES'
6492 !      include 'COMMON.FFIELD'
6493 !      include 'COMMON.CONTROL'
6494       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6495          ddersc0,ddummy,xtemp,temp
6496 !el      real(kind=8) :: time11,time12,time112,theti
6497       real(kind=8) :: escloc,delta
6498 !el      integer :: it,nlobit
6499 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6500 !el local variables
6501       integer :: i,k
6502       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6503        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6504       delta=0.02d0*pi
6505       escloc=0.0D0
6506 !     write (iout,'(a)') 'ESC'
6507       do i=loc_start,loc_end
6508         it=itype(i,1)
6509         if (it.eq.ntyp1) cycle
6510         if (it.eq.10) goto 1
6511         nlobit=nlob(iabs(it))
6512 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6513 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6514         theti=theta(i+1)-pipol
6515         x(1)=dtan(theti)
6516         x(2)=alph(i)
6517         x(3)=omeg(i)
6518
6519         if (x(2).gt.pi-delta) then
6520           xtemp(1)=x(1)
6521           xtemp(2)=pi-delta
6522           xtemp(3)=x(3)
6523           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6524           xtemp(2)=pi
6525           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6526           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6527               escloci,dersc(2))
6528           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6529               ddersc0(1),dersc(1))
6530           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6531               ddersc0(3),dersc(3))
6532           xtemp(2)=pi-delta
6533           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6534           xtemp(2)=pi
6535           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6536           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6537                   dersc0(2),esclocbi,dersc02)
6538           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6539                   dersc12,dersc01)
6540           call splinthet(x(2),0.5d0*delta,ss,ssd)
6541           dersc0(1)=dersc01
6542           dersc0(2)=dersc02
6543           dersc0(3)=0.0d0
6544           do k=1,3
6545             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6546           enddo
6547           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6548 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6549 !    &             esclocbi,ss,ssd
6550           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6551 !         escloci=esclocbi
6552 !         write (iout,*) escloci
6553         else if (x(2).lt.delta) then
6554           xtemp(1)=x(1)
6555           xtemp(2)=delta
6556           xtemp(3)=x(3)
6557           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6558           xtemp(2)=0.0d0
6559           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6560           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6561               escloci,dersc(2))
6562           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6563               ddersc0(1),dersc(1))
6564           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6565               ddersc0(3),dersc(3))
6566           xtemp(2)=delta
6567           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6568           xtemp(2)=0.0d0
6569           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6570           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6571                   dersc0(2),esclocbi,dersc02)
6572           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6573                   dersc12,dersc01)
6574           dersc0(1)=dersc01
6575           dersc0(2)=dersc02
6576           dersc0(3)=0.0d0
6577           call splinthet(x(2),0.5d0*delta,ss,ssd)
6578           do k=1,3
6579             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6580           enddo
6581           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6582 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6583 !    &             esclocbi,ss,ssd
6584           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6585 !         write (iout,*) escloci
6586         else
6587           call enesc(x,escloci,dersc,ddummy,.false.)
6588         endif
6589
6590         escloc=escloc+escloci
6591         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6592            'escloc',i,escloci
6593 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6594
6595         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6596          wscloc*dersc(1)
6597         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6598         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6599     1   continue
6600       enddo
6601       return
6602       end subroutine esc
6603 !-----------------------------------------------------------------------------
6604       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6605
6606       use comm_sccalc
6607 !      implicit real*8 (a-h,o-z)
6608 !      include 'DIMENSIONS'
6609 !      include 'COMMON.GEO'
6610 !      include 'COMMON.LOCAL'
6611 !      include 'COMMON.IOUNITS'
6612 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6613       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6614       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6615       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6616       real(kind=8) :: escloci
6617       logical :: mixed
6618 !el local variables
6619       integer :: j,iii,l,k !el,it,nlobit
6620       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6621 !el       time11,time12,time112
6622 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6623         escloc_i=0.0D0
6624         do j=1,3
6625           dersc(j)=0.0D0
6626           if (mixed) ddersc(j)=0.0d0
6627         enddo
6628         x3=x(3)
6629
6630 ! Because of periodicity of the dependence of the SC energy in omega we have
6631 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6632 ! To avoid underflows, first compute & store the exponents.
6633
6634         do iii=-1,1
6635
6636           x(3)=x3+iii*dwapi
6637
6638           do j=1,nlobit
6639             do k=1,3
6640               z(k)=x(k)-censc(k,j,it)
6641             enddo
6642             do k=1,3
6643               Axk=0.0D0
6644               do l=1,3
6645                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6646               enddo
6647               Ax(k,j,iii)=Axk
6648             enddo
6649             expfac=0.0D0
6650             do k=1,3
6651               expfac=expfac+Ax(k,j,iii)*z(k)
6652             enddo
6653             contr(j,iii)=expfac
6654           enddo ! j
6655
6656         enddo ! iii
6657
6658         x(3)=x3
6659 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6660 ! subsequent NaNs and INFs in energy calculation.
6661 ! Find the largest exponent
6662         emin=contr(1,-1)
6663         do iii=-1,1
6664           do j=1,nlobit
6665             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6666           enddo
6667         enddo
6668         emin=0.5D0*emin
6669 !d      print *,'it=',it,' emin=',emin
6670
6671 ! Compute the contribution to SC energy and derivatives
6672         do iii=-1,1
6673
6674           do j=1,nlobit
6675 #ifdef OSF
6676             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6677             if(adexp.ne.adexp) adexp=1.0
6678             expfac=dexp(adexp)
6679 #else
6680             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6681 #endif
6682 !d          print *,'j=',j,' expfac=',expfac
6683             escloc_i=escloc_i+expfac
6684             do k=1,3
6685               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6686             enddo
6687             if (mixed) then
6688               do k=1,3,2
6689                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6690                   +gaussc(k,2,j,it))*expfac
6691               enddo
6692             endif
6693           enddo
6694
6695         enddo ! iii
6696
6697         dersc(1)=dersc(1)/cos(theti)**2
6698         ddersc(1)=ddersc(1)/cos(theti)**2
6699         ddersc(3)=ddersc(3)
6700
6701         escloci=-(dlog(escloc_i)-emin)
6702         do j=1,3
6703           dersc(j)=dersc(j)/escloc_i
6704         enddo
6705         if (mixed) then
6706           do j=1,3,2
6707             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6708           enddo
6709         endif
6710       return
6711       end subroutine enesc
6712 !-----------------------------------------------------------------------------
6713       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6714
6715       use comm_sccalc
6716 !      implicit real*8 (a-h,o-z)
6717 !      include 'DIMENSIONS'
6718 !      include 'COMMON.GEO'
6719 !      include 'COMMON.LOCAL'
6720 !      include 'COMMON.IOUNITS'
6721 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6722       real(kind=8),dimension(3) :: x,z,dersc
6723       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6724       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6725       real(kind=8) :: escloci,dersc12,emin
6726       logical :: mixed
6727 !el local varables
6728       integer :: j,k,l !el,it,nlobit
6729       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6730
6731       escloc_i=0.0D0
6732
6733       do j=1,3
6734         dersc(j)=0.0D0
6735       enddo
6736
6737       do j=1,nlobit
6738         do k=1,2
6739           z(k)=x(k)-censc(k,j,it)
6740         enddo
6741         z(3)=dwapi
6742         do k=1,3
6743           Axk=0.0D0
6744           do l=1,3
6745             Axk=Axk+gaussc(l,k,j,it)*z(l)
6746           enddo
6747           Ax(k,j)=Axk
6748         enddo
6749         expfac=0.0D0
6750         do k=1,3
6751           expfac=expfac+Ax(k,j)*z(k)
6752         enddo
6753         contr(j)=expfac
6754       enddo ! j
6755
6756 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6757 ! subsequent NaNs and INFs in energy calculation.
6758 ! Find the largest exponent
6759       emin=contr(1)
6760       do j=1,nlobit
6761         if (emin.gt.contr(j)) emin=contr(j)
6762       enddo
6763       emin=0.5D0*emin
6764
6765 ! Compute the contribution to SC energy and derivatives
6766
6767       dersc12=0.0d0
6768       do j=1,nlobit
6769         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6770         escloc_i=escloc_i+expfac
6771         do k=1,2
6772           dersc(k)=dersc(k)+Ax(k,j)*expfac
6773         enddo
6774         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6775                   +gaussc(1,2,j,it))*expfac
6776         dersc(3)=0.0d0
6777       enddo
6778
6779       dersc(1)=dersc(1)/cos(theti)**2
6780       dersc12=dersc12/cos(theti)**2
6781       escloci=-(dlog(escloc_i)-emin)
6782       do j=1,2
6783         dersc(j)=dersc(j)/escloc_i
6784       enddo
6785       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6786       return
6787       end subroutine enesc_bound
6788 #else
6789 !-----------------------------------------------------------------------------
6790       subroutine esc(escloc)
6791 ! Calculate the local energy of a side chain and its derivatives in the
6792 ! corresponding virtual-bond valence angles THETA and the spherical angles
6793 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6794 ! added by Urszula Kozlowska. 07/11/2007
6795 !
6796       use comm_sccalc
6797 !      implicit real*8 (a-h,o-z)
6798 !      include 'DIMENSIONS'
6799 !      include 'COMMON.GEO'
6800 !      include 'COMMON.LOCAL'
6801 !      include 'COMMON.VAR'
6802 !      include 'COMMON.SCROT'
6803 !      include 'COMMON.INTERACT'
6804 !      include 'COMMON.DERIV'
6805 !      include 'COMMON.CHAIN'
6806 !      include 'COMMON.IOUNITS'
6807 !      include 'COMMON.NAMES'
6808 !      include 'COMMON.FFIELD'
6809 !      include 'COMMON.CONTROL'
6810 !      include 'COMMON.VECTORS'
6811       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6812       real(kind=8),dimension(65) :: x
6813       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6814          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6815       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6816       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6817          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6818 !el local variables
6819       integer :: i,j,k !el,it,nlobit
6820       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6821 !el      real(kind=8) :: time11,time12,time112,theti
6822 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6823       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6824                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6825                    sumene1x,sumene2x,sumene3x,sumene4x,&
6826                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6827                    cosfac2xx,sinfac2yy
6828 #ifdef DEBUG
6829       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6830                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6831                    de_dt_num
6832 #endif
6833 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6834
6835       delta=0.02d0*pi
6836       escloc=0.0D0
6837       do i=loc_start,loc_end
6838         if (itype(i,1).eq.ntyp1) cycle
6839         costtab(i+1) =dcos(theta(i+1))
6840         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6841         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6842         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6843         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6844         cosfac=dsqrt(cosfac2)
6845         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6846         sinfac=dsqrt(sinfac2)
6847         it=iabs(itype(i,1))
6848         if (it.eq.10) goto 1
6849 !
6850 !  Compute the axes of tghe local cartesian coordinates system; store in
6851 !   x_prime, y_prime and z_prime
6852 !
6853         do j=1,3
6854           x_prime(j) = 0.00
6855           y_prime(j) = 0.00
6856           z_prime(j) = 0.00
6857         enddo
6858 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6859 !     &   dc_norm(3,i+nres)
6860         do j = 1,3
6861           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6862           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6863         enddo
6864         do j = 1,3
6865           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6866         enddo
6867 !       write (2,*) "i",i
6868 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6869 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6870 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6871 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6872 !      & " xy",scalar(x_prime(1),y_prime(1)),
6873 !      & " xz",scalar(x_prime(1),z_prime(1)),
6874 !      & " yy",scalar(y_prime(1),y_prime(1)),
6875 !      & " yz",scalar(y_prime(1),z_prime(1)),
6876 !      & " zz",scalar(z_prime(1),z_prime(1))
6877 !
6878 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6879 ! to local coordinate system. Store in xx, yy, zz.
6880 !
6881         xx=0.0d0
6882         yy=0.0d0
6883         zz=0.0d0
6884         do j = 1,3
6885           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6886           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6887           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6888         enddo
6889
6890         xxtab(i)=xx
6891         yytab(i)=yy
6892         zztab(i)=zz
6893 !
6894 ! Compute the energy of the ith side cbain
6895 !
6896 !        write (2,*) "xx",xx," yy",yy," zz",zz
6897         it=iabs(itype(i,1))
6898         do j = 1,65
6899           x(j) = sc_parmin(j,it)
6900         enddo
6901 #ifdef CHECK_COORD
6902 !c diagnostics - remove later
6903         xx1 = dcos(alph(2))
6904         yy1 = dsin(alph(2))*dcos(omeg(2))
6905         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6906         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6907           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6908           xx1,yy1,zz1
6909 !,"  --- ", xx_w,yy_w,zz_w
6910 ! end diagnostics
6911 #endif
6912         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6913          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6914          + x(10)*yy*zz
6915         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6916          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6917          + x(20)*yy*zz
6918         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6919          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6920          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6921          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6922          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6923          +x(40)*xx*yy*zz
6924         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6925          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6926          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6927          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6928          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6929          +x(60)*xx*yy*zz
6930         dsc_i   = 0.743d0+x(61)
6931         dp2_i   = 1.9d0+x(62)
6932         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6933                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6934         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6935                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6936         s1=(1+x(63))/(0.1d0 + dscp1)
6937         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6938         s2=(1+x(65))/(0.1d0 + dscp2)
6939         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6940         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6941       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6942 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6943 !     &   sumene4,
6944 !     &   dscp1,dscp2,sumene
6945 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6946         escloc = escloc + sumene
6947 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6948 !     & ,zz,xx,yy
6949 !#define DEBUG
6950 #ifdef DEBUG
6951 !
6952 ! This section to check the numerical derivatives of the energy of ith side
6953 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6954 ! #define DEBUG in the code to turn it on.
6955 !
6956         write (2,*) "sumene               =",sumene
6957         aincr=1.0d-7
6958         xxsave=xx
6959         xx=xx+aincr
6960         write (2,*) xx,yy,zz
6961         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6962         de_dxx_num=(sumenep-sumene)/aincr
6963         xx=xxsave
6964         write (2,*) "xx+ sumene from enesc=",sumenep
6965         yysave=yy
6966         yy=yy+aincr
6967         write (2,*) xx,yy,zz
6968         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6969         de_dyy_num=(sumenep-sumene)/aincr
6970         yy=yysave
6971         write (2,*) "yy+ sumene from enesc=",sumenep
6972         zzsave=zz
6973         zz=zz+aincr
6974         write (2,*) xx,yy,zz
6975         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6976         de_dzz_num=(sumenep-sumene)/aincr
6977         zz=zzsave
6978         write (2,*) "zz+ sumene from enesc=",sumenep
6979         costsave=cost2tab(i+1)
6980         sintsave=sint2tab(i+1)
6981         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6982         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6983         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6984         de_dt_num=(sumenep-sumene)/aincr
6985         write (2,*) " t+ sumene from enesc=",sumenep
6986         cost2tab(i+1)=costsave
6987         sint2tab(i+1)=sintsave
6988 ! End of diagnostics section.
6989 #endif
6990 !
6991 ! Compute the gradient of esc
6992 !
6993 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6994         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6995         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6996         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6997         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6998         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6999         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7000         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7001         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7002         pom1=(sumene3*sint2tab(i+1)+sumene1) &
7003            *(pom_s1/dscp1+pom_s16*dscp1**4)
7004         pom2=(sumene4*cost2tab(i+1)+sumene2) &
7005            *(pom_s2/dscp2+pom_s26*dscp2**4)
7006         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7007         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7008         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7009         +x(40)*yy*zz
7010         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7011         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7012         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7013         +x(60)*yy*zz
7014         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7015               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7016               +(pom1+pom2)*pom_dx
7017 #ifdef DEBUG
7018         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7019 #endif
7020 !
7021         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7022         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7023         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7024         +x(40)*xx*zz
7025         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7026         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7027         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7028         +x(59)*zz**2 +x(60)*xx*zz
7029         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7030               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7031               +(pom1-pom2)*pom_dy
7032 #ifdef DEBUG
7033         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7034 #endif
7035 !
7036         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7037         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7038         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7039         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7040         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7041         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7042         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7043         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7044 #ifdef DEBUG
7045         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7046 #endif
7047 !
7048         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7049         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7050         +pom1*pom_dt1+pom2*pom_dt2
7051 #ifdef DEBUG
7052         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7053 #endif
7054 !
7055 !
7056        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7057        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7058        cosfac2xx=cosfac2*xx
7059        sinfac2yy=sinfac2*yy
7060        do k = 1,3
7061          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7062             vbld_inv(i+1)
7063          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7064             vbld_inv(i)
7065          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7066          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7067 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7068 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7069 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7070 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7071          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7072          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7073          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7074          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7075          dZZ_Ci1(k)=0.0d0
7076          dZZ_Ci(k)=0.0d0
7077          do j=1,3
7078            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7079            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7080            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7081            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7082          enddo
7083
7084          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7085          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7086          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7087          (z_prime(k)-zz*dC_norm(k,i+nres))
7088 !
7089          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7090          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7091        enddo
7092
7093        do k=1,3
7094          dXX_Ctab(k,i)=dXX_Ci(k)
7095          dXX_C1tab(k,i)=dXX_Ci1(k)
7096          dYY_Ctab(k,i)=dYY_Ci(k)
7097          dYY_C1tab(k,i)=dYY_Ci1(k)
7098          dZZ_Ctab(k,i)=dZZ_Ci(k)
7099          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7100          dXX_XYZtab(k,i)=dXX_XYZ(k)
7101          dYY_XYZtab(k,i)=dYY_XYZ(k)
7102          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7103        enddo
7104
7105        do k = 1,3
7106 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7107 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7108 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7109 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7110 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7111 !     &    dt_dci(k)
7112 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7113 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7114          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7115           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7116          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7117           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7118          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7119           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7120        enddo
7121 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7122 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7123
7124 ! to check gradient call subroutine check_grad
7125
7126     1 continue
7127       enddo
7128       return
7129       end subroutine esc
7130 !-----------------------------------------------------------------------------
7131       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7132 !      implicit none
7133       real(kind=8),dimension(65) :: x
7134       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7135         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7136
7137       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7138         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7139         + x(10)*yy*zz
7140       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7141         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7142         + x(20)*yy*zz
7143       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7144         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7145         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7146         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7147         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7148         +x(40)*xx*yy*zz
7149       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7150         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7151         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7152         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7153         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7154         +x(60)*xx*yy*zz
7155       dsc_i   = 0.743d0+x(61)
7156       dp2_i   = 1.9d0+x(62)
7157       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7158                 *(xx*cost2+yy*sint2))
7159       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7160                 *(xx*cost2-yy*sint2))
7161       s1=(1+x(63))/(0.1d0 + dscp1)
7162       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7163       s2=(1+x(65))/(0.1d0 + dscp2)
7164       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7165       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7166        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7167       enesc=sumene
7168       return
7169       end function enesc
7170 #endif
7171 !-----------------------------------------------------------------------------
7172       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7173 !
7174 ! This procedure calculates two-body contact function g(rij) and its derivative:
7175 !
7176 !           eps0ij                                     !       x < -1
7177 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7178 !            0                                         !       x > 1
7179 !
7180 ! where x=(rij-r0ij)/delta
7181 !
7182 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7183 !
7184 !      implicit none
7185       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7186       real(kind=8) :: x,x2,x4,delta
7187 !     delta=0.02D0*r0ij
7188 !      delta=0.2D0*r0ij
7189       x=(rij-r0ij)/delta
7190       if (x.lt.-1.0D0) then
7191         fcont=eps0ij
7192         fprimcont=0.0D0
7193       else if (x.le.1.0D0) then
7194         x2=x*x
7195         x4=x2*x2
7196         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7197         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7198       else
7199         fcont=0.0D0
7200         fprimcont=0.0D0
7201       endif
7202       return
7203       end subroutine gcont
7204 !-----------------------------------------------------------------------------
7205       subroutine splinthet(theti,delta,ss,ssder)
7206 !      implicit real*8 (a-h,o-z)
7207 !      include 'DIMENSIONS'
7208 !      include 'COMMON.VAR'
7209 !      include 'COMMON.GEO'
7210       real(kind=8) :: theti,delta,ss,ssder
7211       real(kind=8) :: thetup,thetlow
7212       thetup=pi-delta
7213       thetlow=delta
7214       if (theti.gt.pipol) then
7215         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7216       else
7217         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7218         ssder=-ssder
7219       endif
7220       return
7221       end subroutine splinthet
7222 !-----------------------------------------------------------------------------
7223       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7224 !      implicit none
7225       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7226       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7227       a1=fprim0*delta/(f1-f0)
7228       a2=3.0d0-2.0d0*a1
7229       a3=a1-2.0d0
7230       ksi=(x-x0)/delta
7231       ksi2=ksi*ksi
7232       ksi3=ksi2*ksi
7233       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7234       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7235       return
7236       end subroutine spline1
7237 !-----------------------------------------------------------------------------
7238       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7239 !      implicit none
7240       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7241       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7242       ksi=(x-x0)/delta
7243       ksi2=ksi*ksi
7244       ksi3=ksi2*ksi
7245       a1=fprim0x*delta
7246       a2=3*(f1x-f0x)-2*fprim0x*delta
7247       a3=fprim0x*delta-2*(f1x-f0x)
7248       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7249       return
7250       end subroutine spline2
7251 !-----------------------------------------------------------------------------
7252 #ifdef CRYST_TOR
7253 !-----------------------------------------------------------------------------
7254       subroutine etor(etors,edihcnstr)
7255 !      implicit real*8 (a-h,o-z)
7256 !      include 'DIMENSIONS'
7257 !      include 'COMMON.VAR'
7258 !      include 'COMMON.GEO'
7259 !      include 'COMMON.LOCAL'
7260 !      include 'COMMON.TORSION'
7261 !      include 'COMMON.INTERACT'
7262 !      include 'COMMON.DERIV'
7263 !      include 'COMMON.CHAIN'
7264 !      include 'COMMON.NAMES'
7265 !      include 'COMMON.IOUNITS'
7266 !      include 'COMMON.FFIELD'
7267 !      include 'COMMON.TORCNSTR'
7268 !      include 'COMMON.CONTROL'
7269       real(kind=8) :: etors,edihcnstr
7270       logical :: lprn
7271 !el local variables
7272       integer :: i,j,
7273       real(kind=8) :: phii,fac,etors_ii
7274
7275 ! Set lprn=.true. for debugging
7276       lprn=.false.
7277 !      lprn=.true.
7278       etors=0.0D0
7279       do i=iphi_start,iphi_end
7280       etors_ii=0.0D0
7281         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7282             .or. itype(i,1).eq.ntyp1) cycle
7283         itori=itortyp(itype(i-2,1))
7284         itori1=itortyp(itype(i-1,1))
7285         phii=phi(i)
7286         gloci=0.0D0
7287 ! Proline-Proline pair is a special case...
7288         if (itori.eq.3 .and. itori1.eq.3) then
7289           if (phii.gt.-dwapi3) then
7290             cosphi=dcos(3*phii)
7291             fac=1.0D0/(1.0D0-cosphi)
7292             etorsi=v1(1,3,3)*fac
7293             etorsi=etorsi+etorsi
7294             etors=etors+etorsi-v1(1,3,3)
7295             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7296             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7297           endif
7298           do j=1,3
7299             v1ij=v1(j+1,itori,itori1)
7300             v2ij=v2(j+1,itori,itori1)
7301             cosphi=dcos(j*phii)
7302             sinphi=dsin(j*phii)
7303             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7304             if (energy_dec) etors_ii=etors_ii+ &
7305                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7306             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7307           enddo
7308         else
7309           do j=1,nterm_old
7310             v1ij=v1(j,itori,itori1)
7311             v2ij=v2(j,itori,itori1)
7312             cosphi=dcos(j*phii)
7313             sinphi=dsin(j*phii)
7314             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7315             if (energy_dec) etors_ii=etors_ii+ &
7316                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7317             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7318           enddo
7319         endif
7320         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7321              'etor',i,etors_ii
7322         if (lprn) &
7323         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7324         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7325         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7326         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7327 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7328       enddo
7329 ! 6/20/98 - dihedral angle constraints
7330       edihcnstr=0.0d0
7331       do i=1,ndih_constr
7332         itori=idih_constr(i)
7333         phii=phi(itori)
7334         difi=phii-phi0(i)
7335         if (difi.gt.drange(i)) then
7336           difi=difi-drange(i)
7337           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7338           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7339         else if (difi.lt.-drange(i)) then
7340           difi=difi+drange(i)
7341           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7342           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7343         endif
7344 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7345 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7346       enddo
7347 !      write (iout,*) 'edihcnstr',edihcnstr
7348       return
7349       end subroutine etor
7350 !-----------------------------------------------------------------------------
7351       subroutine etor_d(etors_d)
7352       real(kind=8) :: etors_d
7353       etors_d=0.0d0
7354       return
7355       end subroutine etor_d
7356 #else
7357 !-----------------------------------------------------------------------------
7358       subroutine etor(etors)
7359 !      implicit real*8 (a-h,o-z)
7360 !      include 'DIMENSIONS'
7361 !      include 'COMMON.VAR'
7362 !      include 'COMMON.GEO'
7363 !      include 'COMMON.LOCAL'
7364 !      include 'COMMON.TORSION'
7365 !      include 'COMMON.INTERACT'
7366 !      include 'COMMON.DERIV'
7367 !      include 'COMMON.CHAIN'
7368 !      include 'COMMON.NAMES'
7369 !      include 'COMMON.IOUNITS'
7370 !      include 'COMMON.FFIELD'
7371 !      include 'COMMON.TORCNSTR'
7372 !      include 'COMMON.CONTROL'
7373       real(kind=8) :: etors,edihcnstr
7374       logical :: lprn
7375 !el local variables
7376       integer :: i,j,iblock,itori,itori1
7377       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7378                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7379 ! Set lprn=.true. for debugging
7380       lprn=.false.
7381 !     lprn=.true.
7382       etors=0.0D0
7383       do i=iphi_start,iphi_end
7384         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7385              .or. itype(i-3,1).eq.ntyp1 &
7386              .or. itype(i,1).eq.ntyp1) cycle
7387         etors_ii=0.0D0
7388          if (iabs(itype(i,1)).eq.20) then
7389          iblock=2
7390          else
7391          iblock=1
7392          endif
7393         itori=itortyp(itype(i-2,1))
7394         itori1=itortyp(itype(i-1,1))
7395         phii=phi(i)
7396         gloci=0.0D0
7397 ! Regular cosine and sine terms
7398         do j=1,nterm(itori,itori1,iblock)
7399           v1ij=v1(j,itori,itori1,iblock)
7400           v2ij=v2(j,itori,itori1,iblock)
7401           cosphi=dcos(j*phii)
7402           sinphi=dsin(j*phii)
7403           etors=etors+v1ij*cosphi+v2ij*sinphi
7404           if (energy_dec) etors_ii=etors_ii+ &
7405                      v1ij*cosphi+v2ij*sinphi
7406           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7407         enddo
7408 ! Lorentz terms
7409 !                         v1
7410 !  E = SUM ----------------------------------- - v1
7411 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7412 !
7413         cosphi=dcos(0.5d0*phii)
7414         sinphi=dsin(0.5d0*phii)
7415         do j=1,nlor(itori,itori1,iblock)
7416           vl1ij=vlor1(j,itori,itori1)
7417           vl2ij=vlor2(j,itori,itori1)
7418           vl3ij=vlor3(j,itori,itori1)
7419           pom=vl2ij*cosphi+vl3ij*sinphi
7420           pom1=1.0d0/(pom*pom+1.0d0)
7421           etors=etors+vl1ij*pom1
7422           if (energy_dec) etors_ii=etors_ii+ &
7423                      vl1ij*pom1
7424           pom=-pom*pom1*pom1
7425           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7426         enddo
7427 ! Subtract the constant term
7428         etors=etors-v0(itori,itori1,iblock)
7429           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7430                'etor',i,etors_ii-v0(itori,itori1,iblock)
7431         if (lprn) &
7432         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7433         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7434         (v1(j,itori,itori1,iblock),j=1,6),&
7435         (v2(j,itori,itori1,iblock),j=1,6)
7436         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7437 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7438       enddo
7439 ! 6/20/98 - dihedral angle constraints
7440       return
7441       end subroutine etor
7442 !C The rigorous attempt to derive energy function
7443 !-------------------------------------------------------------------------------------------
7444       subroutine etor_kcc(etors)
7445       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7446       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7447        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7448        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7449        gradvalst2,etori
7450       logical lprn
7451       integer :: i,j,itori,itori1,nval,k,l
7452
7453       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7454       etors=0.0D0
7455       do i=iphi_start,iphi_end
7456 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7457 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7458 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7459 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7460         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7461            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7462         itori=itortyp(itype(i-2,1))
7463         itori1=itortyp(itype(i-1,1))
7464         phii=phi(i)
7465         glocig=0.0D0
7466         glocit1=0.0d0
7467         glocit2=0.0d0
7468 !C to avoid multiple devision by 2
7469 !c        theti22=0.5d0*theta(i)
7470 !C theta 12 is the theta_1 /2
7471 !C theta 22 is theta_2 /2
7472 !c        theti12=0.5d0*theta(i-1)
7473 !C and appropriate sinus function
7474         sinthet1=dsin(theta(i-1))
7475         sinthet2=dsin(theta(i))
7476         costhet1=dcos(theta(i-1))
7477         costhet2=dcos(theta(i))
7478 !C to speed up lets store its mutliplication
7479         sint1t2=sinthet2*sinthet1
7480         sint1t2n=1.0d0
7481 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7482 !C +d_n*sin(n*gamma)) *
7483 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7484 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7485         nval=nterm_kcc_Tb(itori,itori1)
7486         c1(0)=0.0d0
7487         c2(0)=0.0d0
7488         c1(1)=1.0d0
7489         c2(1)=1.0d0
7490         do j=2,nval
7491           c1(j)=c1(j-1)*costhet1
7492           c2(j)=c2(j-1)*costhet2
7493         enddo
7494         etori=0.0d0
7495
7496        do j=1,nterm_kcc(itori,itori1)
7497           cosphi=dcos(j*phii)
7498           sinphi=dsin(j*phii)
7499           sint1t2n1=sint1t2n
7500           sint1t2n=sint1t2n*sint1t2
7501           sumvalc=0.0d0
7502           gradvalct1=0.0d0
7503           gradvalct2=0.0d0
7504           do k=1,nval
7505             do l=1,nval
7506               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7507               gradvalct1=gradvalct1+ &
7508                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7509               gradvalct2=gradvalct2+ &
7510                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7511             enddo
7512           enddo
7513           gradvalct1=-gradvalct1*sinthet1
7514           gradvalct2=-gradvalct2*sinthet2
7515           sumvals=0.0d0
7516           gradvalst1=0.0d0
7517           gradvalst2=0.0d0
7518           do k=1,nval
7519             do l=1,nval
7520               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7521               gradvalst1=gradvalst1+ &
7522                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7523               gradvalst2=gradvalst2+ &
7524                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7525             enddo
7526           enddo
7527           gradvalst1=-gradvalst1*sinthet1
7528           gradvalst2=-gradvalst2*sinthet2
7529           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7530           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7531 !C glocig is the gradient local i site in gamma
7532           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7533 !C now gradient over theta_1
7534          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7535         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7536          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7537         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7538         enddo ! j
7539         etors=etors+etori
7540         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7541 !C derivative over theta1
7542         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7543 !C now derivative over theta2
7544         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7545         if (lprn) then
7546          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7547             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7548           write (iout,*) "c1",(c1(k),k=0,nval), &
7549          " c2",(c2(k),k=0,nval)
7550         endif
7551       enddo
7552       return
7553        end  subroutine etor_kcc
7554 !------------------------------------------------------------------------------
7555
7556         subroutine etor_constr(edihcnstr)
7557       real(kind=8) :: etors,edihcnstr
7558       logical :: lprn
7559 !el local variables
7560       integer :: i,j,iblock,itori,itori1
7561       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7562                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7563                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7564
7565       if (raw_psipred) then
7566         do i=idihconstr_start,idihconstr_end
7567           itori=idih_constr(i)
7568           phii=phi(itori)
7569           gaudih_i=vpsipred(1,i)
7570           gauder_i=0.0d0
7571           do j=1,2
7572             s = sdihed(j,i)
7573             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7574             dexpcos_i=dexp(-cos_i*cos_i)
7575             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7576           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7577                  *cos_i*dexpcos_i/s**2
7578           enddo
7579           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7580           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7581           if (energy_dec) &
7582           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7583           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7584           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7585           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7586           -wdihc*dlog(gaudih_i)
7587         enddo
7588       else
7589
7590       do i=idihconstr_start,idihconstr_end
7591         itori=idih_constr(i)
7592         phii=phi(itori)
7593         difi=pinorm(phii-phi0(i))
7594         if (difi.gt.drange(i)) then
7595           difi=difi-drange(i)
7596           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7597           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7598         else if (difi.lt.-drange(i)) then
7599           difi=difi+drange(i)
7600           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7601           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7602         else
7603           difi=0.0
7604         endif
7605       enddo
7606
7607       endif
7608
7609       return
7610
7611       end subroutine etor_constr
7612 !-----------------------------------------------------------------------------
7613       subroutine etor_d(etors_d)
7614 ! 6/23/01 Compute double torsional energy
7615 !      implicit real*8 (a-h,o-z)
7616 !      include 'DIMENSIONS'
7617 !      include 'COMMON.VAR'
7618 !      include 'COMMON.GEO'
7619 !      include 'COMMON.LOCAL'
7620 !      include 'COMMON.TORSION'
7621 !      include 'COMMON.INTERACT'
7622 !      include 'COMMON.DERIV'
7623 !      include 'COMMON.CHAIN'
7624 !      include 'COMMON.NAMES'
7625 !      include 'COMMON.IOUNITS'
7626 !      include 'COMMON.FFIELD'
7627 !      include 'COMMON.TORCNSTR'
7628       real(kind=8) :: etors_d,etors_d_ii
7629       logical :: lprn
7630 !el local variables
7631       integer :: i,j,k,l,itori,itori1,itori2,iblock
7632       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7633                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7634                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7635                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7636 ! Set lprn=.true. for debugging
7637       lprn=.false.
7638 !     lprn=.true.
7639       etors_d=0.0D0
7640 !      write(iout,*) "a tu??"
7641       do i=iphid_start,iphid_end
7642         etors_d_ii=0.0D0
7643         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7644             .or. itype(i-3,1).eq.ntyp1 &
7645             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7646         itori=itortyp(itype(i-2,1))
7647         itori1=itortyp(itype(i-1,1))
7648         itori2=itortyp(itype(i,1))
7649         phii=phi(i)
7650         phii1=phi(i+1)
7651         gloci1=0.0D0
7652         gloci2=0.0D0
7653         iblock=1
7654         if (iabs(itype(i+1,1)).eq.20) iblock=2
7655
7656 ! Regular cosine and sine terms
7657         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7658           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7659           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7660           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7661           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7662           cosphi1=dcos(j*phii)
7663           sinphi1=dsin(j*phii)
7664           cosphi2=dcos(j*phii1)
7665           sinphi2=dsin(j*phii1)
7666           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7667            v2cij*cosphi2+v2sij*sinphi2
7668           if (energy_dec) etors_d_ii=etors_d_ii+ &
7669            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7670           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7671           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7672         enddo
7673         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7674           do l=1,k-1
7675             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7676             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7677             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7678             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7679             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7680             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7681             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7682             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7683             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7684               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7685             if (energy_dec) etors_d_ii=etors_d_ii+ &
7686               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7687               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7688             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7689               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7690             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7691               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7692           enddo
7693         enddo
7694         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7695                             'etor_d',i,etors_d_ii
7696         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7697         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7698       enddo
7699       return
7700       end subroutine etor_d
7701 #endif
7702
7703       subroutine ebend_kcc(etheta)
7704       logical lprn
7705       double precision thybt1(maxang_kcc),etheta
7706       integer :: i,iti,j,ihelp
7707       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7708 !C Set lprn=.true. for debugging
7709       lprn=energy_dec
7710 !c     lprn=.true.
7711 !C      print *,"wchodze kcc"
7712       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7713       etheta=0.0D0
7714       do i=ithet_start,ithet_end
7715 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7716         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7717        .or.itype(i,1).eq.ntyp1) cycle
7718         iti=iabs(itortyp(itype(i-1,1)))
7719         sinthet=dsin(theta(i))
7720         costhet=dcos(theta(i))
7721         do j=1,nbend_kcc_Tb(iti)
7722           thybt1(j)=v1bend_chyb(j,iti)
7723         enddo
7724         sumth1thyb=v1bend_chyb(0,iti)+ &
7725          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7726         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7727          sumth1thyb
7728         ihelp=nbend_kcc_Tb(iti)-1
7729         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7730         etheta=etheta+sumth1thyb
7731 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7732         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7733       enddo
7734       return
7735       end subroutine ebend_kcc
7736 !c------------
7737 !c-------------------------------------------------------------------------------------
7738       subroutine etheta_constr(ethetacnstr)
7739       real (kind=8) :: ethetacnstr,thetiii,difi
7740       integer :: i,itheta
7741       ethetacnstr=0.0d0
7742 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7743       do i=ithetaconstr_start,ithetaconstr_end
7744         itheta=itheta_constr(i)
7745         thetiii=theta(itheta)
7746         difi=pinorm(thetiii-theta_constr0(i))
7747         if (difi.gt.theta_drange(i)) then
7748           difi=difi-theta_drange(i)
7749           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7750           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7751          +for_thet_constr(i)*difi**3
7752         else if (difi.lt.-drange(i)) then
7753           difi=difi+drange(i)
7754           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7755           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7756           +for_thet_constr(i)*difi**3
7757         else
7758           difi=0.0
7759         endif
7760        if (energy_dec) then
7761         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7762          i,itheta,rad2deg*thetiii,&
7763          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7764          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7765          gloc(itheta+nphi-2,icg)
7766         endif
7767       enddo
7768       return
7769       end subroutine etheta_constr
7770
7771 !-----------------------------------------------------------------------------
7772       subroutine eback_sc_corr(esccor)
7773 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7774 !        conformational states; temporarily implemented as differences
7775 !        between UNRES torsional potentials (dependent on three types of
7776 !        residues) and the torsional potentials dependent on all 20 types
7777 !        of residues computed from AM1  energy surfaces of terminally-blocked
7778 !        amino-acid residues.
7779 !      implicit real*8 (a-h,o-z)
7780 !      include 'DIMENSIONS'
7781 !      include 'COMMON.VAR'
7782 !      include 'COMMON.GEO'
7783 !      include 'COMMON.LOCAL'
7784 !      include 'COMMON.TORSION'
7785 !      include 'COMMON.SCCOR'
7786 !      include 'COMMON.INTERACT'
7787 !      include 'COMMON.DERIV'
7788 !      include 'COMMON.CHAIN'
7789 !      include 'COMMON.NAMES'
7790 !      include 'COMMON.IOUNITS'
7791 !      include 'COMMON.FFIELD'
7792 !      include 'COMMON.CONTROL'
7793       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7794                    cosphi,sinphi
7795       logical :: lprn
7796       integer :: i,interty,j,isccori,isccori1,intertyp
7797 ! Set lprn=.true. for debugging
7798       lprn=.false.
7799 !      lprn=.true.
7800 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7801       esccor=0.0D0
7802       do i=itau_start,itau_end
7803         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7804         esccor_ii=0.0D0
7805         isccori=isccortyp(itype(i-2,1))
7806         isccori1=isccortyp(itype(i-1,1))
7807
7808 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7809         phii=phi(i)
7810         do intertyp=1,3 !intertyp
7811          esccor_ii=0.0D0
7812 !c Added 09 May 2012 (Adasko)
7813 !c  Intertyp means interaction type of backbone mainchain correlation:
7814 !   1 = SC...Ca...Ca...Ca
7815 !   2 = Ca...Ca...Ca...SC
7816 !   3 = SC...Ca...Ca...SCi
7817         gloci=0.0D0
7818         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7819             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7820             (itype(i-1,1).eq.ntyp1))) &
7821           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7822            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7823            .or.(itype(i,1).eq.ntyp1))) &
7824           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7825             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7826             (itype(i-3,1).eq.ntyp1)))) cycle
7827         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7828         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7829        cycle
7830        do j=1,nterm_sccor(isccori,isccori1)
7831           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7832           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7833           cosphi=dcos(j*tauangle(intertyp,i))
7834           sinphi=dsin(j*tauangle(intertyp,i))
7835           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7836           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7837           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7838         enddo
7839         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7840                                 'esccor',i,intertyp,esccor_ii
7841 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7842         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7843         if (lprn) &
7844         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7845         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7846         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7847         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7848         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7849        enddo !intertyp
7850       enddo
7851
7852       return
7853       end subroutine eback_sc_corr
7854 !-----------------------------------------------------------------------------
7855       subroutine multibody(ecorr)
7856 ! This subroutine calculates multi-body contributions to energy following
7857 ! the idea of Skolnick et al. If side chains I and J make a contact and
7858 ! at the same time side chains I+1 and J+1 make a contact, an extra
7859 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7860 !      implicit real*8 (a-h,o-z)
7861 !      include 'DIMENSIONS'
7862 !      include 'COMMON.IOUNITS'
7863 !      include 'COMMON.DERIV'
7864 !      include 'COMMON.INTERACT'
7865 !      include 'COMMON.CONTACTS'
7866       real(kind=8),dimension(3) :: gx,gx1
7867       logical :: lprn
7868       real(kind=8) :: ecorr
7869       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7870 ! Set lprn=.true. for debugging
7871       lprn=.false.
7872
7873       if (lprn) then
7874         write (iout,'(a)') 'Contact function values:'
7875         do i=nnt,nct-2
7876           write (iout,'(i2,20(1x,i2,f10.5))') &
7877               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7878         enddo
7879       endif
7880       ecorr=0.0D0
7881
7882 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7883 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7884       do i=nnt,nct
7885         do j=1,3
7886           gradcorr(j,i)=0.0D0
7887           gradxorr(j,i)=0.0D0
7888         enddo
7889       enddo
7890       do i=nnt,nct-2
7891
7892         DO ISHIFT = 3,4
7893
7894         i1=i+ishift
7895         num_conti=num_cont(i)
7896         num_conti1=num_cont(i1)
7897         do jj=1,num_conti
7898           j=jcont(jj,i)
7899           do kk=1,num_conti1
7900             j1=jcont(kk,i1)
7901             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7902 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7903 !d   &                   ' ishift=',ishift
7904 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7905 ! The system gains extra energy.
7906               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7907             endif   ! j1==j+-ishift
7908           enddo     ! kk
7909         enddo       ! jj
7910
7911         ENDDO ! ISHIFT
7912
7913       enddo         ! i
7914       return
7915       end subroutine multibody
7916 !-----------------------------------------------------------------------------
7917       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7918 !      implicit real*8 (a-h,o-z)
7919 !      include 'DIMENSIONS'
7920 !      include 'COMMON.IOUNITS'
7921 !      include 'COMMON.DERIV'
7922 !      include 'COMMON.INTERACT'
7923 !      include 'COMMON.CONTACTS'
7924       real(kind=8),dimension(3) :: gx,gx1
7925       logical :: lprn
7926       integer :: i,j,k,l,jj,kk,m,ll
7927       real(kind=8) :: eij,ekl
7928       lprn=.false.
7929       eij=facont(jj,i)
7930       ekl=facont(kk,k)
7931 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7932 ! Calculate the multi-body contribution to energy.
7933 ! Calculate multi-body contributions to the gradient.
7934 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7935 !d   & k,l,(gacont(m,kk,k),m=1,3)
7936       do m=1,3
7937         gx(m) =ekl*gacont(m,jj,i)
7938         gx1(m)=eij*gacont(m,kk,k)
7939         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7940         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7941         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7942         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7943       enddo
7944       do m=i,j-1
7945         do ll=1,3
7946           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7947         enddo
7948       enddo
7949       do m=k,l-1
7950         do ll=1,3
7951           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7952         enddo
7953       enddo
7954       esccorr=-eij*ekl
7955       return
7956       end function esccorr
7957 !-----------------------------------------------------------------------------
7958       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7959 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7960 !      implicit real*8 (a-h,o-z)
7961 !      include 'DIMENSIONS'
7962 !      include 'COMMON.IOUNITS'
7963 #ifdef MPI
7964       include "mpif.h"
7965 !      integer :: maxconts !max_cont=maxconts  =nres/4
7966       integer,parameter :: max_dim=26
7967       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7968       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7969 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7970 !el      common /przechowalnia/ zapas
7971       integer :: status(MPI_STATUS_SIZE)
7972       integer,dimension((nres/4)*2) :: req !maxconts*2
7973       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7974 #endif
7975 !      include 'COMMON.SETUP'
7976 !      include 'COMMON.FFIELD'
7977 !      include 'COMMON.DERIV'
7978 !      include 'COMMON.INTERACT'
7979 !      include 'COMMON.CONTACTS'
7980 !      include 'COMMON.CONTROL'
7981 !      include 'COMMON.LOCAL'
7982       real(kind=8),dimension(3) :: gx,gx1
7983       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7984       logical :: lprn,ldone
7985 !el local variables
7986       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7987               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7988
7989 ! Set lprn=.true. for debugging
7990       lprn=.false.
7991 #ifdef MPI
7992 !      maxconts=nres/4
7993       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7994       n_corr=0
7995       n_corr1=0
7996       if (nfgtasks.le.1) goto 30
7997       if (lprn) then
7998         write (iout,'(a)') 'Contact function values before RECEIVE:'
7999         do i=nnt,nct-2
8000           write (iout,'(2i3,50(1x,i2,f5.2))') &
8001           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8002           j=1,num_cont_hb(i))
8003         enddo
8004       endif
8005       call flush(iout)
8006       do i=1,ntask_cont_from
8007         ncont_recv(i)=0
8008       enddo
8009       do i=1,ntask_cont_to
8010         ncont_sent(i)=0
8011       enddo
8012 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8013 !     & ntask_cont_to
8014 ! Make the list of contacts to send to send to other procesors
8015 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8016 !      call flush(iout)
8017       do i=iturn3_start,iturn3_end
8018 !        write (iout,*) "make contact list turn3",i," num_cont",
8019 !     &    num_cont_hb(i)
8020         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8021       enddo
8022       do i=iturn4_start,iturn4_end
8023 !        write (iout,*) "make contact list turn4",i," num_cont",
8024 !     &   num_cont_hb(i)
8025         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8026       enddo
8027       do ii=1,nat_sent
8028         i=iat_sent(ii)
8029 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8030 !     &    num_cont_hb(i)
8031         do j=1,num_cont_hb(i)
8032         do k=1,4
8033           jjc=jcont_hb(j,i)
8034           iproc=iint_sent_local(k,jjc,ii)
8035 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8036           if (iproc.gt.0) then
8037             ncont_sent(iproc)=ncont_sent(iproc)+1
8038             nn=ncont_sent(iproc)
8039             zapas(1,nn,iproc)=i
8040             zapas(2,nn,iproc)=jjc
8041             zapas(3,nn,iproc)=facont_hb(j,i)
8042             zapas(4,nn,iproc)=ees0p(j,i)
8043             zapas(5,nn,iproc)=ees0m(j,i)
8044             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8045             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8046             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8047             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8048             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8049             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8050             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8051             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8052             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8053             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8054             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8055             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8056             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8057             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8058             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8059             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8060             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8061             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8062             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8063             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8064             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8065           endif
8066         enddo
8067         enddo
8068       enddo
8069       if (lprn) then
8070       write (iout,*) &
8071         "Numbers of contacts to be sent to other processors",&
8072         (ncont_sent(i),i=1,ntask_cont_to)
8073       write (iout,*) "Contacts sent"
8074       do ii=1,ntask_cont_to
8075         nn=ncont_sent(ii)
8076         iproc=itask_cont_to(ii)
8077         write (iout,*) nn," contacts to processor",iproc,&
8078          " of CONT_TO_COMM group"
8079         do i=1,nn
8080           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8081         enddo
8082       enddo
8083       call flush(iout)
8084       endif
8085       CorrelType=477
8086       CorrelID=fg_rank+1
8087       CorrelType1=478
8088       CorrelID1=nfgtasks+fg_rank+1
8089       ireq=0
8090 ! Receive the numbers of needed contacts from other processors
8091       do ii=1,ntask_cont_from
8092         iproc=itask_cont_from(ii)
8093         ireq=ireq+1
8094         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8095           FG_COMM,req(ireq),IERR)
8096       enddo
8097 !      write (iout,*) "IRECV ended"
8098 !      call flush(iout)
8099 ! Send the number of contacts needed by other processors
8100       do ii=1,ntask_cont_to
8101         iproc=itask_cont_to(ii)
8102         ireq=ireq+1
8103         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8104           FG_COMM,req(ireq),IERR)
8105       enddo
8106 !      write (iout,*) "ISEND ended"
8107 !      write (iout,*) "number of requests (nn)",ireq
8108       call flush(iout)
8109       if (ireq.gt.0) &
8110         call MPI_Waitall(ireq,req,status_array,ierr)
8111 !      write (iout,*)
8112 !     &  "Numbers of contacts to be received from other processors",
8113 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8114 !      call flush(iout)
8115 ! Receive contacts
8116       ireq=0
8117       do ii=1,ntask_cont_from
8118         iproc=itask_cont_from(ii)
8119         nn=ncont_recv(ii)
8120 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8121 !     &   " of CONT_TO_COMM group"
8122         call flush(iout)
8123         if (nn.gt.0) then
8124           ireq=ireq+1
8125           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8126           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8127 !          write (iout,*) "ireq,req",ireq,req(ireq)
8128         endif
8129       enddo
8130 ! Send the contacts to processors that need them
8131       do ii=1,ntask_cont_to
8132         iproc=itask_cont_to(ii)
8133         nn=ncont_sent(ii)
8134 !        write (iout,*) nn," contacts to processor",iproc,
8135 !     &   " of CONT_TO_COMM group"
8136         if (nn.gt.0) then
8137           ireq=ireq+1
8138           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8139             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8140 !          write (iout,*) "ireq,req",ireq,req(ireq)
8141 !          do i=1,nn
8142 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8143 !          enddo
8144         endif
8145       enddo
8146 !      write (iout,*) "number of requests (contacts)",ireq
8147 !      write (iout,*) "req",(req(i),i=1,4)
8148 !      call flush(iout)
8149       if (ireq.gt.0) &
8150        call MPI_Waitall(ireq,req,status_array,ierr)
8151       do iii=1,ntask_cont_from
8152         iproc=itask_cont_from(iii)
8153         nn=ncont_recv(iii)
8154         if (lprn) then
8155         write (iout,*) "Received",nn," contacts from processor",iproc,&
8156          " of CONT_FROM_COMM group"
8157         call flush(iout)
8158         do i=1,nn
8159           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8160         enddo
8161         call flush(iout)
8162         endif
8163         do i=1,nn
8164           ii=zapas_recv(1,i,iii)
8165 ! Flag the received contacts to prevent double-counting
8166           jj=-zapas_recv(2,i,iii)
8167 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8168 !          call flush(iout)
8169           nnn=num_cont_hb(ii)+1
8170           num_cont_hb(ii)=nnn
8171           jcont_hb(nnn,ii)=jj
8172           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8173           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8174           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8175           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8176           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8177           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8178           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8179           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8180           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8181           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8182           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8183           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8184           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8185           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8186           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8187           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8188           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8189           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8190           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8191           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8192           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8193           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8194           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8195           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8196         enddo
8197       enddo
8198       call flush(iout)
8199       if (lprn) then
8200         write (iout,'(a)') 'Contact function values after receive:'
8201         do i=nnt,nct-2
8202           write (iout,'(2i3,50(1x,i3,f5.2))') &
8203           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8204           j=1,num_cont_hb(i))
8205         enddo
8206         call flush(iout)
8207       endif
8208    30 continue
8209 #endif
8210       if (lprn) then
8211         write (iout,'(a)') 'Contact function values:'
8212         do i=nnt,nct-2
8213           write (iout,'(2i3,50(1x,i3,f5.2))') &
8214           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8215           j=1,num_cont_hb(i))
8216         enddo
8217       endif
8218       ecorr=0.0D0
8219
8220 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8221 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8222 ! Remove the loop below after debugging !!!
8223       do i=nnt,nct
8224         do j=1,3
8225           gradcorr(j,i)=0.0D0
8226           gradxorr(j,i)=0.0D0
8227         enddo
8228       enddo
8229 ! Calculate the local-electrostatic correlation terms
8230       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8231         i1=i+1
8232         num_conti=num_cont_hb(i)
8233         num_conti1=num_cont_hb(i+1)
8234         do jj=1,num_conti
8235           j=jcont_hb(jj,i)
8236           jp=iabs(j)
8237           do kk=1,num_conti1
8238             j1=jcont_hb(kk,i1)
8239             jp1=iabs(j1)
8240 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8241 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8242             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8243                 .or. j.lt.0 .and. j1.gt.0) .and. &
8244                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8245 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8246 ! The system gains extra energy.
8247               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8248               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8249                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8250               n_corr=n_corr+1
8251             else if (j1.eq.j) then
8252 ! Contacts I-J and I-(J+1) occur simultaneously.
8253 ! The system loses extra energy.
8254 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8255             endif
8256           enddo ! kk
8257           do kk=1,num_conti
8258             j1=jcont_hb(kk,i)
8259 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8260 !    &         ' jj=',jj,' kk=',kk
8261             if (j1.eq.j+1) then
8262 ! Contacts I-J and (I+1)-J occur simultaneously.
8263 ! The system loses extra energy.
8264 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8265             endif ! j1==j+1
8266           enddo ! kk
8267         enddo ! jj
8268       enddo ! i
8269       return
8270       end subroutine multibody_hb
8271 !-----------------------------------------------------------------------------
8272       subroutine add_hb_contact(ii,jj,itask)
8273 !      implicit real*8 (a-h,o-z)
8274 !      include "DIMENSIONS"
8275 !      include "COMMON.IOUNITS"
8276 !      include "COMMON.CONTACTS"
8277 !      integer,parameter :: maxconts=nres/4
8278       integer,parameter :: max_dim=26
8279       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8280 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8281 !      common /przechowalnia/ zapas
8282       integer :: i,j,ii,jj,iproc,nn,jjc
8283       integer,dimension(4) :: itask
8284 !      write (iout,*) "itask",itask
8285       do i=1,2
8286         iproc=itask(i)
8287         if (iproc.gt.0) then
8288           do j=1,num_cont_hb(ii)
8289             jjc=jcont_hb(j,ii)
8290 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8291             if (jjc.eq.jj) then
8292               ncont_sent(iproc)=ncont_sent(iproc)+1
8293               nn=ncont_sent(iproc)
8294               zapas(1,nn,iproc)=ii
8295               zapas(2,nn,iproc)=jjc
8296               zapas(3,nn,iproc)=facont_hb(j,ii)
8297               zapas(4,nn,iproc)=ees0p(j,ii)
8298               zapas(5,nn,iproc)=ees0m(j,ii)
8299               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8300               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8301               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8302               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8303               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8304               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8305               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8306               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8307               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8308               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8309               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8310               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8311               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8312               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8313               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8314               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8315               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8316               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8317               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8318               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8319               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8320               exit
8321             endif
8322           enddo
8323         endif
8324       enddo
8325       return
8326       end subroutine add_hb_contact
8327 !-----------------------------------------------------------------------------
8328       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8329 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8330 !      implicit real*8 (a-h,o-z)
8331 !      include 'DIMENSIONS'
8332 !      include 'COMMON.IOUNITS'
8333       integer,parameter :: max_dim=70
8334 #ifdef MPI
8335       include "mpif.h"
8336 !      integer :: maxconts !max_cont=maxconts=nres/4
8337       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8338       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8339 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8340 !      common /przechowalnia/ zapas
8341       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8342         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8343         ierr,iii,nnn
8344 #endif
8345 !      include 'COMMON.SETUP'
8346 !      include 'COMMON.FFIELD'
8347 !      include 'COMMON.DERIV'
8348 !      include 'COMMON.LOCAL'
8349 !      include 'COMMON.INTERACT'
8350 !      include 'COMMON.CONTACTS'
8351 !      include 'COMMON.CHAIN'
8352 !      include 'COMMON.CONTROL'
8353       real(kind=8),dimension(3) :: gx,gx1
8354       integer,dimension(nres) :: num_cont_hb_old
8355       logical :: lprn,ldone
8356 !EL      double precision eello4,eello5,eelo6,eello_turn6
8357 !EL      external eello4,eello5,eello6,eello_turn6
8358 !el local variables
8359       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8360               j1,jp1,i1,num_conti1
8361       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8362       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8363
8364 ! Set lprn=.true. for debugging
8365       lprn=.false.
8366       eturn6=0.0d0
8367 #ifdef MPI
8368 !      maxconts=nres/4
8369       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8370       do i=1,nres
8371         num_cont_hb_old(i)=num_cont_hb(i)
8372       enddo
8373       n_corr=0
8374       n_corr1=0
8375       if (nfgtasks.le.1) goto 30
8376       if (lprn) then
8377         write (iout,'(a)') 'Contact function values before RECEIVE:'
8378         do i=nnt,nct-2
8379           write (iout,'(2i3,50(1x,i2,f5.2))') &
8380           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8381           j=1,num_cont_hb(i))
8382         enddo
8383       endif
8384       call flush(iout)
8385       do i=1,ntask_cont_from
8386         ncont_recv(i)=0
8387       enddo
8388       do i=1,ntask_cont_to
8389         ncont_sent(i)=0
8390       enddo
8391 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8392 !     & ntask_cont_to
8393 ! Make the list of contacts to send to send to other procesors
8394       do i=iturn3_start,iturn3_end
8395 !        write (iout,*) "make contact list turn3",i," num_cont",
8396 !     &    num_cont_hb(i)
8397         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8398       enddo
8399       do i=iturn4_start,iturn4_end
8400 !        write (iout,*) "make contact list turn4",i," num_cont",
8401 !     &   num_cont_hb(i)
8402         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8403       enddo
8404       do ii=1,nat_sent
8405         i=iat_sent(ii)
8406 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8407 !     &    num_cont_hb(i)
8408         do j=1,num_cont_hb(i)
8409         do k=1,4
8410           jjc=jcont_hb(j,i)
8411           iproc=iint_sent_local(k,jjc,ii)
8412 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8413           if (iproc.ne.0) then
8414             ncont_sent(iproc)=ncont_sent(iproc)+1
8415             nn=ncont_sent(iproc)
8416             zapas(1,nn,iproc)=i
8417             zapas(2,nn,iproc)=jjc
8418             zapas(3,nn,iproc)=d_cont(j,i)
8419             ind=3
8420             do kk=1,3
8421               ind=ind+1
8422               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8423             enddo
8424             do kk=1,2
8425               do ll=1,2
8426                 ind=ind+1
8427                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8428               enddo
8429             enddo
8430             do jj=1,5
8431               do kk=1,3
8432                 do ll=1,2
8433                   do mm=1,2
8434                     ind=ind+1
8435                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8436                   enddo
8437                 enddo
8438               enddo
8439             enddo
8440           endif
8441         enddo
8442         enddo
8443       enddo
8444       if (lprn) then
8445       write (iout,*) &
8446         "Numbers of contacts to be sent to other processors",&
8447         (ncont_sent(i),i=1,ntask_cont_to)
8448       write (iout,*) "Contacts sent"
8449       do ii=1,ntask_cont_to
8450         nn=ncont_sent(ii)
8451         iproc=itask_cont_to(ii)
8452         write (iout,*) nn," contacts to processor",iproc,&
8453          " of CONT_TO_COMM group"
8454         do i=1,nn
8455           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8456         enddo
8457       enddo
8458       call flush(iout)
8459       endif
8460       CorrelType=477
8461       CorrelID=fg_rank+1
8462       CorrelType1=478
8463       CorrelID1=nfgtasks+fg_rank+1
8464       ireq=0
8465 ! Receive the numbers of needed contacts from other processors
8466       do ii=1,ntask_cont_from
8467         iproc=itask_cont_from(ii)
8468         ireq=ireq+1
8469         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8470           FG_COMM,req(ireq),IERR)
8471       enddo
8472 !      write (iout,*) "IRECV ended"
8473 !      call flush(iout)
8474 ! Send the number of contacts needed by other processors
8475       do ii=1,ntask_cont_to
8476         iproc=itask_cont_to(ii)
8477         ireq=ireq+1
8478         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8479           FG_COMM,req(ireq),IERR)
8480       enddo
8481 !      write (iout,*) "ISEND ended"
8482 !      write (iout,*) "number of requests (nn)",ireq
8483       call flush(iout)
8484       if (ireq.gt.0) &
8485         call MPI_Waitall(ireq,req,status_array,ierr)
8486 !      write (iout,*)
8487 !     &  "Numbers of contacts to be received from other processors",
8488 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8489 !      call flush(iout)
8490 ! Receive contacts
8491       ireq=0
8492       do ii=1,ntask_cont_from
8493         iproc=itask_cont_from(ii)
8494         nn=ncont_recv(ii)
8495 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8496 !     &   " of CONT_TO_COMM group"
8497         call flush(iout)
8498         if (nn.gt.0) then
8499           ireq=ireq+1
8500           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8501           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8502 !          write (iout,*) "ireq,req",ireq,req(ireq)
8503         endif
8504       enddo
8505 ! Send the contacts to processors that need them
8506       do ii=1,ntask_cont_to
8507         iproc=itask_cont_to(ii)
8508         nn=ncont_sent(ii)
8509 !        write (iout,*) nn," contacts to processor",iproc,
8510 !     &   " of CONT_TO_COMM group"
8511         if (nn.gt.0) then
8512           ireq=ireq+1
8513           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8514             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8515 !          write (iout,*) "ireq,req",ireq,req(ireq)
8516 !          do i=1,nn
8517 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8518 !          enddo
8519         endif
8520       enddo
8521 !      write (iout,*) "number of requests (contacts)",ireq
8522 !      write (iout,*) "req",(req(i),i=1,4)
8523 !      call flush(iout)
8524       if (ireq.gt.0) &
8525        call MPI_Waitall(ireq,req,status_array,ierr)
8526       do iii=1,ntask_cont_from
8527         iproc=itask_cont_from(iii)
8528         nn=ncont_recv(iii)
8529         if (lprn) then
8530         write (iout,*) "Received",nn," contacts from processor",iproc,&
8531          " of CONT_FROM_COMM group"
8532         call flush(iout)
8533         do i=1,nn
8534           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8535         enddo
8536         call flush(iout)
8537         endif
8538         do i=1,nn
8539           ii=zapas_recv(1,i,iii)
8540 ! Flag the received contacts to prevent double-counting
8541           jj=-zapas_recv(2,i,iii)
8542 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8543 !          call flush(iout)
8544           nnn=num_cont_hb(ii)+1
8545           num_cont_hb(ii)=nnn
8546           jcont_hb(nnn,ii)=jj
8547           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8548           ind=3
8549           do kk=1,3
8550             ind=ind+1
8551             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8552           enddo
8553           do kk=1,2
8554             do ll=1,2
8555               ind=ind+1
8556               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8557             enddo
8558           enddo
8559           do jj=1,5
8560             do kk=1,3
8561               do ll=1,2
8562                 do mm=1,2
8563                   ind=ind+1
8564                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8565                 enddo
8566               enddo
8567             enddo
8568           enddo
8569         enddo
8570       enddo
8571       call flush(iout)
8572       if (lprn) then
8573         write (iout,'(a)') 'Contact function values after receive:'
8574         do i=nnt,nct-2
8575           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8576           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8577           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8578         enddo
8579         call flush(iout)
8580       endif
8581    30 continue
8582 #endif
8583       if (lprn) then
8584         write (iout,'(a)') 'Contact function values:'
8585         do i=nnt,nct-2
8586           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8587           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8588           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8589         enddo
8590       endif
8591       ecorr=0.0D0
8592       ecorr5=0.0d0
8593       ecorr6=0.0d0
8594
8595 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8596 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8597 ! Remove the loop below after debugging !!!
8598       do i=nnt,nct
8599         do j=1,3
8600           gradcorr(j,i)=0.0D0
8601           gradxorr(j,i)=0.0D0
8602         enddo
8603       enddo
8604 ! Calculate the dipole-dipole interaction energies
8605       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8606       do i=iatel_s,iatel_e+1
8607         num_conti=num_cont_hb(i)
8608         do jj=1,num_conti
8609           j=jcont_hb(jj,i)
8610 #ifdef MOMENT
8611           call dipole(i,j,jj)
8612 #endif
8613         enddo
8614       enddo
8615       endif
8616 ! Calculate the local-electrostatic correlation terms
8617 !                write (iout,*) "gradcorr5 in eello5 before loop"
8618 !                do iii=1,nres
8619 !                  write (iout,'(i5,3f10.5)')
8620 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8621 !                enddo
8622       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8623 !        write (iout,*) "corr loop i",i
8624         i1=i+1
8625         num_conti=num_cont_hb(i)
8626         num_conti1=num_cont_hb(i+1)
8627         do jj=1,num_conti
8628           j=jcont_hb(jj,i)
8629           jp=iabs(j)
8630           do kk=1,num_conti1
8631             j1=jcont_hb(kk,i1)
8632             jp1=iabs(j1)
8633 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8634 !     &         ' jj=',jj,' kk=',kk
8635 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8636             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8637                 .or. j.lt.0 .and. j1.gt.0) .and. &
8638                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8639 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8640 ! The system gains extra energy.
8641               n_corr=n_corr+1
8642               sqd1=dsqrt(d_cont(jj,i))
8643               sqd2=dsqrt(d_cont(kk,i1))
8644               sred_geom = sqd1*sqd2
8645               IF (sred_geom.lt.cutoff_corr) THEN
8646                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8647                   ekont,fprimcont)
8648 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8649 !d     &         ' jj=',jj,' kk=',kk
8650                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8651                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8652                 do l=1,3
8653                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8654                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8655                 enddo
8656                 n_corr1=n_corr1+1
8657 !d               write (iout,*) 'sred_geom=',sred_geom,
8658 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8659 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8660 !d               write (iout,*) "g_contij",g_contij
8661 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8662 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8663                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8664                 if (wcorr4.gt.0.0d0) &
8665                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8666                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8667                        write (iout,'(a6,4i5,0pf7.3)') &
8668                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8669 !                write (iout,*) "gradcorr5 before eello5"
8670 !                do iii=1,nres
8671 !                  write (iout,'(i5,3f10.5)')
8672 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8673 !                enddo
8674                 if (wcorr5.gt.0.0d0) &
8675                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8676 !                write (iout,*) "gradcorr5 after eello5"
8677 !                do iii=1,nres
8678 !                  write (iout,'(i5,3f10.5)')
8679 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8680 !                enddo
8681                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8682                        write (iout,'(a6,4i5,0pf7.3)') &
8683                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8684 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8685 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8686                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8687                      .or. wturn6.eq.0.0d0))then
8688 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8689                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8690                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8691                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8692 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8693 !d     &            'ecorr6=',ecorr6
8694 !d                write (iout,'(4e15.5)') sred_geom,
8695 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8696 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8697 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8698                 else if (wturn6.gt.0.0d0 &
8699                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8700 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8701                   eturn6=eturn6+eello_turn6(i,jj,kk)
8702                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8703                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8704 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8705                 endif
8706               ENDIF
8707 1111          continue
8708             endif
8709           enddo ! kk
8710         enddo ! jj
8711       enddo ! i
8712       do i=1,nres
8713         num_cont_hb(i)=num_cont_hb_old(i)
8714       enddo
8715 !                write (iout,*) "gradcorr5 in eello5"
8716 !                do iii=1,nres
8717 !                  write (iout,'(i5,3f10.5)')
8718 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8719 !                enddo
8720       return
8721       end subroutine multibody_eello
8722 !-----------------------------------------------------------------------------
8723       subroutine add_hb_contact_eello(ii,jj,itask)
8724 !      implicit real*8 (a-h,o-z)
8725 !      include "DIMENSIONS"
8726 !      include "COMMON.IOUNITS"
8727 !      include "COMMON.CONTACTS"
8728 !      integer,parameter :: maxconts=nres/4
8729       integer,parameter :: max_dim=70
8730       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8731 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8732 !      common /przechowalnia/ zapas
8733
8734       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8735       integer,dimension(4) ::itask
8736 !      write (iout,*) "itask",itask
8737       do i=1,2
8738         iproc=itask(i)
8739         if (iproc.gt.0) then
8740           do j=1,num_cont_hb(ii)
8741             jjc=jcont_hb(j,ii)
8742 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8743             if (jjc.eq.jj) then
8744               ncont_sent(iproc)=ncont_sent(iproc)+1
8745               nn=ncont_sent(iproc)
8746               zapas(1,nn,iproc)=ii
8747               zapas(2,nn,iproc)=jjc
8748               zapas(3,nn,iproc)=d_cont(j,ii)
8749               ind=3
8750               do kk=1,3
8751                 ind=ind+1
8752                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8753               enddo
8754               do kk=1,2
8755                 do ll=1,2
8756                   ind=ind+1
8757                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8758                 enddo
8759               enddo
8760               do jj=1,5
8761                 do kk=1,3
8762                   do ll=1,2
8763                     do mm=1,2
8764                       ind=ind+1
8765                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8766                     enddo
8767                   enddo
8768                 enddo
8769               enddo
8770               exit
8771             endif
8772           enddo
8773         endif
8774       enddo
8775       return
8776       end subroutine add_hb_contact_eello
8777 !-----------------------------------------------------------------------------
8778       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8779 !      implicit real*8 (a-h,o-z)
8780 !      include 'DIMENSIONS'
8781 !      include 'COMMON.IOUNITS'
8782 !      include 'COMMON.DERIV'
8783 !      include 'COMMON.INTERACT'
8784 !      include 'COMMON.CONTACTS'
8785       real(kind=8),dimension(3) :: gx,gx1
8786       logical :: lprn
8787 !el local variables
8788       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8789       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8790                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8791                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8792                    rlocshield
8793
8794       lprn=.false.
8795       eij=facont_hb(jj,i)
8796       ekl=facont_hb(kk,k)
8797       ees0pij=ees0p(jj,i)
8798       ees0pkl=ees0p(kk,k)
8799       ees0mij=ees0m(jj,i)
8800       ees0mkl=ees0m(kk,k)
8801       ekont=eij*ekl
8802       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8803 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8804 ! Following 4 lines for diagnostics.
8805 !d    ees0pkl=0.0D0
8806 !d    ees0pij=1.0D0
8807 !d    ees0mkl=0.0D0
8808 !d    ees0mij=1.0D0
8809 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8810 !     & 'Contacts ',i,j,
8811 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8812 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8813 !     & 'gradcorr_long'
8814 ! Calculate the multi-body contribution to energy.
8815 !      ecorr=ecorr+ekont*ees
8816 ! Calculate multi-body contributions to the gradient.
8817       coeffpees0pij=coeffp*ees0pij
8818       coeffmees0mij=coeffm*ees0mij
8819       coeffpees0pkl=coeffp*ees0pkl
8820       coeffmees0mkl=coeffm*ees0mkl
8821       do ll=1,3
8822 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8823         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8824         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8825         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8826         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8827         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8828         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8829 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8830         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8831         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8832         coeffmees0mij*gacontm_hb1(ll,kk,k))
8833         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8834         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8835         coeffmees0mij*gacontm_hb2(ll,kk,k))
8836         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8837            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8838            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8839         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8840         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8841         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8842            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8843            coeffmees0mij*gacontm_hb3(ll,kk,k))
8844         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8845         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8846 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8847       enddo
8848 !      write (iout,*)
8849 !grad      do m=i+1,j-1
8850 !grad        do ll=1,3
8851 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8852 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8853 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8854 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8855 !grad        enddo
8856 !grad      enddo
8857 !grad      do m=k+1,l-1
8858 !grad        do ll=1,3
8859 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8860 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8861 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8862 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8863 !grad        enddo
8864 !grad      enddo
8865 !      write (iout,*) "ehbcorr",ekont*ees
8866       ehbcorr=ekont*ees
8867       if (shield_mode.gt.0) then
8868        j=ees0plist(jj,i)
8869        l=ees0plist(kk,k)
8870 !C        print *,i,j,fac_shield(i),fac_shield(j),
8871 !C     &fac_shield(k),fac_shield(l)
8872         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8873            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8874           do ilist=1,ishield_list(i)
8875            iresshield=shield_list(ilist,i)
8876            do m=1,3
8877            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8878            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8879                    rlocshield  &
8880             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8881             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8882             +rlocshield
8883            enddo
8884           enddo
8885           do ilist=1,ishield_list(j)
8886            iresshield=shield_list(ilist,j)
8887            do m=1,3
8888            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8889            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8890                    rlocshield &
8891             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8892            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8893             +rlocshield
8894            enddo
8895           enddo
8896
8897           do ilist=1,ishield_list(k)
8898            iresshield=shield_list(ilist,k)
8899            do m=1,3
8900            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8901            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8902                    rlocshield &
8903             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8904            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8905             +rlocshield
8906            enddo
8907           enddo
8908           do ilist=1,ishield_list(l)
8909            iresshield=shield_list(ilist,l)
8910            do m=1,3
8911            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8912            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8913                    rlocshield &
8914             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8915            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8916             +rlocshield
8917            enddo
8918           enddo
8919           do m=1,3
8920             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8921                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8922             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8923                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8924             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8925                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8926             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8927                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8928
8929             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8930                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8931             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8932                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8933             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8934                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8935             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8936                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8937
8938            enddo
8939       endif
8940       endif
8941       return
8942       end function ehbcorr
8943 #ifdef MOMENT
8944 !-----------------------------------------------------------------------------
8945       subroutine dipole(i,j,jj)
8946 !      implicit real*8 (a-h,o-z)
8947 !      include 'DIMENSIONS'
8948 !      include 'COMMON.IOUNITS'
8949 !      include 'COMMON.CHAIN'
8950 !      include 'COMMON.FFIELD'
8951 !      include 'COMMON.DERIV'
8952 !      include 'COMMON.INTERACT'
8953 !      include 'COMMON.CONTACTS'
8954 !      include 'COMMON.TORSION'
8955 !      include 'COMMON.VAR'
8956 !      include 'COMMON.GEO'
8957       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8958       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8959       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8960
8961       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8962       allocate(dipderx(3,5,4,maxconts,nres))
8963 !
8964
8965       iti1 = itortyp(itype(i+1,1))
8966       if (j.lt.nres-1) then
8967         itj1 = itype2loc(itype(j+1,1))
8968       else
8969         itj1=nloctyp
8970       endif
8971       do iii=1,2
8972         dipi(iii,1)=Ub2(iii,i)
8973         dipderi(iii)=Ub2der(iii,i)
8974         dipi(iii,2)=b1(iii,iti1)
8975         dipj(iii,1)=Ub2(iii,j)
8976         dipderj(iii)=Ub2der(iii,j)
8977         dipj(iii,2)=b1(iii,itj1)
8978       enddo
8979       kkk=0
8980       do iii=1,2
8981         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8982         do jjj=1,2
8983           kkk=kkk+1
8984           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8985         enddo
8986       enddo
8987       do kkk=1,5
8988         do lll=1,3
8989           mmm=0
8990           do iii=1,2
8991             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8992               auxvec(1))
8993             do jjj=1,2
8994               mmm=mmm+1
8995               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8996             enddo
8997           enddo
8998         enddo
8999       enddo
9000       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9001       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9002       do iii=1,2
9003         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9004       enddo
9005       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9006       do iii=1,2
9007         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9008       enddo
9009       return
9010       end subroutine dipole
9011 #endif
9012 !-----------------------------------------------------------------------------
9013       subroutine calc_eello(i,j,k,l,jj,kk)
9014 !
9015 ! This subroutine computes matrices and vectors needed to calculate
9016 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9017 !
9018       use comm_kut
9019 !      implicit real*8 (a-h,o-z)
9020 !      include 'DIMENSIONS'
9021 !      include 'COMMON.IOUNITS'
9022 !      include 'COMMON.CHAIN'
9023 !      include 'COMMON.DERIV'
9024 !      include 'COMMON.INTERACT'
9025 !      include 'COMMON.CONTACTS'
9026 !      include 'COMMON.TORSION'
9027 !      include 'COMMON.VAR'
9028 !      include 'COMMON.GEO'
9029 !      include 'COMMON.FFIELD'
9030       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9031       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9032       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9033               itj1
9034 !el      logical :: lprn
9035 !el      common /kutas/ lprn
9036 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9037 !d     & ' jj=',jj,' kk=',kk
9038 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9039 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9040 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9041       do iii=1,2
9042         do jjj=1,2
9043           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9044           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9045         enddo
9046       enddo
9047       call transpose2(aa1(1,1),aa1t(1,1))
9048       call transpose2(aa2(1,1),aa2t(1,1))
9049       do kkk=1,5
9050         do lll=1,3
9051           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9052             aa1tder(1,1,lll,kkk))
9053           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9054             aa2tder(1,1,lll,kkk))
9055         enddo
9056       enddo
9057       if (l.eq.j+1) then
9058 ! parallel orientation of the two CA-CA-CA frames.
9059         if (i.gt.1) then
9060           iti=itortyp(itype(i,1))
9061         else
9062           iti=ntortyp+1
9063         endif
9064         itk1=itortyp(itype(k+1,1))
9065         itj=itortyp(itype(j,1))
9066         if (l.lt.nres-1) then
9067           itl1=itortyp(itype(l+1,1))
9068         else
9069           itl1=ntortyp+1
9070         endif
9071 ! A1 kernel(j+1) A2T
9072 !d        do iii=1,2
9073 !d          write (iout,'(3f10.5,5x,3f10.5)')
9074 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9075 !d        enddo
9076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9077          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9078          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9079 ! Following matrices are needed only for 6-th order cumulants
9080         IF (wcorr6.gt.0.0d0) THEN
9081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9082          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9083          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9084         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9085          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9086          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9087          ADtEAderx(1,1,1,1,1,1))
9088         lprn=.false.
9089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9090          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9091          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9092          ADtEA1derx(1,1,1,1,1,1))
9093         ENDIF
9094 ! End 6-th order cumulants
9095 !d        lprn=.false.
9096 !d        if (lprn) then
9097 !d        write (2,*) 'In calc_eello6'
9098 !d        do iii=1,2
9099 !d          write (2,*) 'iii=',iii
9100 !d          do kkk=1,5
9101 !d            write (2,*) 'kkk=',kkk
9102 !d            do jjj=1,2
9103 !d              write (2,'(3(2f10.5),5x)')
9104 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9105 !d            enddo
9106 !d          enddo
9107 !d        enddo
9108 !d        endif
9109         call transpose2(EUgder(1,1,k),auxmat(1,1))
9110         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9111         call transpose2(EUg(1,1,k),auxmat(1,1))
9112         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9113         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9114         do iii=1,2
9115           do kkk=1,5
9116             do lll=1,3
9117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9118                 EAEAderx(1,1,lll,kkk,iii,1))
9119             enddo
9120           enddo
9121         enddo
9122 ! A1T kernel(i+1) A2
9123         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9124          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9125          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9126 ! Following matrices are needed only for 6-th order cumulants
9127         IF (wcorr6.gt.0.0d0) THEN
9128         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9129          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9130          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9131         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9132          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9133          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9134          ADtEAderx(1,1,1,1,1,2))
9135         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9136          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9137          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9138          ADtEA1derx(1,1,1,1,1,2))
9139         ENDIF
9140 ! End 6-th order cumulants
9141         call transpose2(EUgder(1,1,l),auxmat(1,1))
9142         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9143         call transpose2(EUg(1,1,l),auxmat(1,1))
9144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9146         do iii=1,2
9147           do kkk=1,5
9148             do lll=1,3
9149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9150                 EAEAderx(1,1,lll,kkk,iii,2))
9151             enddo
9152           enddo
9153         enddo
9154 ! AEAb1 and AEAb2
9155 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9156 ! They are needed only when the fifth- or the sixth-order cumulants are
9157 ! indluded.
9158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9159         call transpose2(AEA(1,1,1),auxmat(1,1))
9160         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9161         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9162         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9163         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9164         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9165         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9166         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9167         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9168         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9169         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9170         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9171         call transpose2(AEA(1,1,2),auxmat(1,1))
9172         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9173         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9174         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9175         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9176         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9177         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9178         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9179         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9180         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9181         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9182         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9183 ! Calculate the Cartesian derivatives of the vectors.
9184         do iii=1,2
9185           do kkk=1,5
9186             do lll=1,3
9187               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9188               call matvec2(auxmat(1,1),b1(1,iti),&
9189                 AEAb1derx(1,lll,kkk,iii,1,1))
9190               call matvec2(auxmat(1,1),Ub2(1,i),&
9191                 AEAb2derx(1,lll,kkk,iii,1,1))
9192               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9193                 AEAb1derx(1,lll,kkk,iii,2,1))
9194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9195                 AEAb2derx(1,lll,kkk,iii,2,1))
9196               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9197               call matvec2(auxmat(1,1),b1(1,itj),&
9198                 AEAb1derx(1,lll,kkk,iii,1,2))
9199               call matvec2(auxmat(1,1),Ub2(1,j),&
9200                 AEAb2derx(1,lll,kkk,iii,1,2))
9201               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9202                 AEAb1derx(1,lll,kkk,iii,2,2))
9203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9204                 AEAb2derx(1,lll,kkk,iii,2,2))
9205             enddo
9206           enddo
9207         enddo
9208         ENDIF
9209 ! End vectors
9210       else
9211 ! Antiparallel orientation of the two CA-CA-CA frames.
9212         if (i.gt.1) then
9213           iti=itortyp(itype(i,1))
9214         else
9215           iti=ntortyp+1
9216         endif
9217         itk1=itortyp(itype(k+1,1))
9218         itl=itortyp(itype(l,1))
9219         itj=itortyp(itype(j,1))
9220         if (j.lt.nres-1) then
9221           itj1=itortyp(itype(j+1,1))
9222         else
9223           itj1=ntortyp+1
9224         endif
9225 ! A2 kernel(j-1)T A1T
9226         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9227          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9228          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9229 ! Following matrices are needed only for 6-th order cumulants
9230         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9231            j.eq.i+4 .and. l.eq.i+3)) THEN
9232         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9233          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9234          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9235         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9236          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9237          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9238          ADtEAderx(1,1,1,1,1,1))
9239         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9240          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9241          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9242          ADtEA1derx(1,1,1,1,1,1))
9243         ENDIF
9244 ! End 6-th order cumulants
9245         call transpose2(EUgder(1,1,k),auxmat(1,1))
9246         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9247         call transpose2(EUg(1,1,k),auxmat(1,1))
9248         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9249         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9250         do iii=1,2
9251           do kkk=1,5
9252             do lll=1,3
9253               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9254                 EAEAderx(1,1,lll,kkk,iii,1))
9255             enddo
9256           enddo
9257         enddo
9258 ! A2T kernel(i+1)T A1
9259         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9260          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9261          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9262 ! Following matrices are needed only for 6-th order cumulants
9263         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9264            j.eq.i+4 .and. l.eq.i+3)) THEN
9265         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9266          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9267          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9268         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9269          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9270          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9271          ADtEAderx(1,1,1,1,1,2))
9272         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9273          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9274          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9275          ADtEA1derx(1,1,1,1,1,2))
9276         ENDIF
9277 ! End 6-th order cumulants
9278         call transpose2(EUgder(1,1,j),auxmat(1,1))
9279         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9280         call transpose2(EUg(1,1,j),auxmat(1,1))
9281         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9282         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9283         do iii=1,2
9284           do kkk=1,5
9285             do lll=1,3
9286               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9287                 EAEAderx(1,1,lll,kkk,iii,2))
9288             enddo
9289           enddo
9290         enddo
9291 ! AEAb1 and AEAb2
9292 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9293 ! They are needed only when the fifth- or the sixth-order cumulants are
9294 ! indluded.
9295         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9296           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9297         call transpose2(AEA(1,1,1),auxmat(1,1))
9298         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9299         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9300         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9301         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9302         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9303         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9304         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9305         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9306         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9307         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9308         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9309         call transpose2(AEA(1,1,2),auxmat(1,1))
9310         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9311         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9312         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9313         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9314         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9315         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9316         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9317         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9318         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9319         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9320         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9321 ! Calculate the Cartesian derivatives of the vectors.
9322         do iii=1,2
9323           do kkk=1,5
9324             do lll=1,3
9325               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9326               call matvec2(auxmat(1,1),b1(1,iti),&
9327                 AEAb1derx(1,lll,kkk,iii,1,1))
9328               call matvec2(auxmat(1,1),Ub2(1,i),&
9329                 AEAb2derx(1,lll,kkk,iii,1,1))
9330               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9331                 AEAb1derx(1,lll,kkk,iii,2,1))
9332               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9333                 AEAb2derx(1,lll,kkk,iii,2,1))
9334               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9335               call matvec2(auxmat(1,1),b1(1,itl),&
9336                 AEAb1derx(1,lll,kkk,iii,1,2))
9337               call matvec2(auxmat(1,1),Ub2(1,l),&
9338                 AEAb2derx(1,lll,kkk,iii,1,2))
9339               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9340                 AEAb1derx(1,lll,kkk,iii,2,2))
9341               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9342                 AEAb2derx(1,lll,kkk,iii,2,2))
9343             enddo
9344           enddo
9345         enddo
9346         ENDIF
9347 ! End vectors
9348       endif
9349       return
9350       end subroutine calc_eello
9351 !-----------------------------------------------------------------------------
9352       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9353       use comm_kut
9354       implicit none
9355       integer :: nderg
9356       logical :: transp
9357       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9358       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9359       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9360       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9361       integer :: iii,kkk,lll
9362       integer :: jjj,mmm
9363 !el      logical :: lprn
9364 !el      common /kutas/ lprn
9365       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9366       do iii=1,nderg
9367         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9368           AKAderg(1,1,iii))
9369       enddo
9370 !d      if (lprn) write (2,*) 'In kernel'
9371       do kkk=1,5
9372 !d        if (lprn) write (2,*) 'kkk=',kkk
9373         do lll=1,3
9374           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9375             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9376 !d          if (lprn) then
9377 !d            write (2,*) 'lll=',lll
9378 !d            write (2,*) 'iii=1'
9379 !d            do jjj=1,2
9380 !d              write (2,'(3(2f10.5),5x)')
9381 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9382 !d            enddo
9383 !d          endif
9384           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9385             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9386 !d          if (lprn) then
9387 !d            write (2,*) 'lll=',lll
9388 !d            write (2,*) 'iii=2'
9389 !d            do jjj=1,2
9390 !d              write (2,'(3(2f10.5),5x)')
9391 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9392 !d            enddo
9393 !d          endif
9394         enddo
9395       enddo
9396       return
9397       end subroutine kernel
9398 !-----------------------------------------------------------------------------
9399       real(kind=8) function eello4(i,j,k,l,jj,kk)
9400 !      implicit real*8 (a-h,o-z)
9401 !      include 'DIMENSIONS'
9402 !      include 'COMMON.IOUNITS'
9403 !      include 'COMMON.CHAIN'
9404 !      include 'COMMON.DERIV'
9405 !      include 'COMMON.INTERACT'
9406 !      include 'COMMON.CONTACTS'
9407 !      include 'COMMON.TORSION'
9408 !      include 'COMMON.VAR'
9409 !      include 'COMMON.GEO'
9410       real(kind=8),dimension(2,2) :: pizda
9411       real(kind=8),dimension(3) :: ggg1,ggg2
9412       real(kind=8) ::  eel4,glongij,glongkl
9413       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9414 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9415 !d        eello4=0.0d0
9416 !d        return
9417 !d      endif
9418 !d      print *,'eello4:',i,j,k,l,jj,kk
9419 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9420 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9421 !old      eij=facont_hb(jj,i)
9422 !old      ekl=facont_hb(kk,k)
9423 !old      ekont=eij*ekl
9424       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9425 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9426       gcorr_loc(k-1)=gcorr_loc(k-1) &
9427          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9428       if (l.eq.j+1) then
9429         gcorr_loc(l-1)=gcorr_loc(l-1) &
9430            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9431       else
9432         gcorr_loc(j-1)=gcorr_loc(j-1) &
9433            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9434       endif
9435       do iii=1,2
9436         do kkk=1,5
9437           do lll=1,3
9438             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9439                               -EAEAderx(2,2,lll,kkk,iii,1)
9440 !d            derx(lll,kkk,iii)=0.0d0
9441           enddo
9442         enddo
9443       enddo
9444 !d      gcorr_loc(l-1)=0.0d0
9445 !d      gcorr_loc(j-1)=0.0d0
9446 !d      gcorr_loc(k-1)=0.0d0
9447 !d      eel4=1.0d0
9448 !d      write (iout,*)'Contacts have occurred for peptide groups',
9449 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9450 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9451       if (j.lt.nres-1) then
9452         j1=j+1
9453         j2=j-1
9454       else
9455         j1=j-1
9456         j2=j-2
9457       endif
9458       if (l.lt.nres-1) then
9459         l1=l+1
9460         l2=l-1
9461       else
9462         l1=l-1
9463         l2=l-2
9464       endif
9465       do ll=1,3
9466 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9467 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9468         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9469         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9470 !grad        ghalf=0.5d0*ggg1(ll)
9471         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9472         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9473         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9474         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9475         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9476         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9477 !grad        ghalf=0.5d0*ggg2(ll)
9478         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9479         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9480         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9481         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9482         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9483         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9484       enddo
9485 !grad      do m=i+1,j-1
9486 !grad        do ll=1,3
9487 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9488 !grad        enddo
9489 !grad      enddo
9490 !grad      do m=k+1,l-1
9491 !grad        do ll=1,3
9492 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9493 !grad        enddo
9494 !grad      enddo
9495 !grad      do m=i+2,j2
9496 !grad        do ll=1,3
9497 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9498 !grad        enddo
9499 !grad      enddo
9500 !grad      do m=k+2,l2
9501 !grad        do ll=1,3
9502 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9503 !grad        enddo
9504 !grad      enddo
9505 !d      do iii=1,nres-3
9506 !d        write (2,*) iii,gcorr_loc(iii)
9507 !d      enddo
9508       eello4=ekont*eel4
9509 !d      write (2,*) 'ekont',ekont
9510 !d      write (iout,*) 'eello4',ekont*eel4
9511       return
9512       end function eello4
9513 !-----------------------------------------------------------------------------
9514       real(kind=8) function eello5(i,j,k,l,jj,kk)
9515 !      implicit real*8 (a-h,o-z)
9516 !      include 'DIMENSIONS'
9517 !      include 'COMMON.IOUNITS'
9518 !      include 'COMMON.CHAIN'
9519 !      include 'COMMON.DERIV'
9520 !      include 'COMMON.INTERACT'
9521 !      include 'COMMON.CONTACTS'
9522 !      include 'COMMON.TORSION'
9523 !      include 'COMMON.VAR'
9524 !      include 'COMMON.GEO'
9525       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9526       real(kind=8),dimension(2) :: vv
9527       real(kind=8),dimension(3) :: ggg1,ggg2
9528       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9529       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9530       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9531 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9532 !                                                                              C
9533 !                            Parallel chains                                   C
9534 !                                                                              C
9535 !          o             o                   o             o                   C
9536 !         /l\           / \             \   / \           / \   /              C
9537 !        /   \         /   \             \ /   \         /   \ /               C
9538 !       j| o |l1       | o |                o| o |         | o |o                C
9539 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9540 !      \i/   \         /   \ /             /   \         /   \                 C
9541 !       o    k1             o                                                  C
9542 !         (I)          (II)                (III)          (IV)                 C
9543 !                                                                              C
9544 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9545 !                                                                              C
9546 !                            Antiparallel chains                               C
9547 !                                                                              C
9548 !          o             o                   o             o                   C
9549 !         /j\           / \             \   / \           / \   /              C
9550 !        /   \         /   \             \ /   \         /   \ /               C
9551 !      j1| o |l        | o |                o| o |         | o |o                C
9552 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9553 !      \i/   \         /   \ /             /   \         /   \                 C
9554 !       o     k1            o                                                  C
9555 !         (I)          (II)                (III)          (IV)                 C
9556 !                                                                              C
9557 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9558 !                                                                              C
9559 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9560 !                                                                              C
9561 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9562 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9563 !d        eello5=0.0d0
9564 !d        return
9565 !d      endif
9566 !d      write (iout,*)
9567 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9568 !d     &   ' and',k,l
9569       itk=itortyp(itype(k,1))
9570       itl=itortyp(itype(l,1))
9571       itj=itortyp(itype(j,1))
9572       eello5_1=0.0d0
9573       eello5_2=0.0d0
9574       eello5_3=0.0d0
9575       eello5_4=0.0d0
9576 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9577 !d     &   eel5_3_num,eel5_4_num)
9578       do iii=1,2
9579         do kkk=1,5
9580           do lll=1,3
9581             derx(lll,kkk,iii)=0.0d0
9582           enddo
9583         enddo
9584       enddo
9585 !d      eij=facont_hb(jj,i)
9586 !d      ekl=facont_hb(kk,k)
9587 !d      ekont=eij*ekl
9588 !d      write (iout,*)'Contacts have occurred for peptide groups',
9589 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9590 !d      goto 1111
9591 ! Contribution from the graph I.
9592 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9593 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9594       call transpose2(EUg(1,1,k),auxmat(1,1))
9595       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9596       vv(1)=pizda(1,1)-pizda(2,2)
9597       vv(2)=pizda(1,2)+pizda(2,1)
9598       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9599        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9600 ! Explicit gradient in virtual-dihedral angles.
9601       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9602        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9603        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9604       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9605       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9606       vv(1)=pizda(1,1)-pizda(2,2)
9607       vv(2)=pizda(1,2)+pizda(2,1)
9608       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9609        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9610        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9611       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9612       vv(1)=pizda(1,1)-pizda(2,2)
9613       vv(2)=pizda(1,2)+pizda(2,1)
9614       if (l.eq.j+1) then
9615         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9616          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9617          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9618       else
9619         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9620          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9621          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9622       endif
9623 ! Cartesian gradient
9624       do iii=1,2
9625         do kkk=1,5
9626           do lll=1,3
9627             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9628               pizda(1,1))
9629             vv(1)=pizda(1,1)-pizda(2,2)
9630             vv(2)=pizda(1,2)+pizda(2,1)
9631             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9632              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9633              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9634           enddo
9635         enddo
9636       enddo
9637 !      goto 1112
9638 !1111  continue
9639 ! Contribution from graph II
9640       call transpose2(EE(1,1,itk),auxmat(1,1))
9641       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9642       vv(1)=pizda(1,1)+pizda(2,2)
9643       vv(2)=pizda(2,1)-pizda(1,2)
9644       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9645        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9646 ! Explicit gradient in virtual-dihedral angles.
9647       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9648        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9649       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9650       vv(1)=pizda(1,1)+pizda(2,2)
9651       vv(2)=pizda(2,1)-pizda(1,2)
9652       if (l.eq.j+1) then
9653         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9654          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9655          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9656       else
9657         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9658          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9659          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9660       endif
9661 ! Cartesian gradient
9662       do iii=1,2
9663         do kkk=1,5
9664           do lll=1,3
9665             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9666               pizda(1,1))
9667             vv(1)=pizda(1,1)+pizda(2,2)
9668             vv(2)=pizda(2,1)-pizda(1,2)
9669             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9670              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9671              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9672           enddo
9673         enddo
9674       enddo
9675 !d      goto 1112
9676 !d1111  continue
9677       if (l.eq.j+1) then
9678 !d        goto 1110
9679 ! Parallel orientation
9680 ! Contribution from graph III
9681         call transpose2(EUg(1,1,l),auxmat(1,1))
9682         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9683         vv(1)=pizda(1,1)-pizda(2,2)
9684         vv(2)=pizda(1,2)+pizda(2,1)
9685         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9686          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9687 ! Explicit gradient in virtual-dihedral angles.
9688         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9689          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9690          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9691         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9692         vv(1)=pizda(1,1)-pizda(2,2)
9693         vv(2)=pizda(1,2)+pizda(2,1)
9694         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9695          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9696          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9697         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9698         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9699         vv(1)=pizda(1,1)-pizda(2,2)
9700         vv(2)=pizda(1,2)+pizda(2,1)
9701         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9702          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9703          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9704 ! Cartesian gradient
9705         do iii=1,2
9706           do kkk=1,5
9707             do lll=1,3
9708               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9709                 pizda(1,1))
9710               vv(1)=pizda(1,1)-pizda(2,2)
9711               vv(2)=pizda(1,2)+pizda(2,1)
9712               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9713                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9714                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9715             enddo
9716           enddo
9717         enddo
9718 !d        goto 1112
9719 ! Contribution from graph IV
9720 !d1110    continue
9721         call transpose2(EE(1,1,itl),auxmat(1,1))
9722         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9723         vv(1)=pizda(1,1)+pizda(2,2)
9724         vv(2)=pizda(2,1)-pizda(1,2)
9725         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9726          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9727 ! Explicit gradient in virtual-dihedral angles.
9728         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9729          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9730         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9731         vv(1)=pizda(1,1)+pizda(2,2)
9732         vv(2)=pizda(2,1)-pizda(1,2)
9733         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9734          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9735          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9736 ! Cartesian gradient
9737         do iii=1,2
9738           do kkk=1,5
9739             do lll=1,3
9740               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9741                 pizda(1,1))
9742               vv(1)=pizda(1,1)+pizda(2,2)
9743               vv(2)=pizda(2,1)-pizda(1,2)
9744               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9745                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9746                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9747             enddo
9748           enddo
9749         enddo
9750       else
9751 ! Antiparallel orientation
9752 ! Contribution from graph III
9753 !        goto 1110
9754         call transpose2(EUg(1,1,j),auxmat(1,1))
9755         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9756         vv(1)=pizda(1,1)-pizda(2,2)
9757         vv(2)=pizda(1,2)+pizda(2,1)
9758         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9759          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9760 ! Explicit gradient in virtual-dihedral angles.
9761         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9762          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9763          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9764         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9765         vv(1)=pizda(1,1)-pizda(2,2)
9766         vv(2)=pizda(1,2)+pizda(2,1)
9767         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9768          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9769          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9770         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9771         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9772         vv(1)=pizda(1,1)-pizda(2,2)
9773         vv(2)=pizda(1,2)+pizda(2,1)
9774         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9775          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9776          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9777 ! Cartesian gradient
9778         do iii=1,2
9779           do kkk=1,5
9780             do lll=1,3
9781               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9782                 pizda(1,1))
9783               vv(1)=pizda(1,1)-pizda(2,2)
9784               vv(2)=pizda(1,2)+pizda(2,1)
9785               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9786                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9787                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9788             enddo
9789           enddo
9790         enddo
9791 !d        goto 1112
9792 ! Contribution from graph IV
9793 1110    continue
9794         call transpose2(EE(1,1,itj),auxmat(1,1))
9795         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9796         vv(1)=pizda(1,1)+pizda(2,2)
9797         vv(2)=pizda(2,1)-pizda(1,2)
9798         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9799          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9800 ! Explicit gradient in virtual-dihedral angles.
9801         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9802          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9803         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9804         vv(1)=pizda(1,1)+pizda(2,2)
9805         vv(2)=pizda(2,1)-pizda(1,2)
9806         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9807          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9808          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9809 ! Cartesian gradient
9810         do iii=1,2
9811           do kkk=1,5
9812             do lll=1,3
9813               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9814                 pizda(1,1))
9815               vv(1)=pizda(1,1)+pizda(2,2)
9816               vv(2)=pizda(2,1)-pizda(1,2)
9817               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9818                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9819                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9820             enddo
9821           enddo
9822         enddo
9823       endif
9824 1112  continue
9825       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9826 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9827 !d        write (2,*) 'ijkl',i,j,k,l
9828 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9829 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9830 !d      endif
9831 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9832 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9833 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9834 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9835       if (j.lt.nres-1) then
9836         j1=j+1
9837         j2=j-1
9838       else
9839         j1=j-1
9840         j2=j-2
9841       endif
9842       if (l.lt.nres-1) then
9843         l1=l+1
9844         l2=l-1
9845       else
9846         l1=l-1
9847         l2=l-2
9848       endif
9849 !d      eij=1.0d0
9850 !d      ekl=1.0d0
9851 !d      ekont=1.0d0
9852 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9853 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9854 !        summed up outside the subrouine as for the other subroutines
9855 !        handling long-range interactions. The old code is commented out
9856 !        with "cgrad" to keep track of changes.
9857       do ll=1,3
9858 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9859 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9860         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9861         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9862 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9863 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9864 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9865 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9866 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9867 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9868 !     &   gradcorr5ij,
9869 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9870 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9871 !grad        ghalf=0.5d0*ggg1(ll)
9872 !d        ghalf=0.0d0
9873         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9874         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9875         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9876         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9877         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9878         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9879 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9880 !grad        ghalf=0.5d0*ggg2(ll)
9881         ghalf=0.0d0
9882         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9883         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9884         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9885         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9886         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9887         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9888       enddo
9889 !d      goto 1112
9890 !grad      do m=i+1,j-1
9891 !grad        do ll=1,3
9892 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9893 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9894 !grad        enddo
9895 !grad      enddo
9896 !grad      do m=k+1,l-1
9897 !grad        do ll=1,3
9898 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9899 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9900 !grad        enddo
9901 !grad      enddo
9902 !1112  continue
9903 !grad      do m=i+2,j2
9904 !grad        do ll=1,3
9905 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9906 !grad        enddo
9907 !grad      enddo
9908 !grad      do m=k+2,l2
9909 !grad        do ll=1,3
9910 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9911 !grad        enddo
9912 !grad      enddo
9913 !d      do iii=1,nres-3
9914 !d        write (2,*) iii,g_corr5_loc(iii)
9915 !d      enddo
9916       eello5=ekont*eel5
9917 !d      write (2,*) 'ekont',ekont
9918 !d      write (iout,*) 'eello5',ekont*eel5
9919       return
9920       end function eello5
9921 !-----------------------------------------------------------------------------
9922       real(kind=8) function eello6(i,j,k,l,jj,kk)
9923 !      implicit real*8 (a-h,o-z)
9924 !      include 'DIMENSIONS'
9925 !      include 'COMMON.IOUNITS'
9926 !      include 'COMMON.CHAIN'
9927 !      include 'COMMON.DERIV'
9928 !      include 'COMMON.INTERACT'
9929 !      include 'COMMON.CONTACTS'
9930 !      include 'COMMON.TORSION'
9931 !      include 'COMMON.VAR'
9932 !      include 'COMMON.GEO'
9933 !      include 'COMMON.FFIELD'
9934       real(kind=8),dimension(3) :: ggg1,ggg2
9935       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9936                    eello6_6,eel6
9937       real(kind=8) :: gradcorr6ij,gradcorr6kl
9938       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9939 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9940 !d        eello6=0.0d0
9941 !d        return
9942 !d      endif
9943 !d      write (iout,*)
9944 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9945 !d     &   ' and',k,l
9946       eello6_1=0.0d0
9947       eello6_2=0.0d0
9948       eello6_3=0.0d0
9949       eello6_4=0.0d0
9950       eello6_5=0.0d0
9951       eello6_6=0.0d0
9952 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9953 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9954       do iii=1,2
9955         do kkk=1,5
9956           do lll=1,3
9957             derx(lll,kkk,iii)=0.0d0
9958           enddo
9959         enddo
9960       enddo
9961 !d      eij=facont_hb(jj,i)
9962 !d      ekl=facont_hb(kk,k)
9963 !d      ekont=eij*ekl
9964 !d      eij=1.0d0
9965 !d      ekl=1.0d0
9966 !d      ekont=1.0d0
9967       if (l.eq.j+1) then
9968         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9969         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9970         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9971         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9972         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9973         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9974       else
9975         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9976         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9977         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9978         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9979         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9980           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9981         else
9982           eello6_5=0.0d0
9983         endif
9984         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9985       endif
9986 ! If turn contributions are considered, they will be handled separately.
9987       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9988 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9989 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9990 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9991 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9992 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9993 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9994 !d      goto 1112
9995       if (j.lt.nres-1) then
9996         j1=j+1
9997         j2=j-1
9998       else
9999         j1=j-1
10000         j2=j-2
10001       endif
10002       if (l.lt.nres-1) then
10003         l1=l+1
10004         l2=l-1
10005       else
10006         l1=l-1
10007         l2=l-2
10008       endif
10009       do ll=1,3
10010 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10011 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10012 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10013 !grad        ghalf=0.5d0*ggg1(ll)
10014 !d        ghalf=0.0d0
10015         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10016         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10017         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10018         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10019         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10020         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10021         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10022         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10023 !grad        ghalf=0.5d0*ggg2(ll)
10024 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10025 !d        ghalf=0.0d0
10026         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10027         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10028         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10029         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10030         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10031         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10032       enddo
10033 !d      goto 1112
10034 !grad      do m=i+1,j-1
10035 !grad        do ll=1,3
10036 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10037 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10038 !grad        enddo
10039 !grad      enddo
10040 !grad      do m=k+1,l-1
10041 !grad        do ll=1,3
10042 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10043 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10044 !grad        enddo
10045 !grad      enddo
10046 !grad1112  continue
10047 !grad      do m=i+2,j2
10048 !grad        do ll=1,3
10049 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10050 !grad        enddo
10051 !grad      enddo
10052 !grad      do m=k+2,l2
10053 !grad        do ll=1,3
10054 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10055 !grad        enddo
10056 !grad      enddo
10057 !d      do iii=1,nres-3
10058 !d        write (2,*) iii,g_corr6_loc(iii)
10059 !d      enddo
10060       eello6=ekont*eel6
10061 !d      write (2,*) 'ekont',ekont
10062 !d      write (iout,*) 'eello6',ekont*eel6
10063       return
10064       end function eello6
10065 !-----------------------------------------------------------------------------
10066       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10067       use comm_kut
10068 !      implicit real*8 (a-h,o-z)
10069 !      include 'DIMENSIONS'
10070 !      include 'COMMON.IOUNITS'
10071 !      include 'COMMON.CHAIN'
10072 !      include 'COMMON.DERIV'
10073 !      include 'COMMON.INTERACT'
10074 !      include 'COMMON.CONTACTS'
10075 !      include 'COMMON.TORSION'
10076 !      include 'COMMON.VAR'
10077 !      include 'COMMON.GEO'
10078       real(kind=8),dimension(2) :: vv,vv1
10079       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10080       logical :: swap
10081 !el      logical :: lprn
10082 !el      common /kutas/ lprn
10083       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10084       real(kind=8) :: s1,s2,s3,s4,s5
10085 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10086 !                                                                              C
10087 !      Parallel       Antiparallel                                             C
10088 !                                                                              C
10089 !          o             o                                                     C
10090 !         /l\           /j\                                                    C
10091 !        /   \         /   \                                                   C
10092 !       /| o |         | o |\                                                  C
10093 !     \ j|/k\|  /   \  |/k\|l /                                                C
10094 !      \ /   \ /     \ /   \ /                                                 C
10095 !       o     o       o     o                                                  C
10096 !       i             i                                                        C
10097 !                                                                              C
10098 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10099       itk=itortyp(itype(k,1))
10100       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10101       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10102       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10103       call transpose2(EUgC(1,1,k),auxmat(1,1))
10104       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10105       vv1(1)=pizda1(1,1)-pizda1(2,2)
10106       vv1(2)=pizda1(1,2)+pizda1(2,1)
10107       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10108       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10109       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10110       s5=scalar2(vv(1),Dtobr2(1,i))
10111 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10112       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10113       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10114        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10115        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10116        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10117        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10118        +scalar2(vv(1),Dtobr2der(1,i)))
10119       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10120       vv1(1)=pizda1(1,1)-pizda1(2,2)
10121       vv1(2)=pizda1(1,2)+pizda1(2,1)
10122       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10123       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10124       if (l.eq.j+1) then
10125         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10126        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10127        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10128        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10129        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10130       else
10131         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10132        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10133        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10134        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10135        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10136       endif
10137       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10138       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10139       vv1(1)=pizda1(1,1)-pizda1(2,2)
10140       vv1(2)=pizda1(1,2)+pizda1(2,1)
10141       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10142        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10143        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10144        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10145       do iii=1,2
10146         if (swap) then
10147           ind=3-iii
10148         else
10149           ind=iii
10150         endif
10151         do kkk=1,5
10152           do lll=1,3
10153             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10154             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10155             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10156             call transpose2(EUgC(1,1,k),auxmat(1,1))
10157             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10158               pizda1(1,1))
10159             vv1(1)=pizda1(1,1)-pizda1(2,2)
10160             vv1(2)=pizda1(1,2)+pizda1(2,1)
10161             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10162             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10163              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10164             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10165              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10166             s5=scalar2(vv(1),Dtobr2(1,i))
10167             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10168           enddo
10169         enddo
10170       enddo
10171       return
10172       end function eello6_graph1
10173 !-----------------------------------------------------------------------------
10174       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10175       use comm_kut
10176 !      implicit real*8 (a-h,o-z)
10177 !      include 'DIMENSIONS'
10178 !      include 'COMMON.IOUNITS'
10179 !      include 'COMMON.CHAIN'
10180 !      include 'COMMON.DERIV'
10181 !      include 'COMMON.INTERACT'
10182 !      include 'COMMON.CONTACTS'
10183 !      include 'COMMON.TORSION'
10184 !      include 'COMMON.VAR'
10185 !      include 'COMMON.GEO'
10186       logical :: swap
10187       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10188       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10189 !el      logical :: lprn
10190 !el      common /kutas/ lprn
10191       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10192       real(kind=8) :: s2,s3,s4
10193 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10194 !                                                                              C
10195 !      Parallel       Antiparallel                                             C
10196 !                                                                              C
10197 !          o             o                                                     C
10198 !     \   /l\           /j\   /                                                C
10199 !      \ /   \         /   \ /                                                 C
10200 !       o| o |         | o |o                                                  C
10201 !     \ j|/k\|      \  |/k\|l                                                  C
10202 !      \ /   \       \ /   \                                                   C
10203 !       o             o                                                        C
10204 !       i             i                                                        C
10205 !                                                                              C
10206 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10207 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10208 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10209 !           but not in a cluster cumulant
10210 #ifdef MOMENT
10211       s1=dip(1,jj,i)*dip(1,kk,k)
10212 #endif
10213       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10214       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10215       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10216       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10217       call transpose2(EUg(1,1,k),auxmat(1,1))
10218       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10219       vv(1)=pizda(1,1)-pizda(2,2)
10220       vv(2)=pizda(1,2)+pizda(2,1)
10221       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10222 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10223 #ifdef MOMENT
10224       eello6_graph2=-(s1+s2+s3+s4)
10225 #else
10226       eello6_graph2=-(s2+s3+s4)
10227 #endif
10228 !      eello6_graph2=-s3
10229 ! Derivatives in gamma(i-1)
10230       if (i.gt.1) then
10231 #ifdef MOMENT
10232         s1=dipderg(1,jj,i)*dip(1,kk,k)
10233 #endif
10234         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10235         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10236         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10237         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10238 #ifdef MOMENT
10239         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10240 #else
10241         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10242 #endif
10243 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10244       endif
10245 ! Derivatives in gamma(k-1)
10246 #ifdef MOMENT
10247       s1=dip(1,jj,i)*dipderg(1,kk,k)
10248 #endif
10249       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10250       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10251       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10252       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10253       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10254       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10255       vv(1)=pizda(1,1)-pizda(2,2)
10256       vv(2)=pizda(1,2)+pizda(2,1)
10257       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10258 #ifdef MOMENT
10259       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10260 #else
10261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10262 #endif
10263 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10264 ! Derivatives in gamma(j-1) or gamma(l-1)
10265       if (j.gt.1) then
10266 #ifdef MOMENT
10267         s1=dipderg(3,jj,i)*dip(1,kk,k)
10268 #endif
10269         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10270         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10271         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10272         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10273         vv(1)=pizda(1,1)-pizda(2,2)
10274         vv(2)=pizda(1,2)+pizda(2,1)
10275         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10276 #ifdef MOMENT
10277         if (swap) then
10278           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10279         else
10280           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10281         endif
10282 #endif
10283         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10284 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10285       endif
10286 ! Derivatives in gamma(l-1) or gamma(j-1)
10287       if (l.gt.1) then
10288 #ifdef MOMENT
10289         s1=dip(1,jj,i)*dipderg(3,kk,k)
10290 #endif
10291         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10292         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10293         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10294         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10295         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10296         vv(1)=pizda(1,1)-pizda(2,2)
10297         vv(2)=pizda(1,2)+pizda(2,1)
10298         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10299 #ifdef MOMENT
10300         if (swap) then
10301           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10302         else
10303           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10304         endif
10305 #endif
10306         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10307 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10308       endif
10309 ! Cartesian derivatives.
10310       if (lprn) then
10311         write (2,*) 'In eello6_graph2'
10312         do iii=1,2
10313           write (2,*) 'iii=',iii
10314           do kkk=1,5
10315             write (2,*) 'kkk=',kkk
10316             do jjj=1,2
10317               write (2,'(3(2f10.5),5x)') &
10318               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10319             enddo
10320           enddo
10321         enddo
10322       endif
10323       do iii=1,2
10324         do kkk=1,5
10325           do lll=1,3
10326 #ifdef MOMENT
10327             if (iii.eq.1) then
10328               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10329             else
10330               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10331             endif
10332 #endif
10333             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10334               auxvec(1))
10335             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10336             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10337               auxvec(1))
10338             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10339             call transpose2(EUg(1,1,k),auxmat(1,1))
10340             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10341               pizda(1,1))
10342             vv(1)=pizda(1,1)-pizda(2,2)
10343             vv(2)=pizda(1,2)+pizda(2,1)
10344             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10345 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10346 #ifdef MOMENT
10347             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10348 #else
10349             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10350 #endif
10351             if (swap) then
10352               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10353             else
10354               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10355             endif
10356           enddo
10357         enddo
10358       enddo
10359       return
10360       end function eello6_graph2
10361 !-----------------------------------------------------------------------------
10362       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10363 !      implicit real*8 (a-h,o-z)
10364 !      include 'DIMENSIONS'
10365 !      include 'COMMON.IOUNITS'
10366 !      include 'COMMON.CHAIN'
10367 !      include 'COMMON.DERIV'
10368 !      include 'COMMON.INTERACT'
10369 !      include 'COMMON.CONTACTS'
10370 !      include 'COMMON.TORSION'
10371 !      include 'COMMON.VAR'
10372 !      include 'COMMON.GEO'
10373       real(kind=8),dimension(2) :: vv,auxvec
10374       real(kind=8),dimension(2,2) :: pizda,auxmat
10375       logical :: swap
10376       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10377       real(kind=8) :: s1,s2,s3,s4
10378 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10379 !                                                                              C
10380 !      Parallel       Antiparallel                                             C
10381 !                                                                              C
10382 !          o             o                                                     C
10383 !         /l\   /   \   /j\                                                    C
10384 !        /   \ /     \ /   \                                                   C
10385 !       /| o |o       o| o |\                                                  C
10386 !       j|/k\|  /      |/k\|l /                                                C
10387 !        /   \ /       /   \ /                                                 C
10388 !       /     o       /     o                                                  C
10389 !       i             i                                                        C
10390 !                                                                              C
10391 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10392 !
10393 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10394 !           energy moment and not to the cluster cumulant.
10395       iti=itortyp(itype(i,1))
10396       if (j.lt.nres-1) then
10397         itj1=itortyp(itype(j+1,1))
10398       else
10399         itj1=ntortyp+1
10400       endif
10401       itk=itortyp(itype(k,1))
10402       itk1=itortyp(itype(k+1,1))
10403       if (l.lt.nres-1) then
10404         itl1=itortyp(itype(l+1,1))
10405       else
10406         itl1=ntortyp+1
10407       endif
10408 #ifdef MOMENT
10409       s1=dip(4,jj,i)*dip(4,kk,k)
10410 #endif
10411       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10412       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10413       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10414       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10415       call transpose2(EE(1,1,itk),auxmat(1,1))
10416       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10417       vv(1)=pizda(1,1)+pizda(2,2)
10418       vv(2)=pizda(2,1)-pizda(1,2)
10419       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10420 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10421 !d     & "sum",-(s2+s3+s4)
10422 #ifdef MOMENT
10423       eello6_graph3=-(s1+s2+s3+s4)
10424 #else
10425       eello6_graph3=-(s2+s3+s4)
10426 #endif
10427 !      eello6_graph3=-s4
10428 ! Derivatives in gamma(k-1)
10429       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10430       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10431       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10432       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10433 ! Derivatives in gamma(l-1)
10434       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10435       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10436       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10437       vv(1)=pizda(1,1)+pizda(2,2)
10438       vv(2)=pizda(2,1)-pizda(1,2)
10439       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10440       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10441 ! Cartesian derivatives.
10442       do iii=1,2
10443         do kkk=1,5
10444           do lll=1,3
10445 #ifdef MOMENT
10446             if (iii.eq.1) then
10447               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10448             else
10449               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10450             endif
10451 #endif
10452             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10453               auxvec(1))
10454             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10455             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10456               auxvec(1))
10457             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10458             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10459               pizda(1,1))
10460             vv(1)=pizda(1,1)+pizda(2,2)
10461             vv(2)=pizda(2,1)-pizda(1,2)
10462             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10463 #ifdef MOMENT
10464             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10465 #else
10466             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10467 #endif
10468             if (swap) then
10469               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10470             else
10471               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10472             endif
10473 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10474           enddo
10475         enddo
10476       enddo
10477       return
10478       end function eello6_graph3
10479 !-----------------------------------------------------------------------------
10480       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10481 !      implicit real*8 (a-h,o-z)
10482 !      include 'DIMENSIONS'
10483 !      include 'COMMON.IOUNITS'
10484 !      include 'COMMON.CHAIN'
10485 !      include 'COMMON.DERIV'
10486 !      include 'COMMON.INTERACT'
10487 !      include 'COMMON.CONTACTS'
10488 !      include 'COMMON.TORSION'
10489 !      include 'COMMON.VAR'
10490 !      include 'COMMON.GEO'
10491 !      include 'COMMON.FFIELD'
10492       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10493       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10494       logical :: swap
10495       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10496               iii,kkk,lll
10497       real(kind=8) :: s1,s2,s3,s4
10498 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10499 !                                                                              C
10500 !      Parallel       Antiparallel                                             C
10501 !                                                                              C
10502 !          o             o                                                     C
10503 !         /l\   /   \   /j\                                                    C
10504 !        /   \ /     \ /   \                                                   C
10505 !       /| o |o       o| o |\                                                  C
10506 !     \ j|/k\|      \  |/k\|l                                                  C
10507 !      \ /   \       \ /   \                                                   C
10508 !       o     \       o     \                                                  C
10509 !       i             i                                                        C
10510 !                                                                              C
10511 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10512 !
10513 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10514 !           energy moment and not to the cluster cumulant.
10515 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10516       iti=itortyp(itype(i,1))
10517       itj=itortyp(itype(j,1))
10518       if (j.lt.nres-1) then
10519         itj1=itortyp(itype(j+1,1))
10520       else
10521         itj1=ntortyp+1
10522       endif
10523       itk=itortyp(itype(k,1))
10524       if (k.lt.nres-1) then
10525         itk1=itortyp(itype(k+1,1))
10526       else
10527         itk1=ntortyp+1
10528       endif
10529       itl=itortyp(itype(l,1))
10530       if (l.lt.nres-1) then
10531         itl1=itortyp(itype(l+1,1))
10532       else
10533         itl1=ntortyp+1
10534       endif
10535 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10536 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10537 !d     & ' itl',itl,' itl1',itl1
10538 #ifdef MOMENT
10539       if (imat.eq.1) then
10540         s1=dip(3,jj,i)*dip(3,kk,k)
10541       else
10542         s1=dip(2,jj,j)*dip(2,kk,l)
10543       endif
10544 #endif
10545       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10546       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10547       if (j.eq.l+1) then
10548         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10549         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10550       else
10551         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10552         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10553       endif
10554       call transpose2(EUg(1,1,k),auxmat(1,1))
10555       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10556       vv(1)=pizda(1,1)-pizda(2,2)
10557       vv(2)=pizda(2,1)+pizda(1,2)
10558       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10559 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10560 #ifdef MOMENT
10561       eello6_graph4=-(s1+s2+s3+s4)
10562 #else
10563       eello6_graph4=-(s2+s3+s4)
10564 #endif
10565 ! Derivatives in gamma(i-1)
10566       if (i.gt.1) then
10567 #ifdef MOMENT
10568         if (imat.eq.1) then
10569           s1=dipderg(2,jj,i)*dip(3,kk,k)
10570         else
10571           s1=dipderg(4,jj,j)*dip(2,kk,l)
10572         endif
10573 #endif
10574         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10575         if (j.eq.l+1) then
10576           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10577           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10578         else
10579           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10580           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10581         endif
10582         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10583         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10584 !d          write (2,*) 'turn6 derivatives'
10585 #ifdef MOMENT
10586           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10587 #else
10588           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10589 #endif
10590         else
10591 #ifdef MOMENT
10592           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10593 #else
10594           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10595 #endif
10596         endif
10597       endif
10598 ! Derivatives in gamma(k-1)
10599 #ifdef MOMENT
10600       if (imat.eq.1) then
10601         s1=dip(3,jj,i)*dipderg(2,kk,k)
10602       else
10603         s1=dip(2,jj,j)*dipderg(4,kk,l)
10604       endif
10605 #endif
10606       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10607       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10608       if (j.eq.l+1) then
10609         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10610         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10611       else
10612         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10613         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10614       endif
10615       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10616       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10617       vv(1)=pizda(1,1)-pizda(2,2)
10618       vv(2)=pizda(2,1)+pizda(1,2)
10619       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10620       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10621 #ifdef MOMENT
10622         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10623 #else
10624         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10625 #endif
10626       else
10627 #ifdef MOMENT
10628         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10629 #else
10630         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10631 #endif
10632       endif
10633 ! Derivatives in gamma(j-1) or gamma(l-1)
10634       if (l.eq.j+1 .and. l.gt.1) then
10635         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10636         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10637         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10638         vv(1)=pizda(1,1)-pizda(2,2)
10639         vv(2)=pizda(2,1)+pizda(1,2)
10640         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10641         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10642       else if (j.gt.1) then
10643         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10644         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10645         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10646         vv(1)=pizda(1,1)-pizda(2,2)
10647         vv(2)=pizda(2,1)+pizda(1,2)
10648         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10649         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10650           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10651         else
10652           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10653         endif
10654       endif
10655 ! Cartesian derivatives.
10656       do iii=1,2
10657         do kkk=1,5
10658           do lll=1,3
10659 #ifdef MOMENT
10660             if (iii.eq.1) then
10661               if (imat.eq.1) then
10662                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10663               else
10664                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10665               endif
10666             else
10667               if (imat.eq.1) then
10668                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10669               else
10670                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10671               endif
10672             endif
10673 #endif
10674             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10675               auxvec(1))
10676             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10677             if (j.eq.l+1) then
10678               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10679                 b1(1,itj1),auxvec(1))
10680               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10681             else
10682               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10683                 b1(1,itl1),auxvec(1))
10684               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10685             endif
10686             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10687               pizda(1,1))
10688             vv(1)=pizda(1,1)-pizda(2,2)
10689             vv(2)=pizda(2,1)+pizda(1,2)
10690             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10691             if (swap) then
10692               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10693 #ifdef MOMENT
10694                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10695                    -(s1+s2+s4)
10696 #else
10697                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10698                    -(s2+s4)
10699 #endif
10700                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10701               else
10702 #ifdef MOMENT
10703                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10704 #else
10705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10706 #endif
10707                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10708               endif
10709             else
10710 #ifdef MOMENT
10711               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10712 #else
10713               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10714 #endif
10715               if (l.eq.j+1) then
10716                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10717               else
10718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10719               endif
10720             endif
10721           enddo
10722         enddo
10723       enddo
10724       return
10725       end function eello6_graph4
10726 !-----------------------------------------------------------------------------
10727       real(kind=8) function eello_turn6(i,jj,kk)
10728 !      implicit real*8 (a-h,o-z)
10729 !      include 'DIMENSIONS'
10730 !      include 'COMMON.IOUNITS'
10731 !      include 'COMMON.CHAIN'
10732 !      include 'COMMON.DERIV'
10733 !      include 'COMMON.INTERACT'
10734 !      include 'COMMON.CONTACTS'
10735 !      include 'COMMON.TORSION'
10736 !      include 'COMMON.VAR'
10737 !      include 'COMMON.GEO'
10738       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10739       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10740       real(kind=8),dimension(3) :: ggg1,ggg2
10741       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10742       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10743 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10744 !           the respective energy moment and not to the cluster cumulant.
10745 !el local variables
10746       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10747       integer :: j1,j2,l1,l2,ll
10748       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10749       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10750       s1=0.0d0
10751       s8=0.0d0
10752       s13=0.0d0
10753 !
10754       eello_turn6=0.0d0
10755       j=i+4
10756       k=i+1
10757       l=i+3
10758       iti=itortyp(itype(i,1))
10759       itk=itortyp(itype(k,1))
10760       itk1=itortyp(itype(k+1,1))
10761       itl=itortyp(itype(l,1))
10762       itj=itortyp(itype(j,1))
10763 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10764 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10765 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10766 !d        eello6=0.0d0
10767 !d        return
10768 !d      endif
10769 !d      write (iout,*)
10770 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10771 !d     &   ' and',k,l
10772 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10773       do iii=1,2
10774         do kkk=1,5
10775           do lll=1,3
10776             derx_turn(lll,kkk,iii)=0.0d0
10777           enddo
10778         enddo
10779       enddo
10780 !d      eij=1.0d0
10781 !d      ekl=1.0d0
10782 !d      ekont=1.0d0
10783       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10784 !d      eello6_5=0.0d0
10785 !d      write (2,*) 'eello6_5',eello6_5
10786 #ifdef MOMENT
10787       call transpose2(AEA(1,1,1),auxmat(1,1))
10788       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10789       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10790       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10791 #endif
10792       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10793       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10794       s2 = scalar2(b1(1,itk),vtemp1(1))
10795 #ifdef MOMENT
10796       call transpose2(AEA(1,1,2),atemp(1,1))
10797       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10798       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10799       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10800 #endif
10801       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10802       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10803       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10804 #ifdef MOMENT
10805       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10807       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10808       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10809       ss13 = scalar2(b1(1,itk),vtemp4(1))
10810       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10811 #endif
10812 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10813 !      s1=0.0d0
10814 !      s2=0.0d0
10815 !      s8=0.0d0
10816 !      s12=0.0d0
10817 !      s13=0.0d0
10818       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10819 ! Derivatives in gamma(i+2)
10820       s1d =0.0d0
10821       s8d =0.0d0
10822 #ifdef MOMENT
10823       call transpose2(AEA(1,1,1),auxmatd(1,1))
10824       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10825       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10826       call transpose2(AEAderg(1,1,2),atempd(1,1))
10827       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10828       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10829 #endif
10830       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10831       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10832       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10833 !      s1d=0.0d0
10834 !      s2d=0.0d0
10835 !      s8d=0.0d0
10836 !      s12d=0.0d0
10837 !      s13d=0.0d0
10838       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10839 ! Derivatives in gamma(i+3)
10840 #ifdef MOMENT
10841       call transpose2(AEA(1,1,1),auxmatd(1,1))
10842       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10843       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10845 #endif
10846       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10847       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10848       s2d = scalar2(b1(1,itk),vtemp1d(1))
10849 #ifdef MOMENT
10850       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10851       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10852 #endif
10853       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10854 #ifdef MOMENT
10855       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10856       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10857       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10858 #endif
10859 !      s1d=0.0d0
10860 !      s2d=0.0d0
10861 !      s8d=0.0d0
10862 !      s12d=0.0d0
10863 !      s13d=0.0d0
10864 #ifdef MOMENT
10865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10866                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10867 #else
10868       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10869                     -0.5d0*ekont*(s2d+s12d)
10870 #endif
10871 ! Derivatives in gamma(i+4)
10872       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10873       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10875 #ifdef MOMENT
10876       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10877       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10878       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10879 #endif
10880 !      s1d=0.0d0
10881 !      s2d=0.0d0
10882 !      s8d=0.0d0
10883 !      s12d=0.0d0
10884 !      s13d=0.0d0
10885 #ifdef MOMENT
10886       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10887 #else
10888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10889 #endif
10890 ! Derivatives in gamma(i+5)
10891 #ifdef MOMENT
10892       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10893       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10894       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10895 #endif
10896       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10897       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10898       s2d = scalar2(b1(1,itk),vtemp1d(1))
10899 #ifdef MOMENT
10900       call transpose2(AEA(1,1,2),atempd(1,1))
10901       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10902       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10903 #endif
10904       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10906 #ifdef MOMENT
10907       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10908       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10909       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10910 #endif
10911 !      s1d=0.0d0
10912 !      s2d=0.0d0
10913 !      s8d=0.0d0
10914 !      s12d=0.0d0
10915 !      s13d=0.0d0
10916 #ifdef MOMENT
10917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10918                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10919 #else
10920       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10921                     -0.5d0*ekont*(s2d+s12d)
10922 #endif
10923 ! Cartesian derivatives
10924       do iii=1,2
10925         do kkk=1,5
10926           do lll=1,3
10927 #ifdef MOMENT
10928             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10929             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10930             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10931 #endif
10932             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10933             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10934                 vtemp1d(1))
10935             s2d = scalar2(b1(1,itk),vtemp1d(1))
10936 #ifdef MOMENT
10937             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10938             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10939             s8d = -(atempd(1,1)+atempd(2,2))* &
10940                  scalar2(cc(1,1,itl),vtemp2(1))
10941 #endif
10942             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10943                  auxmatd(1,1))
10944             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10945             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10946 !      s1d=0.0d0
10947 !      s2d=0.0d0
10948 !      s8d=0.0d0
10949 !      s12d=0.0d0
10950 !      s13d=0.0d0
10951 #ifdef MOMENT
10952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10953               - 0.5d0*(s1d+s2d)
10954 #else
10955             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10956               - 0.5d0*s2d
10957 #endif
10958 #ifdef MOMENT
10959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10960               - 0.5d0*(s8d+s12d)
10961 #else
10962             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10963               - 0.5d0*s12d
10964 #endif
10965           enddo
10966         enddo
10967       enddo
10968 #ifdef MOMENT
10969       do kkk=1,5
10970         do lll=1,3
10971           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10972             achuj_tempd(1,1))
10973           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10974           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10975           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10976           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10977           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10978             vtemp4d(1))
10979           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10980           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10981           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10982         enddo
10983       enddo
10984 #endif
10985 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10986 !d     &  16*eel_turn6_num
10987 !d      goto 1112
10988       if (j.lt.nres-1) then
10989         j1=j+1
10990         j2=j-1
10991       else
10992         j1=j-1
10993         j2=j-2
10994       endif
10995       if (l.lt.nres-1) then
10996         l1=l+1
10997         l2=l-1
10998       else
10999         l1=l-1
11000         l2=l-2
11001       endif
11002       do ll=1,3
11003 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11004 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11005 !grad        ghalf=0.5d0*ggg1(ll)
11006 !d        ghalf=0.0d0
11007         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11008         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11009         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11010           +ekont*derx_turn(ll,2,1)
11011         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11012         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11013           +ekont*derx_turn(ll,4,1)
11014         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11015         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11016         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11017 !grad        ghalf=0.5d0*ggg2(ll)
11018 !d        ghalf=0.0d0
11019         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11020           +ekont*derx_turn(ll,2,2)
11021         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11022         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11023           +ekont*derx_turn(ll,4,2)
11024         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11025         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11026         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11027       enddo
11028 !d      goto 1112
11029 !grad      do m=i+1,j-1
11030 !grad        do ll=1,3
11031 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11032 !grad        enddo
11033 !grad      enddo
11034 !grad      do m=k+1,l-1
11035 !grad        do ll=1,3
11036 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11037 !grad        enddo
11038 !grad      enddo
11039 !grad1112  continue
11040 !grad      do m=i+2,j2
11041 !grad        do ll=1,3
11042 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11043 !grad        enddo
11044 !grad      enddo
11045 !grad      do m=k+2,l2
11046 !grad        do ll=1,3
11047 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11048 !grad        enddo
11049 !grad      enddo
11050 !d      do iii=1,nres-3
11051 !d        write (2,*) iii,g_corr6_loc(iii)
11052 !d      enddo
11053       eello_turn6=ekont*eel_turn6
11054 !d      write (2,*) 'ekont',ekont
11055 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11056       return
11057       end function eello_turn6
11058 !-----------------------------------------------------------------------------
11059       subroutine MATVEC2(A1,V1,V2)
11060 !DIR$ INLINEALWAYS MATVEC2
11061 #ifndef OSF
11062 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11063 #endif
11064 !      implicit real*8 (a-h,o-z)
11065 !      include 'DIMENSIONS'
11066       real(kind=8),dimension(2) :: V1,V2
11067       real(kind=8),dimension(2,2) :: A1
11068       real(kind=8) :: vaux1,vaux2
11069 !      DO 1 I=1,2
11070 !        VI=0.0
11071 !        DO 3 K=1,2
11072 !    3     VI=VI+A1(I,K)*V1(K)
11073 !        Vaux(I)=VI
11074 !    1 CONTINUE
11075
11076       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11077       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11078
11079       v2(1)=vaux1
11080       v2(2)=vaux2
11081       end subroutine MATVEC2
11082 !-----------------------------------------------------------------------------
11083       subroutine MATMAT2(A1,A2,A3)
11084 #ifndef OSF
11085 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11086 #endif
11087 !      implicit real*8 (a-h,o-z)
11088 !      include 'DIMENSIONS'
11089       real(kind=8),dimension(2,2) :: A1,A2,A3
11090       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11091 !      DIMENSION AI3(2,2)
11092 !        DO  J=1,2
11093 !          A3IJ=0.0
11094 !          DO K=1,2
11095 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11096 !          enddo
11097 !          A3(I,J)=A3IJ
11098 !       enddo
11099 !      enddo
11100
11101       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11102       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11103       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11104       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11105
11106       A3(1,1)=AI3_11
11107       A3(2,1)=AI3_21
11108       A3(1,2)=AI3_12
11109       A3(2,2)=AI3_22
11110       end subroutine MATMAT2
11111 !-----------------------------------------------------------------------------
11112       real(kind=8) function scalar2(u,v)
11113 !DIR$ INLINEALWAYS scalar2
11114       implicit none
11115       real(kind=8),dimension(2) :: u,v
11116       real(kind=8) :: sc
11117       integer :: i
11118       scalar2=u(1)*v(1)+u(2)*v(2)
11119       return
11120       end function scalar2
11121 !-----------------------------------------------------------------------------
11122       subroutine transpose2(a,at)
11123 !DIR$ INLINEALWAYS transpose2
11124 #ifndef OSF
11125 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11126 #endif
11127       implicit none
11128       real(kind=8),dimension(2,2) :: a,at
11129       at(1,1)=a(1,1)
11130       at(1,2)=a(2,1)
11131       at(2,1)=a(1,2)
11132       at(2,2)=a(2,2)
11133       return
11134       end subroutine transpose2
11135 !-----------------------------------------------------------------------------
11136       subroutine transpose(n,a,at)
11137       implicit none
11138       integer :: n,i,j
11139       real(kind=8),dimension(n,n) :: a,at
11140       do i=1,n
11141         do j=1,n
11142           at(j,i)=a(i,j)
11143         enddo
11144       enddo
11145       return
11146       end subroutine transpose
11147 !-----------------------------------------------------------------------------
11148       subroutine prodmat3(a1,a2,kk,transp,prod)
11149 !DIR$ INLINEALWAYS prodmat3
11150 #ifndef OSF
11151 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11152 #endif
11153       implicit none
11154       integer :: i,j
11155       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11156       logical :: transp
11157 !rc      double precision auxmat(2,2),prod_(2,2)
11158
11159       if (transp) then
11160 !rc        call transpose2(kk(1,1),auxmat(1,1))
11161 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11162 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11163
11164            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11165        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11166            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11167        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11168            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11169        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11170            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11171        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11172
11173       else
11174 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11175 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11176
11177            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11178         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11179            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11180         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11181            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11182         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11183            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11184         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11185
11186       endif
11187 !      call transpose2(a2(1,1),a2t(1,1))
11188
11189 !rc      print *,transp
11190 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11191 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11192
11193       return
11194       end subroutine prodmat3
11195 !-----------------------------------------------------------------------------
11196 ! energy_p_new_barrier.F
11197 !-----------------------------------------------------------------------------
11198       subroutine sum_gradient
11199 !      implicit real*8 (a-h,o-z)
11200       use io_base, only: pdbout
11201 !      include 'DIMENSIONS'
11202 #ifndef ISNAN
11203       external proc_proc
11204 #ifdef WINPGI
11205 !MS$ATTRIBUTES C ::  proc_proc
11206 #endif
11207 #endif
11208 #ifdef MPI
11209       include 'mpif.h'
11210 #endif
11211       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11212                    gloc_scbuf !(3,maxres)
11213
11214       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11215 !#endif
11216 !el local variables
11217       integer :: i,j,k,ierror,ierr
11218       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11219                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11220                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11221                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11222                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11223                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11224                    gsccorr_max,gsccorrx_max,time00
11225
11226 !      include 'COMMON.SETUP'
11227 !      include 'COMMON.IOUNITS'
11228 !      include 'COMMON.FFIELD'
11229 !      include 'COMMON.DERIV'
11230 !      include 'COMMON.INTERACT'
11231 !      include 'COMMON.SBRIDGE'
11232 !      include 'COMMON.CHAIN'
11233 !      include 'COMMON.VAR'
11234 !      include 'COMMON.CONTROL'
11235 !      include 'COMMON.TIME1'
11236 !      include 'COMMON.MAXGRAD'
11237 !      include 'COMMON.SCCOR'
11238 #ifdef TIMING
11239       time01=MPI_Wtime()
11240 #endif
11241 !#define DEBUG
11242 #ifdef DEBUG
11243       write (iout,*) "sum_gradient gvdwc, gvdwx"
11244       do i=1,nres
11245         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11246          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11247       enddo
11248       call flush(iout)
11249 #endif
11250 #ifdef MPI
11251         gradbufc=0.0d0
11252         gradbufx=0.0d0
11253         gradbufc_sum=0.0d0
11254         gloc_scbuf=0.0d0
11255         glocbuf=0.0d0
11256 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11257         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11258           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11259 #endif
11260 !
11261 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11262 !            in virtual-bond-vector coordinates
11263 !
11264 #ifdef DEBUG
11265 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11266 !      do i=1,nres-1
11267 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11268 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11269 !      enddo
11270 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11271 !      do i=1,nres-1
11272 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11273 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11274 !      enddo
11275 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11276 !      do i=1,nres
11277 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11278 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11279 !         (gvdwc_scpp(j,i),j=1,3)
11280 !      enddo
11281 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11282 !      do i=1,nres
11283 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11284 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11285 !         (gelc_loc_long(j,i),j=1,3)
11286 !      enddo
11287       call flush(iout)
11288 #endif
11289 #ifdef SPLITELE
11290       do i=0,nct
11291         do j=1,3
11292           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11293                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11294                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11295                       wel_loc*gel_loc_long(j,i)+ &
11296                       wcorr*gradcorr_long(j,i)+ &
11297                       wcorr5*gradcorr5_long(j,i)+ &
11298                       wcorr6*gradcorr6_long(j,i)+ &
11299                       wturn6*gcorr6_turn_long(j,i)+ &
11300                       wstrain*ghpbc(j,i) &
11301                      +wliptran*gliptranc(j,i) &
11302                      +gradafm(j,i) &
11303                      +welec*gshieldc(j,i) &
11304                      +wcorr*gshieldc_ec(j,i) &
11305                      +wturn3*gshieldc_t3(j,i)&
11306                      +wturn4*gshieldc_t4(j,i)&
11307                      +wel_loc*gshieldc_ll(j,i)&
11308                      +wtube*gg_tube(j,i) &
11309                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11310                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11311                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11312                      wcorr_nucl*gradcorr_nucl(j,i)&
11313                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11314                      wcatprot* gradpepcat(j,i)+ &
11315                      wcatcat*gradcatcat(j,i)+   &
11316                      wscbase*gvdwc_scbase(j,i)+ &
11317                      wpepbase*gvdwc_pepbase(j,i)+&
11318                      wscpho*gvdwc_scpho(j,i)+   &
11319                      wpeppho*gvdwc_peppho(j,i)
11320
11321
11322
11323
11324
11325         enddo
11326       enddo
11327 #else
11328       do i=0,nct
11329         do j=1,3
11330           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11331                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11332                       welec*gelc_long(j,i)+ &
11333                       wbond*gradb(j,i)+ &
11334                       wel_loc*gel_loc_long(j,i)+ &
11335                       wcorr*gradcorr_long(j,i)+ &
11336                       wcorr5*gradcorr5_long(j,i)+ &
11337                       wcorr6*gradcorr6_long(j,i)+ &
11338                       wturn6*gcorr6_turn_long(j,i)+ &
11339                       wstrain*ghpbc(j,i) &
11340                      +wliptran*gliptranc(j,i) &
11341                      +gradafm(j,i) &
11342                      +welec*gshieldc(j,i)&
11343                      +wcorr*gshieldc_ec(j,i) &
11344                      +wturn4*gshieldc_t4(j,i) &
11345                      +wel_loc*gshieldc_ll(j,i)&
11346                      +wtube*gg_tube(j,i) &
11347                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11348                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11349                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11350                      wcorr_nucl*gradcorr_nucl(j,i) &
11351                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11352                      wcatprot* gradpepcat(j,i)+ &
11353                      wcatcat*gradcatcat(j,i)+   &
11354                      wscbase*gvdwc_scbase(j,i)+ &
11355                      wpepbase*gvdwc_pepbase(j,i)+&
11356                      wscpho*gvdwc_scpho(j,i)+&
11357                      wpeppho*gvdwc_peppho(j,i)
11358
11359
11360         enddo
11361       enddo
11362 #endif
11363 #ifdef MPI
11364       if (nfgtasks.gt.1) then
11365       time00=MPI_Wtime()
11366 #ifdef DEBUG
11367       write (iout,*) "gradbufc before allreduce"
11368       do i=1,nres
11369         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11370       enddo
11371       call flush(iout)
11372 #endif
11373       do i=0,nres
11374         do j=1,3
11375           gradbufc_sum(j,i)=gradbufc(j,i)
11376         enddo
11377       enddo
11378 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11379 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11380 !      time_reduce=time_reduce+MPI_Wtime()-time00
11381 #ifdef DEBUG
11382 !      write (iout,*) "gradbufc_sum after allreduce"
11383 !      do i=1,nres
11384 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11385 !      enddo
11386 !      call flush(iout)
11387 #endif
11388 #ifdef TIMING
11389 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11390 #endif
11391       do i=0,nres
11392         do k=1,3
11393           gradbufc(k,i)=0.0d0
11394         enddo
11395       enddo
11396 #ifdef DEBUG
11397       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11398       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11399                         " jgrad_end  ",jgrad_end(i),&
11400                         i=igrad_start,igrad_end)
11401 #endif
11402 !
11403 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11404 ! do not parallelize this part.
11405 !
11406 !      do i=igrad_start,igrad_end
11407 !        do j=jgrad_start(i),jgrad_end(i)
11408 !          do k=1,3
11409 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11410 !          enddo
11411 !        enddo
11412 !      enddo
11413       do j=1,3
11414         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11415       enddo
11416       do i=nres-2,-1,-1
11417         do j=1,3
11418           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11419         enddo
11420       enddo
11421 #ifdef DEBUG
11422       write (iout,*) "gradbufc after summing"
11423       do i=1,nres
11424         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11425       enddo
11426       call flush(iout)
11427 #endif
11428       else
11429 #endif
11430 !el#define DEBUG
11431 #ifdef DEBUG
11432       write (iout,*) "gradbufc"
11433       do i=1,nres
11434         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11435       enddo
11436       call flush(iout)
11437 #endif
11438 !el#undef DEBUG
11439       do i=-1,nres
11440         do j=1,3
11441           gradbufc_sum(j,i)=gradbufc(j,i)
11442           gradbufc(j,i)=0.0d0
11443         enddo
11444       enddo
11445       do j=1,3
11446         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11447       enddo
11448       do i=nres-2,-1,-1
11449         do j=1,3
11450           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11451         enddo
11452       enddo
11453 !      do i=nnt,nres-1
11454 !        do k=1,3
11455 !          gradbufc(k,i)=0.0d0
11456 !        enddo
11457 !        do j=i+1,nres
11458 !          do k=1,3
11459 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11460 !          enddo
11461 !        enddo
11462 !      enddo
11463 !el#define DEBUG
11464 #ifdef DEBUG
11465       write (iout,*) "gradbufc after summing"
11466       do i=1,nres
11467         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11468       enddo
11469       call flush(iout)
11470 #endif
11471 !el#undef DEBUG
11472 #ifdef MPI
11473       endif
11474 #endif
11475       do k=1,3
11476         gradbufc(k,nres)=0.0d0
11477       enddo
11478 !el----------------
11479 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11480 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11481 !el-----------------
11482       do i=-1,nct
11483         do j=1,3
11484 #ifdef SPLITELE
11485           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11486                       wel_loc*gel_loc(j,i)+ &
11487                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11488                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11489                       wel_loc*gel_loc_long(j,i)+ &
11490                       wcorr*gradcorr_long(j,i)+ &
11491                       wcorr5*gradcorr5_long(j,i)+ &
11492                       wcorr6*gradcorr6_long(j,i)+ &
11493                       wturn6*gcorr6_turn_long(j,i))+ &
11494                       wbond*gradb(j,i)+ &
11495                       wcorr*gradcorr(j,i)+ &
11496                       wturn3*gcorr3_turn(j,i)+ &
11497                       wturn4*gcorr4_turn(j,i)+ &
11498                       wcorr5*gradcorr5(j,i)+ &
11499                       wcorr6*gradcorr6(j,i)+ &
11500                       wturn6*gcorr6_turn(j,i)+ &
11501                       wsccor*gsccorc(j,i) &
11502                      +wscloc*gscloc(j,i)  &
11503                      +wliptran*gliptranc(j,i) &
11504                      +gradafm(j,i) &
11505                      +welec*gshieldc(j,i) &
11506                      +welec*gshieldc_loc(j,i) &
11507                      +wcorr*gshieldc_ec(j,i) &
11508                      +wcorr*gshieldc_loc_ec(j,i) &
11509                      +wturn3*gshieldc_t3(j,i) &
11510                      +wturn3*gshieldc_loc_t3(j,i) &
11511                      +wturn4*gshieldc_t4(j,i) &
11512                      +wturn4*gshieldc_loc_t4(j,i) &
11513                      +wel_loc*gshieldc_ll(j,i) &
11514                      +wel_loc*gshieldc_loc_ll(j,i) &
11515                      +wtube*gg_tube(j,i) &
11516                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11517                      +wvdwpsb*gvdwpsb1(j,i))&
11518                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11519 !                      if (i.eq.21) then
11520 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11521 !                      wturn4*gshieldc_t4(j,i), &
11522 !                     wturn4*gshieldc_loc_t4(j,i)
11523 !                       endif
11524 !                 if ((i.le.2).and.(i.ge.1))
11525 !                       print *,gradc(j,i,icg),&
11526 !                      gradbufc(j,i),welec*gelc(j,i), &
11527 !                      wel_loc*gel_loc(j,i), &
11528 !                      wscp*gvdwc_scpp(j,i), &
11529 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11530 !                      wel_loc*gel_loc_long(j,i), &
11531 !                      wcorr*gradcorr_long(j,i), &
11532 !                      wcorr5*gradcorr5_long(j,i), &
11533 !                      wcorr6*gradcorr6_long(j,i), &
11534 !                      wturn6*gcorr6_turn_long(j,i), &
11535 !                      wbond*gradb(j,i), &
11536 !                      wcorr*gradcorr(j,i), &
11537 !                      wturn3*gcorr3_turn(j,i), &
11538 !                      wturn4*gcorr4_turn(j,i), &
11539 !                      wcorr5*gradcorr5(j,i), &
11540 !                      wcorr6*gradcorr6(j,i), &
11541 !                      wturn6*gcorr6_turn(j,i), &
11542 !                      wsccor*gsccorc(j,i) &
11543 !                     ,wscloc*gscloc(j,i)  &
11544 !                     ,wliptran*gliptranc(j,i) &
11545 !                    ,gradafm(j,i) &
11546 !                     ,welec*gshieldc(j,i) &
11547 !                     ,welec*gshieldc_loc(j,i) &
11548 !                     ,wcorr*gshieldc_ec(j,i) &
11549 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11550 !                     ,wturn3*gshieldc_t3(j,i) &
11551 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11552 !                     ,wturn4*gshieldc_t4(j,i) &
11553 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11554 !                     ,wel_loc*gshieldc_ll(j,i) &
11555 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11556 !                     ,wtube*gg_tube(j,i) &
11557 !                     ,wbond_nucl*gradb_nucl(j,i) &
11558 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11559 !                     wvdwpsb*gvdwpsb1(j,i)&
11560 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11561 !
11562
11563 #else
11564           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11565                       wel_loc*gel_loc(j,i)+ &
11566                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11567                       welec*gelc_long(j,i)+ &
11568                       wel_loc*gel_loc_long(j,i)+ &
11569 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11570                       wcorr5*gradcorr5_long(j,i)+ &
11571                       wcorr6*gradcorr6_long(j,i)+ &
11572                       wturn6*gcorr6_turn_long(j,i))+ &
11573                       wbond*gradb(j,i)+ &
11574                       wcorr*gradcorr(j,i)+ &
11575                       wturn3*gcorr3_turn(j,i)+ &
11576                       wturn4*gcorr4_turn(j,i)+ &
11577                       wcorr5*gradcorr5(j,i)+ &
11578                       wcorr6*gradcorr6(j,i)+ &
11579                       wturn6*gcorr6_turn(j,i)+ &
11580                       wsccor*gsccorc(j,i) &
11581                      +wscloc*gscloc(j,i) &
11582                      +gradafm(j,i) &
11583                      +wliptran*gliptranc(j,i) &
11584                      +welec*gshieldc(j,i) &
11585                      +welec*gshieldc_loc(j,i) &
11586                      +wcorr*gshieldc_ec(j,i) &
11587                      +wcorr*gshieldc_loc_ec(j,i) &
11588                      +wturn3*gshieldc_t3(j,i) &
11589                      +wturn3*gshieldc_loc_t3(j,i) &
11590                      +wturn4*gshieldc_t4(j,i) &
11591                      +wturn4*gshieldc_loc_t4(j,i) &
11592                      +wel_loc*gshieldc_ll(j,i) &
11593                      +wel_loc*gshieldc_loc_ll(j,i) &
11594                      +wtube*gg_tube(j,i) &
11595                      +wbond_nucl*gradb_nucl(j,i) &
11596                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11597                      +wvdwpsb*gvdwpsb1(j,i))&
11598                      +wsbloc*gsbloc(j,i)
11599
11600
11601
11602
11603 #endif
11604           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11605                         wbond*gradbx(j,i)+ &
11606                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11607                         wsccor*gsccorx(j,i) &
11608                        +wscloc*gsclocx(j,i) &
11609                        +wliptran*gliptranx(j,i) &
11610                        +welec*gshieldx(j,i)     &
11611                        +wcorr*gshieldx_ec(j,i)  &
11612                        +wturn3*gshieldx_t3(j,i) &
11613                        +wturn4*gshieldx_t4(j,i) &
11614                        +wel_loc*gshieldx_ll(j,i)&
11615                        +wtube*gg_tube_sc(j,i)   &
11616                        +wbond_nucl*gradbx_nucl(j,i) &
11617                        +wvdwsb*gvdwsbx(j,i) &
11618                        +welsb*gelsbx(j,i) &
11619                        +wcorr_nucl*gradxorr_nucl(j,i)&
11620                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11621                        +wsbloc*gsblocx(j,i) &
11622                        +wcatprot* gradpepcatx(j,i)&
11623                        +wscbase*gvdwx_scbase(j,i) &
11624                        +wpepbase*gvdwx_pepbase(j,i)&
11625                        +wscpho*gvdwx_scpho(j,i)
11626 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11627
11628         enddo
11629       enddo
11630 !#define DEBUG
11631 #ifdef DEBUG
11632       write (iout,*) "gloc before adding corr"
11633       do i=1,4*nres
11634         write (iout,*) i,gloc(i,icg)
11635       enddo
11636 #endif
11637       do i=1,nres-3
11638         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11639          +wcorr5*g_corr5_loc(i) &
11640          +wcorr6*g_corr6_loc(i) &
11641          +wturn4*gel_loc_turn4(i) &
11642          +wturn3*gel_loc_turn3(i) &
11643          +wturn6*gel_loc_turn6(i) &
11644          +wel_loc*gel_loc_loc(i)
11645       enddo
11646 #ifdef DEBUG
11647       write (iout,*) "gloc after adding corr"
11648       do i=1,4*nres
11649         write (iout,*) i,gloc(i,icg)
11650       enddo
11651 #endif
11652 !#undef DEBUG
11653 #ifdef MPI
11654       if (nfgtasks.gt.1) then
11655         do j=1,3
11656           do i=0,nres
11657             gradbufc(j,i)=gradc(j,i,icg)
11658             gradbufx(j,i)=gradx(j,i,icg)
11659           enddo
11660         enddo
11661         do i=1,4*nres
11662           glocbuf(i)=gloc(i,icg)
11663         enddo
11664 !#define DEBUG
11665 #ifdef DEBUG
11666       write (iout,*) "gloc_sc before reduce"
11667       do i=1,nres
11668        do j=1,1
11669         write (iout,*) i,j,gloc_sc(j,i,icg)
11670        enddo
11671       enddo
11672 #endif
11673 !#undef DEBUG
11674         do i=1,nres
11675          do j=1,3
11676           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11677          enddo
11678         enddo
11679         time00=MPI_Wtime()
11680         call MPI_Barrier(FG_COMM,IERR)
11681         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11682         time00=MPI_Wtime()
11683         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11684           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11685         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11686           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11687         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11688           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11689         time_reduce=time_reduce+MPI_Wtime()-time00
11690         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11691           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11692         time_reduce=time_reduce+MPI_Wtime()-time00
11693 !#define DEBUG
11694 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11695 #ifdef DEBUG
11696       write (iout,*) "gloc_sc after reduce"
11697       do i=1,nres
11698        do j=1,1
11699         write (iout,*) i,j,gloc_sc(j,i,icg)
11700        enddo
11701       enddo
11702 #endif
11703 !#undef DEBUG
11704 #ifdef DEBUG
11705       write (iout,*) "gloc after reduce"
11706       do i=1,4*nres
11707         write (iout,*) i,gloc(i,icg)
11708       enddo
11709 #endif
11710       endif
11711 #endif
11712       if (gnorm_check) then
11713 !
11714 ! Compute the maximum elements of the gradient
11715 !
11716       gvdwc_max=0.0d0
11717       gvdwc_scp_max=0.0d0
11718       gelc_max=0.0d0
11719       gvdwpp_max=0.0d0
11720       gradb_max=0.0d0
11721       ghpbc_max=0.0d0
11722       gradcorr_max=0.0d0
11723       gel_loc_max=0.0d0
11724       gcorr3_turn_max=0.0d0
11725       gcorr4_turn_max=0.0d0
11726       gradcorr5_max=0.0d0
11727       gradcorr6_max=0.0d0
11728       gcorr6_turn_max=0.0d0
11729       gsccorc_max=0.0d0
11730       gscloc_max=0.0d0
11731       gvdwx_max=0.0d0
11732       gradx_scp_max=0.0d0
11733       ghpbx_max=0.0d0
11734       gradxorr_max=0.0d0
11735       gsccorx_max=0.0d0
11736       gsclocx_max=0.0d0
11737       do i=1,nct
11738         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11739         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11740         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11741         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11742          gvdwc_scp_max=gvdwc_scp_norm
11743         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11744         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11745         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11746         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11747         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11748         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11749         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11750         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11751         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11752         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11753         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11754         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11755         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11756           gcorr3_turn(1,i)))
11757         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11758           gcorr3_turn_max=gcorr3_turn_norm
11759         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11760           gcorr4_turn(1,i)))
11761         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11762           gcorr4_turn_max=gcorr4_turn_norm
11763         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11764         if (gradcorr5_norm.gt.gradcorr5_max) &
11765           gradcorr5_max=gradcorr5_norm
11766         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11767         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11768         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11769           gcorr6_turn(1,i)))
11770         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11771           gcorr6_turn_max=gcorr6_turn_norm
11772         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11773         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11774         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11775         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11776         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11777         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11778         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11779         if (gradx_scp_norm.gt.gradx_scp_max) &
11780           gradx_scp_max=gradx_scp_norm
11781         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11782         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11783         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11784         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11785         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11786         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11787         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11788         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11789       enddo
11790       if (gradout) then
11791 #ifdef AIX
11792         open(istat,file=statname,position="append")
11793 #else
11794         open(istat,file=statname,access="append")
11795 #endif
11796         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11797            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11798            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11799            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11800            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11801            gsccorx_max,gsclocx_max
11802         close(istat)
11803         if (gvdwc_max.gt.1.0d4) then
11804           write (iout,*) "gvdwc gvdwx gradb gradbx"
11805           do i=nnt,nct
11806             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11807               gradb(j,i),gradbx(j,i),j=1,3)
11808           enddo
11809           call pdbout(0.0d0,'cipiszcze',iout)
11810           call flush(iout)
11811         endif
11812       endif
11813       endif
11814 !#define DEBUG
11815 #ifdef DEBUG
11816       write (iout,*) "gradc gradx gloc"
11817       do i=1,nres
11818         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11819          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11820       enddo
11821 #endif
11822 !#undef DEBUG
11823 #ifdef TIMING
11824       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11825 #endif
11826       return
11827       end subroutine sum_gradient
11828 !-----------------------------------------------------------------------------
11829       subroutine sc_grad
11830 !      implicit real*8 (a-h,o-z)
11831       use calc_data
11832 !      include 'DIMENSIONS'
11833 !      include 'COMMON.CHAIN'
11834 !      include 'COMMON.DERIV'
11835 !      include 'COMMON.CALC'
11836 !      include 'COMMON.IOUNITS'
11837       real(kind=8), dimension(3) :: dcosom1,dcosom2
11838 !      print *,"wchodze"
11839       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11840           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11841       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11842           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11843
11844       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11845            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11846            +dCAVdOM12+ dGCLdOM12
11847 ! diagnostics only
11848 !      eom1=0.0d0
11849 !      eom2=0.0d0
11850 !      eom12=evdwij*eps1_om12
11851 ! end diagnostics
11852 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11853 !       " sigder",sigder
11854 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11855 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11856 !C      print *,sss_ele_cut,'in sc_grad'
11857       do k=1,3
11858         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11859         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11860       enddo
11861       do k=1,3
11862         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11863 !C      print *,'gg',k,gg(k)
11864        enddo
11865 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11866 !      write (iout,*) "gg",(gg(k),k=1,3)
11867       do k=1,3
11868         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11869                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11870                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11871                   *sss_ele_cut
11872
11873         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11874                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11875                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11876                   *sss_ele_cut
11877
11878 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11879 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11880 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11881 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11882       enddo
11883 !
11884 ! Calculate the components of the gradient in DC and X
11885 !
11886 !grad      do k=i,j-1
11887 !grad        do l=1,3
11888 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11889 !grad        enddo
11890 !grad      enddo
11891       do l=1,3
11892         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11893         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11894       enddo
11895       return
11896       end subroutine sc_grad
11897
11898       subroutine sc_grad_cat
11899       use calc_data
11900       real(kind=8), dimension(3) :: dcosom1,dcosom2
11901       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11902           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11903       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11904           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11905
11906       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11907            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11908            +dCAVdOM12+ dGCLdOM12
11909 ! diagnostics only
11910 !      eom1=0.0d0
11911 !      eom2=0.0d0
11912 !      eom12=evdwij*eps1_om12
11913 ! end diagnostics
11914
11915       do k=1,3
11916         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11917         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11918       enddo
11919       do k=1,3
11920         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11921 !C      print *,'gg',k,gg(k)
11922        enddo
11923 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11924 !      write (iout,*) "gg",(gg(k),k=1,3)
11925       do k=1,3
11926         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11927                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11928                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11929
11930 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11931 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11932 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11933
11934 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11935 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11936 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11937 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11938       enddo
11939 !
11940 ! Calculate the components of the gradient in DC and X
11941 !
11942       do l=1,3
11943         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11944         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11945       enddo
11946       end subroutine sc_grad_cat
11947
11948       subroutine sc_grad_cat_pep
11949       use calc_data
11950       real(kind=8), dimension(3) :: dcosom1,dcosom2
11951       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11952           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11953       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11954           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11955
11956       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11957            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11958            +dCAVdOM12+ dGCLdOM12
11959 ! diagnostics only
11960 !      eom1=0.0d0
11961 !      eom2=0.0d0
11962 !      eom12=evdwij*eps1_om12
11963 ! end diagnostics
11964
11965       do k=1,3
11966         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11967         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11968         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11969         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11970                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11971                  *dsci_inv*2.0 &
11972                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11973         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11974                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11975                  *dsci_inv*2.0 &
11976                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11977         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11978       enddo
11979       end subroutine sc_grad_cat_pep
11980
11981 #ifdef CRYST_THETA
11982 !-----------------------------------------------------------------------------
11983       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11984
11985       use comm_calcthet
11986 !      implicit real*8 (a-h,o-z)
11987 !      include 'DIMENSIONS'
11988 !      include 'COMMON.LOCAL'
11989 !      include 'COMMON.IOUNITS'
11990 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11991 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11992 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11993       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11994       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11995 !el      integer :: it
11996 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11997 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11998 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11999 !el local variables
12000
12001       delthec=thetai-thet_pred_mean
12002       delthe0=thetai-theta0i
12003 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12004       t3 = thetai-thet_pred_mean
12005       t6 = t3**2
12006       t9 = term1
12007       t12 = t3*sigcsq
12008       t14 = t12+t6*sigsqtc
12009       t16 = 1.0d0
12010       t21 = thetai-theta0i
12011       t23 = t21**2
12012       t26 = term2
12013       t27 = t21*t26
12014       t32 = termexp
12015       t40 = t32**2
12016       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12017        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12018        *(-t12*t9-ak*sig0inv*t27)
12019       return
12020       end subroutine mixder
12021 #endif
12022 !-----------------------------------------------------------------------------
12023 ! cartder.F
12024 !-----------------------------------------------------------------------------
12025       subroutine cartder
12026 !-----------------------------------------------------------------------------
12027 ! This subroutine calculates the derivatives of the consecutive virtual
12028 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12029 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12030 ! in the angles alpha and omega, describing the location of a side chain
12031 ! in its local coordinate system.
12032 !
12033 ! The derivatives are stored in the following arrays:
12034 !
12035 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12036 ! The structure is as follows:
12037 !
12038 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12039 ! 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)
12040 !         . . . . . . . . . . . .  . . . . . .
12041 ! 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)
12042 !                          .
12043 !                          .
12044 !                          .
12045 ! 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)
12046 !
12047 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12048 ! The structure is same as above.
12049 !
12050 ! DCDS - the derivatives of the side chain vectors in the local spherical
12051 ! andgles alph and omega:
12052 !
12053 ! 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)
12054 ! 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)
12055 !                          .
12056 !                          .
12057 !                          .
12058 ! 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)
12059 !
12060 ! Version of March '95, based on an early version of November '91.
12061 !
12062 !**********************************************************************
12063 !      implicit real*8 (a-h,o-z)
12064 !      include 'DIMENSIONS'
12065 !      include 'COMMON.VAR'
12066 !      include 'COMMON.CHAIN'
12067 !      include 'COMMON.DERIV'
12068 !      include 'COMMON.GEO'
12069 !      include 'COMMON.LOCAL'
12070 !      include 'COMMON.INTERACT'
12071       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12072       real(kind=8),dimension(3,3) :: dp,temp
12073 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12074       real(kind=8),dimension(3) :: xx,xx1
12075 !el local variables
12076       integer :: i,k,l,j,m,ind,ind1,jjj
12077       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12078                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12079                  sint2,xp,yp,xxp,yyp,zzp,dj
12080
12081 !      common /przechowalnia/ fromto
12082       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12083 ! get the position of the jth ijth fragment of the chain coordinate system
12084 ! in the fromto array.
12085 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12086 !
12087 !      maxdim=(nres-1)*(nres-2)/2
12088 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12089 ! calculate the derivatives of transformation matrix elements in theta
12090 !
12091
12092 !el      call flush(iout) !el
12093       do i=1,nres-2
12094         rdt(1,1,i)=-rt(1,2,i)
12095         rdt(1,2,i)= rt(1,1,i)
12096         rdt(1,3,i)= 0.0d0
12097         rdt(2,1,i)=-rt(2,2,i)
12098         rdt(2,2,i)= rt(2,1,i)
12099         rdt(2,3,i)= 0.0d0
12100         rdt(3,1,i)=-rt(3,2,i)
12101         rdt(3,2,i)= rt(3,1,i)
12102         rdt(3,3,i)= 0.0d0
12103       enddo
12104 !
12105 ! derivatives in phi
12106 !
12107       do i=2,nres-2
12108         drt(1,1,i)= 0.0d0
12109         drt(1,2,i)= 0.0d0
12110         drt(1,3,i)= 0.0d0
12111         drt(2,1,i)= rt(3,1,i)
12112         drt(2,2,i)= rt(3,2,i)
12113         drt(2,3,i)= rt(3,3,i)
12114         drt(3,1,i)=-rt(2,1,i)
12115         drt(3,2,i)=-rt(2,2,i)
12116         drt(3,3,i)=-rt(2,3,i)
12117       enddo
12118 !
12119 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12120 !
12121       do i=2,nres-2
12122         ind=indmat(i,i+1)
12123         do k=1,3
12124           do l=1,3
12125             temp(k,l)=rt(k,l,i)
12126           enddo
12127         enddo
12128         do k=1,3
12129           do l=1,3
12130             fromto(k,l,ind)=temp(k,l)
12131           enddo
12132         enddo
12133         do j=i+1,nres-2
12134           ind=indmat(i,j+1)
12135           do k=1,3
12136             do l=1,3
12137               dpkl=0.0d0
12138               do m=1,3
12139                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12140               enddo
12141               dp(k,l)=dpkl
12142               fromto(k,l,ind)=dpkl
12143             enddo
12144           enddo
12145           do k=1,3
12146             do l=1,3
12147               temp(k,l)=dp(k,l)
12148             enddo
12149           enddo
12150         enddo
12151       enddo
12152 !
12153 ! Calculate derivatives.
12154 !
12155       ind1=0
12156       do i=1,nres-2
12157       ind1=ind1+1
12158 !
12159 ! Derivatives of DC(i+1) in theta(i+2)
12160 !
12161         do j=1,3
12162           do k=1,2
12163             dpjk=0.0D0
12164             do l=1,3
12165               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12166             enddo
12167             dp(j,k)=dpjk
12168             prordt(j,k,i)=dp(j,k)
12169           enddo
12170           dp(j,3)=0.0D0
12171           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12172         enddo
12173 !
12174 ! Derivatives of SC(i+1) in theta(i+2)
12175 !
12176         xx1(1)=-0.5D0*xloc(2,i+1)
12177         xx1(2)= 0.5D0*xloc(1,i+1)
12178         do j=1,3
12179           xj=0.0D0
12180           do k=1,2
12181             xj=xj+r(j,k,i)*xx1(k)
12182           enddo
12183           xx(j)=xj
12184         enddo
12185         do j=1,3
12186           rj=0.0D0
12187           do k=1,3
12188             rj=rj+prod(j,k,i)*xx(k)
12189           enddo
12190           dxdv(j,ind1)=rj
12191         enddo
12192 !
12193 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12194 ! than the other off-diagonal derivatives.
12195 !
12196         do j=1,3
12197           dxoiij=0.0D0
12198           do k=1,3
12199             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12200           enddo
12201           dxdv(j,ind1+1)=dxoiij
12202         enddo
12203 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12204 !
12205 ! Derivatives of DC(i+1) in phi(i+2)
12206 !
12207         do j=1,3
12208           do k=1,3
12209             dpjk=0.0
12210             do l=2,3
12211               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12212             enddo
12213             dp(j,k)=dpjk
12214             prodrt(j,k,i)=dp(j,k)
12215           enddo
12216           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12217         enddo
12218 !
12219 ! Derivatives of SC(i+1) in phi(i+2)
12220 !
12221         xx(1)= 0.0D0
12222         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12223         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12224         do j=1,3
12225           rj=0.0D0
12226           do k=2,3
12227             rj=rj+prod(j,k,i)*xx(k)
12228           enddo
12229           dxdv(j+3,ind1)=-rj
12230         enddo
12231 !
12232 ! Derivatives of SC(i+1) in phi(i+3).
12233 !
12234         do j=1,3
12235           dxoiij=0.0D0
12236           do k=1,3
12237             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12238           enddo
12239           dxdv(j+3,ind1+1)=dxoiij
12240         enddo
12241 !
12242 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12243 ! theta(nres) and phi(i+3) thru phi(nres).
12244 !
12245         do j=i+1,nres-2
12246         ind1=ind1+1
12247         ind=indmat(i+1,j+1)
12248 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12249           do k=1,3
12250             do l=1,3
12251               tempkl=0.0D0
12252               do m=1,2
12253                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12254               enddo
12255               temp(k,l)=tempkl
12256             enddo
12257           enddo
12258 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12259 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12260 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12261 ! Derivatives of virtual-bond vectors in theta
12262           do k=1,3
12263             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12264           enddo
12265 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12266 ! Derivatives of SC vectors in theta
12267           do k=1,3
12268             dxoijk=0.0D0
12269             do l=1,3
12270               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12271             enddo
12272             dxdv(k,ind1+1)=dxoijk
12273           enddo
12274 !
12275 !--- Calculate the derivatives in phi
12276 !
12277           do k=1,3
12278             do l=1,3
12279               tempkl=0.0D0
12280               do m=1,3
12281                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12282               enddo
12283               temp(k,l)=tempkl
12284             enddo
12285           enddo
12286           do k=1,3
12287             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12288         enddo
12289           do k=1,3
12290             dxoijk=0.0D0
12291             do l=1,3
12292               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12293             enddo
12294             dxdv(k+3,ind1+1)=dxoijk
12295           enddo
12296         enddo
12297       enddo
12298 !
12299 ! Derivatives in alpha and omega:
12300 !
12301       do i=2,nres-1
12302 !       dsci=dsc(itype(i,1))
12303         dsci=vbld(i+nres)
12304 #ifdef OSF
12305         alphi=alph(i)
12306         omegi=omeg(i)
12307         if(alphi.ne.alphi) alphi=100.0
12308         if(omegi.ne.omegi) omegi=-100.0
12309 #else
12310       alphi=alph(i)
12311       omegi=omeg(i)
12312 #endif
12313 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12314       cosalphi=dcos(alphi)
12315       sinalphi=dsin(alphi)
12316       cosomegi=dcos(omegi)
12317       sinomegi=dsin(omegi)
12318       temp(1,1)=-dsci*sinalphi
12319       temp(2,1)= dsci*cosalphi*cosomegi
12320       temp(3,1)=-dsci*cosalphi*sinomegi
12321       temp(1,2)=0.0D0
12322       temp(2,2)=-dsci*sinalphi*sinomegi
12323       temp(3,2)=-dsci*sinalphi*cosomegi
12324       theta2=pi-0.5D0*theta(i+1)
12325       cost2=dcos(theta2)
12326       sint2=dsin(theta2)
12327       jjj=0
12328 !d      print *,((temp(l,k),l=1,3),k=1,2)
12329         do j=1,2
12330         xp=temp(1,j)
12331         yp=temp(2,j)
12332         xxp= xp*cost2+yp*sint2
12333         yyp=-xp*sint2+yp*cost2
12334         zzp=temp(3,j)
12335         xx(1)=xxp
12336         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12337         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12338         do k=1,3
12339           dj=0.0D0
12340           do l=1,3
12341             dj=dj+prod(k,l,i-1)*xx(l)
12342             enddo
12343           dxds(jjj+k,i)=dj
12344           enddo
12345         jjj=jjj+3
12346       enddo
12347       enddo
12348       return
12349       end subroutine cartder
12350 !-----------------------------------------------------------------------------
12351 ! checkder_p.F
12352 !-----------------------------------------------------------------------------
12353       subroutine check_cartgrad
12354 ! Check the gradient of Cartesian coordinates in internal coordinates.
12355 !      implicit real*8 (a-h,o-z)
12356 !      include 'DIMENSIONS'
12357 !      include 'COMMON.IOUNITS'
12358 !      include 'COMMON.VAR'
12359 !      include 'COMMON.CHAIN'
12360 !      include 'COMMON.GEO'
12361 !      include 'COMMON.LOCAL'
12362 !      include 'COMMON.DERIV'
12363       real(kind=8),dimension(6,nres) :: temp
12364       real(kind=8),dimension(3) :: xx,gg
12365       integer :: i,k,j,ii
12366       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12367 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12368 !
12369 ! Check the gradient of the virtual-bond and SC vectors in the internal
12370 ! coordinates.
12371 !
12372       aincr=1.0d-6
12373       aincr2=5.0d-7
12374       call cartder
12375       write (iout,'(a)') '**************** dx/dalpha'
12376       write (iout,'(a)')
12377       do i=2,nres-1
12378       alphi=alph(i)
12379       alph(i)=alph(i)+aincr
12380       do k=1,3
12381         temp(k,i)=dc(k,nres+i)
12382         enddo
12383       call chainbuild
12384       do k=1,3
12385         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12386         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12387         enddo
12388         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12389         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12390         write (iout,'(a)')
12391       alph(i)=alphi
12392       call chainbuild
12393       enddo
12394       write (iout,'(a)')
12395       write (iout,'(a)') '**************** dx/domega'
12396       write (iout,'(a)')
12397       do i=2,nres-1
12398       omegi=omeg(i)
12399       omeg(i)=omeg(i)+aincr
12400       do k=1,3
12401         temp(k,i)=dc(k,nres+i)
12402         enddo
12403       call chainbuild
12404       do k=1,3
12405           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12406           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12407                 (aincr*dabs(dxds(k+3,i))+aincr))
12408         enddo
12409         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12410             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12411         write (iout,'(a)')
12412       omeg(i)=omegi
12413       call chainbuild
12414       enddo
12415       write (iout,'(a)')
12416       write (iout,'(a)') '**************** dx/dtheta'
12417       write (iout,'(a)')
12418       do i=3,nres
12419       theti=theta(i)
12420         theta(i)=theta(i)+aincr
12421         do j=i-1,nres-1
12422           do k=1,3
12423             temp(k,j)=dc(k,nres+j)
12424           enddo
12425         enddo
12426         call chainbuild
12427         do j=i-1,nres-1
12428         ii = indmat(i-2,j)
12429 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12430         do k=1,3
12431           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12432           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12433                   (aincr*dabs(dxdv(k,ii))+aincr))
12434           enddo
12435           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12436               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12437           write(iout,'(a)')
12438         enddo
12439         write (iout,'(a)')
12440         theta(i)=theti
12441         call chainbuild
12442       enddo
12443       write (iout,'(a)') '***************** dx/dphi'
12444       write (iout,'(a)')
12445       do i=4,nres
12446         phi(i)=phi(i)+aincr
12447         do j=i-1,nres-1
12448           do k=1,3
12449             temp(k,j)=dc(k,nres+j)
12450           enddo
12451         enddo
12452         call chainbuild
12453         do j=i-1,nres-1
12454         ii = indmat(i-2,j)
12455 !         print *,'ii=',ii
12456         do k=1,3
12457           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12458             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12459                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12460           enddo
12461           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12462               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12463           write(iout,'(a)')
12464         enddo
12465         phi(i)=phi(i)-aincr
12466         call chainbuild
12467       enddo
12468       write (iout,'(a)') '****************** ddc/dtheta'
12469       do i=1,nres-2
12470         thet=theta(i+2)
12471         theta(i+2)=thet+aincr
12472         do j=i,nres
12473           do k=1,3
12474             temp(k,j)=dc(k,j)
12475           enddo
12476         enddo
12477         call chainbuild
12478         do j=i+1,nres-1
12479         ii = indmat(i,j)
12480 !         print *,'ii=',ii
12481         do k=1,3
12482           gg(k)=(dc(k,j)-temp(k,j))/aincr
12483           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12484                  (aincr*dabs(dcdv(k,ii))+aincr))
12485           enddo
12486           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12487                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12488         write (iout,'(a)')
12489         enddo
12490         do j=1,nres
12491           do k=1,3
12492             dc(k,j)=temp(k,j)
12493           enddo
12494         enddo
12495         theta(i+2)=thet
12496       enddo
12497       write (iout,'(a)') '******************* ddc/dphi'
12498       do i=1,nres-3
12499         phii=phi(i+3)
12500         phi(i+3)=phii+aincr
12501         do j=1,nres
12502           do k=1,3
12503             temp(k,j)=dc(k,j)
12504           enddo
12505         enddo
12506         call chainbuild
12507         do j=i+2,nres-1
12508         ii = indmat(i+1,j)
12509 !         print *,'ii=',ii
12510         do k=1,3
12511           gg(k)=(dc(k,j)-temp(k,j))/aincr
12512             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12513                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12514           enddo
12515           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12516                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12517         write (iout,'(a)')
12518         enddo
12519         do j=1,nres
12520           do k=1,3
12521             dc(k,j)=temp(k,j)
12522           enddo
12523         enddo
12524         phi(i+3)=phii
12525       enddo
12526       return
12527       end subroutine check_cartgrad
12528 !-----------------------------------------------------------------------------
12529       subroutine check_ecart
12530 ! Check the gradient of the energy in Cartesian coordinates.
12531 !     implicit real*8 (a-h,o-z)
12532 !     include 'DIMENSIONS'
12533 !     include 'COMMON.CHAIN'
12534 !     include 'COMMON.DERIV'
12535 !     include 'COMMON.IOUNITS'
12536 !     include 'COMMON.VAR'
12537 !     include 'COMMON.CONTACTS'
12538       use comm_srutu
12539 !el      integer :: icall
12540 !el      common /srutu/ icall
12541       real(kind=8),dimension(6) :: ggg
12542       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12543       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12544       real(kind=8),dimension(6,nres) :: grad_s
12545       real(kind=8),dimension(0:n_ene) :: energia,energia1
12546       integer :: uiparm(1)
12547       real(kind=8) :: urparm(1)
12548 !EL      external fdum
12549       integer :: nf,i,j,k
12550       real(kind=8) :: aincr,etot,etot1
12551       icg=1
12552       nf=0
12553       nfl=0
12554       call zerograd
12555       aincr=1.0D-5
12556       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12557       nf=0
12558       icall=0
12559       call geom_to_var(nvar,x)
12560       call etotal(energia)
12561       etot=energia(0)
12562 !el      call enerprint(energia)
12563       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12564       icall =1
12565       do i=1,nres
12566         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12567       enddo
12568       do i=1,nres
12569       do j=1,3
12570         grad_s(j,i)=gradc(j,i,icg)
12571         grad_s(j+3,i)=gradx(j,i,icg)
12572         enddo
12573       enddo
12574       call flush(iout)
12575       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12576       do i=1,nres
12577         do j=1,3
12578         xx(j)=c(j,i+nres)
12579         ddc(j)=dc(j,i)
12580         ddx(j)=dc(j,i+nres)
12581         enddo
12582       do j=1,3
12583         dc(j,i)=dc(j,i)+aincr
12584         do k=i+1,nres
12585           c(j,k)=c(j,k)+aincr
12586           c(j,k+nres)=c(j,k+nres)+aincr
12587           enddo
12588           call zerograd
12589           call etotal(energia1)
12590           etot1=energia1(0)
12591         ggg(j)=(etot1-etot)/aincr
12592         dc(j,i)=ddc(j)
12593         do k=i+1,nres
12594           c(j,k)=c(j,k)-aincr
12595           c(j,k+nres)=c(j,k+nres)-aincr
12596           enddo
12597         enddo
12598       do j=1,3
12599         c(j,i+nres)=c(j,i+nres)+aincr
12600         dc(j,i+nres)=dc(j,i+nres)+aincr
12601           call zerograd
12602           call etotal(energia1)
12603           etot1=energia1(0)
12604         ggg(j+3)=(etot1-etot)/aincr
12605         c(j,i+nres)=xx(j)
12606         dc(j,i+nres)=ddx(j)
12607         enddo
12608       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12609          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12610       enddo
12611       return
12612       end subroutine check_ecart
12613 #ifdef CARGRAD
12614 !-----------------------------------------------------------------------------
12615       subroutine check_ecartint
12616 ! Check the gradient of the energy in Cartesian coordinates.
12617       use io_base, only: intout
12618 !      implicit real*8 (a-h,o-z)
12619 !      include 'DIMENSIONS'
12620 !      include 'COMMON.CONTROL'
12621 !      include 'COMMON.CHAIN'
12622 !      include 'COMMON.DERIV'
12623 !      include 'COMMON.IOUNITS'
12624 !      include 'COMMON.VAR'
12625 !      include 'COMMON.CONTACTS'
12626 !      include 'COMMON.MD'
12627 !      include 'COMMON.LOCAL'
12628 !      include 'COMMON.SPLITELE'
12629       use comm_srutu
12630 !el      integer :: icall
12631 !el      common /srutu/ icall
12632       real(kind=8),dimension(6) :: ggg,ggg1
12633       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12634       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12635       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12636       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12637       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12638       real(kind=8),dimension(0:n_ene) :: energia,energia1
12639       integer :: uiparm(1)
12640       real(kind=8) :: urparm(1)
12641 !EL      external fdum
12642       integer :: i,j,k,nf
12643       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12644                    etot21,etot22
12645       r_cut=2.0d0
12646       rlambd=0.3d0
12647       icg=1
12648       nf=0
12649       nfl=0
12650       call intout
12651 !      call intcartderiv
12652 !      call checkintcartgrad
12653       call zerograd
12654       aincr=1.0D-5
12655       write(iout,*) 'Calling CHECK_ECARTINT.'
12656       nf=0
12657       icall=0
12658       call geom_to_var(nvar,x)
12659       write (iout,*) "split_ene ",split_ene
12660       call flush(iout)
12661       if (.not.split_ene) then
12662         call zerograd
12663         call etotal(energia)
12664         etot=energia(0)
12665         call cartgrad
12666         icall =1
12667         do i=1,nres
12668           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12669         enddo
12670         do j=1,3
12671           grad_s(j,0)=gcart(j,0)
12672         enddo
12673         do i=1,nres
12674           do j=1,3
12675             grad_s(j,i)=gcart(j,i)
12676             grad_s(j+3,i)=gxcart(j,i)
12677           enddo
12678         enddo
12679       else
12680 !- split gradient check
12681         call zerograd
12682         call etotal_long(energia)
12683 !el        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_s(j,0)=gcart(j,0)
12692         enddo
12693         do i=1,nres
12694           do j=1,3
12695             grad_s(j,i)=gcart(j,i)
12696             grad_s(j+3,i)=gxcart(j,i)
12697           enddo
12698         enddo
12699         call zerograd
12700         call etotal_short(energia)
12701         call enerprint(energia)
12702         call cartgrad
12703         icall =1
12704         do i=1,nres
12705           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12706           (gxcart(j,i),j=1,3)
12707         enddo
12708         do j=1,3
12709           grad_s1(j,0)=gcart(j,0)
12710         enddo
12711         do i=1,nres
12712           do j=1,3
12713             grad_s1(j,i)=gcart(j,i)
12714             grad_s1(j+3,i)=gxcart(j,i)
12715           enddo
12716         enddo
12717       endif
12718       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12719 !      do i=1,nres
12720       do i=nnt,nct
12721         do j=1,3
12722           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12723           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12724         ddc(j)=c(j,i)
12725         ddx(j)=c(j,i+nres)
12726           dcnorm_safe1(j)=dc_norm(j,i-1)
12727           dcnorm_safe2(j)=dc_norm(j,i)
12728           dxnorm_safe(j)=dc_norm(j,i+nres)
12729         enddo
12730       do j=1,3
12731         c(j,i)=ddc(j)+aincr
12732           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12733           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12734           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12735           dc(j,i)=c(j,i+1)-c(j,i)
12736           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12737           call int_from_cart1(.false.)
12738           if (.not.split_ene) then
12739            call zerograd
12740             call etotal(energia1)
12741             etot1=energia1(0)
12742             write (iout,*) "ij",i,j," etot1",etot1
12743           else
12744 !- split gradient
12745             call etotal_long(energia1)
12746             etot11=energia1(0)
12747             call etotal_short(energia1)
12748             etot12=energia1(0)
12749           endif
12750 !- end split gradient
12751 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12752         c(j,i)=ddc(j)-aincr
12753           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12754           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12755           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12756           dc(j,i)=c(j,i+1)-c(j,i)
12757           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12758           call int_from_cart1(.false.)
12759           if (.not.split_ene) then
12760             call zerograd
12761             call etotal(energia1)
12762             etot2=energia1(0)
12763             write (iout,*) "ij",i,j," etot2",etot2
12764           ggg(j)=(etot1-etot2)/(2*aincr)
12765           else
12766 !- split gradient
12767             call etotal_long(energia1)
12768             etot21=energia1(0)
12769           ggg(j)=(etot11-etot21)/(2*aincr)
12770             call etotal_short(energia1)
12771             etot22=energia1(0)
12772           ggg1(j)=(etot12-etot22)/(2*aincr)
12773 !- end split gradient
12774 !            write (iout,*) "etot21",etot21," etot22",etot22
12775           endif
12776 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12777         c(j,i)=ddc(j)
12778           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12779           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12780           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12781           dc(j,i)=c(j,i+1)-c(j,i)
12782           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12783           dc_norm(j,i-1)=dcnorm_safe1(j)
12784           dc_norm(j,i)=dcnorm_safe2(j)
12785           dc_norm(j,i+nres)=dxnorm_safe(j)
12786         enddo
12787       do j=1,3
12788         c(j,i+nres)=ddx(j)+aincr
12789           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12790           call int_from_cart1(.false.)
12791           if (.not.split_ene) then
12792             call zerograd
12793             call etotal(energia1)
12794             etot1=energia1(0)
12795           else
12796 !- split gradient
12797             call etotal_long(energia1)
12798             etot11=energia1(0)
12799             call etotal_short(energia1)
12800             etot12=energia1(0)
12801           endif
12802 !- end split gradient
12803         c(j,i+nres)=ddx(j)-aincr
12804           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12805           call int_from_cart1(.false.)
12806           if (.not.split_ene) then
12807            call zerograd
12808            call etotal(energia1)
12809             etot2=energia1(0)
12810           ggg(j+3)=(etot1-etot2)/(2*aincr)
12811           else
12812 !- split gradient
12813             call etotal_long(energia1)
12814             etot21=energia1(0)
12815           ggg(j+3)=(etot11-etot21)/(2*aincr)
12816             call etotal_short(energia1)
12817             etot22=energia1(0)
12818           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12819 !- end split gradient
12820           endif
12821 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12822         c(j,i+nres)=ddx(j)
12823           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12824           dc_norm(j,i+nres)=dxnorm_safe(j)
12825           call int_from_cart1(.false.)
12826         enddo
12827       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12828          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12829         if (split_ene) then
12830           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12831          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12832          k=1,6)
12833          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12834          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12835          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12836         endif
12837       enddo
12838       return
12839       end subroutine check_ecartint
12840 #else
12841 !-----------------------------------------------------------------------------
12842       subroutine check_ecartint
12843 ! Check the gradient of the energy in Cartesian coordinates.
12844       use io_base, only: intout
12845 !      implicit real*8 (a-h,o-z)
12846 !      include 'DIMENSIONS'
12847 !      include 'COMMON.CONTROL'
12848 !      include 'COMMON.CHAIN'
12849 !      include 'COMMON.DERIV'
12850 !      include 'COMMON.IOUNITS'
12851 !      include 'COMMON.VAR'
12852 !      include 'COMMON.CONTACTS'
12853 !      include 'COMMON.MD'
12854 !      include 'COMMON.LOCAL'
12855 !      include 'COMMON.SPLITELE'
12856       use comm_srutu
12857 !el      integer :: icall
12858 !el      common /srutu/ icall
12859       real(kind=8),dimension(6) :: ggg,ggg1
12860       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12861       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12862       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12863       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12864       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12865       real(kind=8),dimension(0:n_ene) :: energia,energia1
12866       integer :: uiparm(1)
12867       real(kind=8) :: urparm(1)
12868 !EL      external fdum
12869       integer :: i,j,k,nf
12870       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12871                    etot21,etot22
12872       r_cut=2.0d0
12873       rlambd=0.3d0
12874       icg=1
12875       nf=0
12876       nfl=0
12877       call intout
12878 !      call intcartderiv
12879 !      call checkintcartgrad
12880       call zerograd
12881       aincr=1.0D-6
12882       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12883       nf=0
12884       icall=0
12885       call geom_to_var(nvar,x)
12886       if (.not.split_ene) then
12887         call etotal(energia)
12888         etot=energia(0)
12889 !el        call enerprint(energia)
12890         call cartgrad
12891         icall =1
12892         do i=1,nres
12893           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12894         enddo
12895         do j=1,3
12896           grad_s(j,0)=gcart(j,0)
12897         enddo
12898         do i=1,nres
12899           do j=1,3
12900             grad_s(j,i)=gcart(j,i)
12901 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12902
12903 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12904             grad_s(j+3,i)=gxcart(j,i)
12905           enddo
12906         enddo
12907       else
12908 !- split gradient check
12909         call zerograd
12910         call etotal_long(energia)
12911 !el        call enerprint(energia)
12912         call cartgrad
12913         icall =1
12914         do i=1,nres
12915           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12916           (gxcart(j,i),j=1,3)
12917         enddo
12918         do j=1,3
12919           grad_s(j,0)=gcart(j,0)
12920         enddo
12921         do i=1,nres
12922           do j=1,3
12923             grad_s(j,i)=gcart(j,i)
12924 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12925             grad_s(j+3,i)=gxcart(j,i)
12926           enddo
12927         enddo
12928         call zerograd
12929         call etotal_short(energia)
12930 !el        call enerprint(energia)
12931         call cartgrad
12932         icall =1
12933         do i=1,nres
12934           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12935           (gxcart(j,i),j=1,3)
12936         enddo
12937         do j=1,3
12938           grad_s1(j,0)=gcart(j,0)
12939         enddo
12940         do i=1,nres
12941           do j=1,3
12942             grad_s1(j,i)=gcart(j,i)
12943             grad_s1(j+3,i)=gxcart(j,i)
12944           enddo
12945         enddo
12946       endif
12947       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12948       do i=0,nres
12949         do j=1,3
12950         xx(j)=c(j,i+nres)
12951         ddc(j)=dc(j,i)
12952         ddx(j)=dc(j,i+nres)
12953           do k=1,3
12954             dcnorm_safe(k)=dc_norm(k,i)
12955             dxnorm_safe(k)=dc_norm(k,i+nres)
12956           enddo
12957         enddo
12958       do j=1,3
12959         dc(j,i)=ddc(j)+aincr
12960           call chainbuild_cart
12961 #ifdef MPI
12962 ! Broadcast the order to compute internal coordinates to the slaves.
12963 !          if (nfgtasks.gt.1)
12964 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12965 #endif
12966 !          call int_from_cart1(.false.)
12967           if (.not.split_ene) then
12968            call zerograd
12969             call etotal(energia1)
12970             etot1=energia1(0)
12971 !            call enerprint(energia1)
12972           else
12973 !- split gradient
12974             call etotal_long(energia1)
12975             etot11=energia1(0)
12976             call etotal_short(energia1)
12977             etot12=energia1(0)
12978 !            write (iout,*) "etot11",etot11," etot12",etot12
12979           endif
12980 !- end split gradient
12981 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12982         dc(j,i)=ddc(j)-aincr
12983           call chainbuild_cart
12984 !          call int_from_cart1(.false.)
12985           if (.not.split_ene) then
12986                   call zerograd
12987             call etotal(energia1)
12988             etot2=energia1(0)
12989           ggg(j)=(etot1-etot2)/(2*aincr)
12990           else
12991 !- split gradient
12992             call etotal_long(energia1)
12993             etot21=energia1(0)
12994           ggg(j)=(etot11-etot21)/(2*aincr)
12995             call etotal_short(energia1)
12996             etot22=energia1(0)
12997           ggg1(j)=(etot12-etot22)/(2*aincr)
12998 !- end split gradient
12999 !            write (iout,*) "etot21",etot21," etot22",etot22
13000           endif
13001 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13002         dc(j,i)=ddc(j)
13003           call chainbuild_cart
13004         enddo
13005       do j=1,3
13006         dc(j,i+nres)=ddx(j)+aincr
13007           call chainbuild_cart
13008 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13009 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13010 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13011 !          write (iout,*) "dxnormnorm",dsqrt(
13012 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13013 !          write (iout,*) "dxnormnormsafe",dsqrt(
13014 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13015 !          write (iout,*)
13016           if (.not.split_ene) then
13017             call zerograd
13018             call etotal(energia1)
13019             etot1=energia1(0)
13020           else
13021 !- split gradient
13022             call etotal_long(energia1)
13023             etot11=energia1(0)
13024             call etotal_short(energia1)
13025             etot12=energia1(0)
13026           endif
13027 !- end split gradient
13028 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13029         dc(j,i+nres)=ddx(j)-aincr
13030           call chainbuild_cart
13031 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13032 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13033 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13034 !          write (iout,*)
13035 !          write (iout,*) "dxnormnorm",dsqrt(
13036 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13037 !          write (iout,*) "dxnormnormsafe",dsqrt(
13038 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13039           if (.not.split_ene) then
13040             call zerograd
13041             call etotal(energia1)
13042             etot2=energia1(0)
13043           ggg(j+3)=(etot1-etot2)/(2*aincr)
13044           else
13045 !- split gradient
13046             call etotal_long(energia1)
13047             etot21=energia1(0)
13048           ggg(j+3)=(etot11-etot21)/(2*aincr)
13049             call etotal_short(energia1)
13050             etot22=energia1(0)
13051           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13052 !- end split gradient
13053           endif
13054 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13055         dc(j,i+nres)=ddx(j)
13056           call chainbuild_cart
13057         enddo
13058       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13059          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13060         if (split_ene) then
13061           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13062          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13063          k=1,6)
13064          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13065          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13066          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13067         endif
13068       enddo
13069       return
13070       end subroutine check_ecartint
13071 #endif
13072 !-----------------------------------------------------------------------------
13073       subroutine check_eint
13074 ! Check the gradient of energy in internal coordinates.
13075 !      implicit real*8 (a-h,o-z)
13076 !      include 'DIMENSIONS'
13077 !      include 'COMMON.CHAIN'
13078 !      include 'COMMON.DERIV'
13079 !      include 'COMMON.IOUNITS'
13080 !      include 'COMMON.VAR'
13081 !      include 'COMMON.GEO'
13082       use comm_srutu
13083 !el      integer :: icall
13084 !el      common /srutu/ icall
13085       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13086       integer :: uiparm(1)
13087       real(kind=8) :: urparm(1)
13088       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13089       character(len=6) :: key
13090 !EL      external fdum
13091       integer :: i,ii,nf
13092       real(kind=8) :: xi,aincr,etot,etot1,etot2
13093       call zerograd
13094       aincr=1.0D-7
13095       print '(a)','Calling CHECK_INT.'
13096       nf=0
13097       nfl=0
13098       icg=1
13099       call geom_to_var(nvar,x)
13100       call var_to_geom(nvar,x)
13101       call chainbuild
13102       icall=1
13103 !      print *,'ICG=',ICG
13104       call etotal(energia)
13105       etot = energia(0)
13106 !el      call enerprint(energia)
13107 !      print *,'ICG=',ICG
13108 #ifdef MPL
13109       if (MyID.ne.BossID) then
13110         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13111         nf=x(nvar+1)
13112         nfl=x(nvar+2)
13113         icg=x(nvar+3)
13114       endif
13115 #endif
13116       nf=1
13117       nfl=3
13118 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13119       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13120 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13121       icall=1
13122       do i=1,nvar
13123         xi=x(i)
13124         x(i)=xi-0.5D0*aincr
13125         call var_to_geom(nvar,x)
13126         call chainbuild
13127         call etotal(energia1)
13128         etot1=energia1(0)
13129         x(i)=xi+0.5D0*aincr
13130         call var_to_geom(nvar,x)
13131         call chainbuild
13132         call etotal(energia2)
13133         etot2=energia2(0)
13134         gg(i)=(etot2-etot1)/aincr
13135         write (iout,*) i,etot1,etot2
13136         x(i)=xi
13137       enddo
13138       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13139           '     RelDiff*100% '
13140       do i=1,nvar
13141         if (i.le.nphi) then
13142           ii=i
13143           key = ' phi'
13144         else if (i.le.nphi+ntheta) then
13145           ii=i-nphi
13146           key=' theta'
13147         else if (i.le.nphi+ntheta+nside) then
13148            ii=i-(nphi+ntheta)
13149            key=' alpha'
13150         else
13151            ii=i-(nphi+ntheta+nside)
13152            key=' omega'
13153         endif
13154         write (iout,'(i3,a,i3,3(1pd16.6))') &
13155        i,key,ii,gg(i),gana(i),&
13156        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13157       enddo
13158       return
13159       end subroutine check_eint
13160 !-----------------------------------------------------------------------------
13161 ! econstr_local.F
13162 !-----------------------------------------------------------------------------
13163       subroutine Econstr_back
13164 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13165 !      implicit real*8 (a-h,o-z)
13166 !      include 'DIMENSIONS'
13167 !      include 'COMMON.CONTROL'
13168 !      include 'COMMON.VAR'
13169 !      include 'COMMON.MD'
13170       use MD_data
13171 !#ifndef LANG0
13172 !      include 'COMMON.LANGEVIN'
13173 !#else
13174 !      include 'COMMON.LANGEVIN.lang0'
13175 !#endif
13176 !      include 'COMMON.CHAIN'
13177 !      include 'COMMON.DERIV'
13178 !      include 'COMMON.GEO'
13179 !      include 'COMMON.LOCAL'
13180 !      include 'COMMON.INTERACT'
13181 !      include 'COMMON.IOUNITS'
13182 !      include 'COMMON.NAMES'
13183 !      include 'COMMON.TIME1'
13184       integer :: i,j,ii,k
13185       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13186
13187       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13188       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13189       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13190
13191       Uconst_back=0.0d0
13192       do i=1,nres
13193         dutheta(i)=0.0d0
13194         dugamma(i)=0.0d0
13195         do j=1,3
13196           duscdiff(j,i)=0.0d0
13197           duscdiffx(j,i)=0.0d0
13198         enddo
13199       enddo
13200       do i=1,nfrag_back
13201         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13202 !
13203 ! Deviations from theta angles
13204 !
13205         utheta_i=0.0d0
13206         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13207           dtheta_i=theta(j)-thetaref(j)
13208           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13209           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13210         enddo
13211         utheta(i)=utheta_i/(ii-1)
13212 !
13213 ! Deviations from gamma angles
13214 !
13215         ugamma_i=0.0d0
13216         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13217           dgamma_i=pinorm(phi(j)-phiref(j))
13218 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13219           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13220           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13221 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13222         enddo
13223         ugamma(i)=ugamma_i/(ii-2)
13224 !
13225 ! Deviations from local SC geometry
13226 !
13227         uscdiff(i)=0.0d0
13228         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13229           dxx=xxtab(j)-xxref(j)
13230           dyy=yytab(j)-yyref(j)
13231           dzz=zztab(j)-zzref(j)
13232           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13233           do k=1,3
13234             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13235              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13236              (ii-1)
13237             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13238              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13239              (ii-1)
13240             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13241            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13242             /(ii-1)
13243           enddo
13244 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13245 !     &      xxref(j),yyref(j),zzref(j)
13246         enddo
13247         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13248 !        write (iout,*) i," uscdiff",uscdiff(i)
13249 !
13250 ! Put together deviations from local geometry
13251 !
13252         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13253           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13254 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13255 !     &   " uconst_back",uconst_back
13256         utheta(i)=dsqrt(utheta(i))
13257         ugamma(i)=dsqrt(ugamma(i))
13258         uscdiff(i)=dsqrt(uscdiff(i))
13259       enddo
13260       return
13261       end subroutine Econstr_back
13262 !-----------------------------------------------------------------------------
13263 ! energy_p_new-sep_barrier.F
13264 !-----------------------------------------------------------------------------
13265       real(kind=8) function sscale(r)
13266 !      include "COMMON.SPLITELE"
13267       real(kind=8) :: r,gamm
13268       if(r.lt.r_cut-rlamb) then
13269         sscale=1.0d0
13270       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13271         gamm=(r-(r_cut-rlamb))/rlamb
13272         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13273       else
13274         sscale=0d0
13275       endif
13276       return
13277       end function sscale
13278       real(kind=8) function sscale_grad(r)
13279 !      include "COMMON.SPLITELE"
13280       real(kind=8) :: r,gamm
13281       if(r.lt.r_cut-rlamb) then
13282         sscale_grad=0.0d0
13283       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13284         gamm=(r-(r_cut-rlamb))/rlamb
13285         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13286       else
13287         sscale_grad=0d0
13288       endif
13289       return
13290       end function sscale_grad
13291
13292 !!!!!!!!!! PBCSCALE
13293       real(kind=8) function sscale_ele(r)
13294 !      include "COMMON.SPLITELE"
13295       real(kind=8) :: r,gamm
13296       if(r.lt.r_cut_ele-rlamb_ele) then
13297         sscale_ele=1.0d0
13298       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13299         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13300         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13301       else
13302         sscale_ele=0d0
13303       endif
13304       return
13305       end function sscale_ele
13306
13307       real(kind=8)  function sscagrad_ele(r)
13308       real(kind=8) :: r,gamm
13309 !      include "COMMON.SPLITELE"
13310       if(r.lt.r_cut_ele-rlamb_ele) then
13311         sscagrad_ele=0.0d0
13312       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13313         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13314         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13315       else
13316         sscagrad_ele=0.0d0
13317       endif
13318       return
13319       end function sscagrad_ele
13320       real(kind=8) function sscalelip(r)
13321       real(kind=8) r,gamm
13322         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13323       return
13324       end function sscalelip
13325 !C-----------------------------------------------------------------------
13326       real(kind=8) function sscagradlip(r)
13327       real(kind=8) r,gamm
13328         sscagradlip=r*(6.0d0*r-6.0d0)
13329       return
13330       end function sscagradlip
13331
13332 !!!!!!!!!!!!!!!
13333 !-----------------------------------------------------------------------------
13334       subroutine elj_long(evdw)
13335 !
13336 ! This subroutine calculates the interaction energy of nonbonded side chains
13337 ! assuming the LJ potential of interaction.
13338 !
13339 !      implicit real*8 (a-h,o-z)
13340 !      include 'DIMENSIONS'
13341 !      include 'COMMON.GEO'
13342 !      include 'COMMON.VAR'
13343 !      include 'COMMON.LOCAL'
13344 !      include 'COMMON.CHAIN'
13345 !      include 'COMMON.DERIV'
13346 !      include 'COMMON.INTERACT'
13347 !      include 'COMMON.TORSION'
13348 !      include 'COMMON.SBRIDGE'
13349 !      include 'COMMON.NAMES'
13350 !      include 'COMMON.IOUNITS'
13351 !      include 'COMMON.CONTACTS'
13352       real(kind=8),parameter :: accur=1.0d-10
13353       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13354 !el local variables
13355       integer :: i,iint,j,k,itypi,itypi1,itypj
13356       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13357       real(kind=8) :: e1,e2,evdwij,evdw
13358 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13359       evdw=0.0D0
13360       do i=iatsc_s,iatsc_e
13361         itypi=itype(i,1)
13362         if (itypi.eq.ntyp1) cycle
13363         itypi1=itype(i+1,1)
13364         xi=c(1,nres+i)
13365         yi=c(2,nres+i)
13366         zi=c(3,nres+i)
13367 !
13368 ! Calculate SC interaction energy.
13369 !
13370         do iint=1,nint_gr(i)
13371 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13372 !d   &                  'iend=',iend(i,iint)
13373           do j=istart(i,iint),iend(i,iint)
13374             itypj=itype(j,1)
13375             if (itypj.eq.ntyp1) cycle
13376             xj=c(1,nres+j)-xi
13377             yj=c(2,nres+j)-yi
13378             zj=c(3,nres+j)-zi
13379             rij=xj*xj+yj*yj+zj*zj
13380             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13381             if (sss.lt.1.0d0) then
13382               rrij=1.0D0/rij
13383               eps0ij=eps(itypi,itypj)
13384               fac=rrij**expon2
13385               e1=fac*fac*aa_aq(itypi,itypj)
13386               e2=fac*bb_aq(itypi,itypj)
13387               evdwij=e1+e2
13388               evdw=evdw+(1.0d0-sss)*evdwij
13389 !
13390 ! Calculate the components of the gradient in DC and X
13391 !
13392               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13393               gg(1)=xj*fac
13394               gg(2)=yj*fac
13395               gg(3)=zj*fac
13396               do k=1,3
13397                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13398                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13399                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13400                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13401               enddo
13402             endif
13403           enddo      ! j
13404         enddo        ! iint
13405       enddo          ! i
13406       do i=1,nct
13407         do j=1,3
13408           gvdwc(j,i)=expon*gvdwc(j,i)
13409           gvdwx(j,i)=expon*gvdwx(j,i)
13410         enddo
13411       enddo
13412 !******************************************************************************
13413 !
13414 !                              N O T E !!!
13415 !
13416 ! To save time, the factor of EXPON has been extracted from ALL components
13417 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13418 ! use!
13419 !
13420 !******************************************************************************
13421       return
13422       end subroutine elj_long
13423 !-----------------------------------------------------------------------------
13424       subroutine elj_short(evdw)
13425 !
13426 ! This subroutine calculates the interaction energy of nonbonded side chains
13427 ! assuming the LJ potential of interaction.
13428 !
13429 !      implicit real*8 (a-h,o-z)
13430 !      include 'DIMENSIONS'
13431 !      include 'COMMON.GEO'
13432 !      include 'COMMON.VAR'
13433 !      include 'COMMON.LOCAL'
13434 !      include 'COMMON.CHAIN'
13435 !      include 'COMMON.DERIV'
13436 !      include 'COMMON.INTERACT'
13437 !      include 'COMMON.TORSION'
13438 !      include 'COMMON.SBRIDGE'
13439 !      include 'COMMON.NAMES'
13440 !      include 'COMMON.IOUNITS'
13441 !      include 'COMMON.CONTACTS'
13442       real(kind=8),parameter :: accur=1.0d-10
13443       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13444 !el local variables
13445       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13446       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13447       real(kind=8) :: e1,e2,evdwij,evdw
13448 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13449       evdw=0.0D0
13450       do i=iatsc_s,iatsc_e
13451         itypi=itype(i,1)
13452         if (itypi.eq.ntyp1) cycle
13453         itypi1=itype(i+1,1)
13454         xi=c(1,nres+i)
13455         yi=c(2,nres+i)
13456         zi=c(3,nres+i)
13457 ! Change 12/1/95
13458         num_conti=0
13459 !
13460 ! Calculate SC interaction energy.
13461 !
13462         do iint=1,nint_gr(i)
13463 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13464 !d   &                  'iend=',iend(i,iint)
13465           do j=istart(i,iint),iend(i,iint)
13466             itypj=itype(j,1)
13467             if (itypj.eq.ntyp1) cycle
13468             xj=c(1,nres+j)-xi
13469             yj=c(2,nres+j)-yi
13470             zj=c(3,nres+j)-zi
13471 ! Change 12/1/95 to calculate four-body interactions
13472             rij=xj*xj+yj*yj+zj*zj
13473             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13474             if (sss.gt.0.0d0) then
13475               rrij=1.0D0/rij
13476               eps0ij=eps(itypi,itypj)
13477               fac=rrij**expon2
13478               e1=fac*fac*aa_aq(itypi,itypj)
13479               e2=fac*bb_aq(itypi,itypj)
13480               evdwij=e1+e2
13481               evdw=evdw+sss*evdwij
13482 !
13483 ! Calculate the components of the gradient in DC and X
13484 !
13485               fac=-rrij*(e1+evdwij)*sss
13486               gg(1)=xj*fac
13487               gg(2)=yj*fac
13488               gg(3)=zj*fac
13489               do k=1,3
13490                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13491                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13492                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13493                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13494               enddo
13495             endif
13496           enddo      ! j
13497         enddo        ! iint
13498       enddo          ! i
13499       do i=1,nct
13500         do j=1,3
13501           gvdwc(j,i)=expon*gvdwc(j,i)
13502           gvdwx(j,i)=expon*gvdwx(j,i)
13503         enddo
13504       enddo
13505 !******************************************************************************
13506 !
13507 !                              N O T E !!!
13508 !
13509 ! To save time, the factor of EXPON has been extracted from ALL components
13510 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13511 ! use!
13512 !
13513 !******************************************************************************
13514       return
13515       end subroutine elj_short
13516 !-----------------------------------------------------------------------------
13517       subroutine eljk_long(evdw)
13518 !
13519 ! This subroutine calculates the interaction energy of nonbonded side chains
13520 ! assuming the LJK potential of interaction.
13521 !
13522 !      implicit real*8 (a-h,o-z)
13523 !      include 'DIMENSIONS'
13524 !      include 'COMMON.GEO'
13525 !      include 'COMMON.VAR'
13526 !      include 'COMMON.LOCAL'
13527 !      include 'COMMON.CHAIN'
13528 !      include 'COMMON.DERIV'
13529 !      include 'COMMON.INTERACT'
13530 !      include 'COMMON.IOUNITS'
13531 !      include 'COMMON.NAMES'
13532       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13533       logical :: scheck
13534 !el local variables
13535       integer :: i,iint,j,k,itypi,itypi1,itypj
13536       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13537                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13538 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13539       evdw=0.0D0
13540       do i=iatsc_s,iatsc_e
13541         itypi=itype(i,1)
13542         if (itypi.eq.ntyp1) cycle
13543         itypi1=itype(i+1,1)
13544         xi=c(1,nres+i)
13545         yi=c(2,nres+i)
13546         zi=c(3,nres+i)
13547 !
13548 ! Calculate SC interaction energy.
13549 !
13550         do iint=1,nint_gr(i)
13551           do j=istart(i,iint),iend(i,iint)
13552             itypj=itype(j,1)
13553             if (itypj.eq.ntyp1) cycle
13554             xj=c(1,nres+j)-xi
13555             yj=c(2,nres+j)-yi
13556             zj=c(3,nres+j)-zi
13557             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13558             fac_augm=rrij**expon
13559             e_augm=augm(itypi,itypj)*fac_augm
13560             r_inv_ij=dsqrt(rrij)
13561             rij=1.0D0/r_inv_ij
13562             sss=sscale(rij/sigma(itypi,itypj))
13563             if (sss.lt.1.0d0) then
13564               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13565               fac=r_shift_inv**expon
13566               e1=fac*fac*aa_aq(itypi,itypj)
13567               e2=fac*bb_aq(itypi,itypj)
13568               evdwij=e_augm+e1+e2
13569 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13570 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13571 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13572 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13573 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13574 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13575 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13576               evdw=evdw+(1.0d0-sss)*evdwij
13577 !
13578 ! Calculate the components of the gradient in DC and X
13579 !
13580               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13581               fac=fac*(1.0d0-sss)
13582               gg(1)=xj*fac
13583               gg(2)=yj*fac
13584               gg(3)=zj*fac
13585               do k=1,3
13586                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13587                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13588                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13589                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13590               enddo
13591             endif
13592           enddo      ! j
13593         enddo        ! iint
13594       enddo          ! i
13595       do i=1,nct
13596         do j=1,3
13597           gvdwc(j,i)=expon*gvdwc(j,i)
13598           gvdwx(j,i)=expon*gvdwx(j,i)
13599         enddo
13600       enddo
13601       return
13602       end subroutine eljk_long
13603 !-----------------------------------------------------------------------------
13604       subroutine eljk_short(evdw)
13605 !
13606 ! This subroutine calculates the interaction energy of nonbonded side chains
13607 ! assuming the LJK potential of interaction.
13608 !
13609 !      implicit real*8 (a-h,o-z)
13610 !      include 'DIMENSIONS'
13611 !      include 'COMMON.GEO'
13612 !      include 'COMMON.VAR'
13613 !      include 'COMMON.LOCAL'
13614 !      include 'COMMON.CHAIN'
13615 !      include 'COMMON.DERIV'
13616 !      include 'COMMON.INTERACT'
13617 !      include 'COMMON.IOUNITS'
13618 !      include 'COMMON.NAMES'
13619       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13620       logical :: scheck
13621 !el local variables
13622       integer :: i,iint,j,k,itypi,itypi1,itypj
13623       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13624                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13625 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13626       evdw=0.0D0
13627       do i=iatsc_s,iatsc_e
13628         itypi=itype(i,1)
13629         if (itypi.eq.ntyp1) cycle
13630         itypi1=itype(i+1,1)
13631         xi=c(1,nres+i)
13632         yi=c(2,nres+i)
13633         zi=c(3,nres+i)
13634 !
13635 ! Calculate SC interaction energy.
13636 !
13637         do iint=1,nint_gr(i)
13638           do j=istart(i,iint),iend(i,iint)
13639             itypj=itype(j,1)
13640             if (itypj.eq.ntyp1) cycle
13641             xj=c(1,nres+j)-xi
13642             yj=c(2,nres+j)-yi
13643             zj=c(3,nres+j)-zi
13644             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13645             fac_augm=rrij**expon
13646             e_augm=augm(itypi,itypj)*fac_augm
13647             r_inv_ij=dsqrt(rrij)
13648             rij=1.0D0/r_inv_ij
13649             sss=sscale(rij/sigma(itypi,itypj))
13650             if (sss.gt.0.0d0) then
13651               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13652               fac=r_shift_inv**expon
13653               e1=fac*fac*aa_aq(itypi,itypj)
13654               e2=fac*bb_aq(itypi,itypj)
13655               evdwij=e_augm+e1+e2
13656 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13657 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13658 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13659 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13660 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13661 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13662 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13663               evdw=evdw+sss*evdwij
13664 !
13665 ! Calculate the components of the gradient in DC and X
13666 !
13667               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13668               fac=fac*sss
13669               gg(1)=xj*fac
13670               gg(2)=yj*fac
13671               gg(3)=zj*fac
13672               do k=1,3
13673                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13674                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13675                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13676                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13677               enddo
13678             endif
13679           enddo      ! j
13680         enddo        ! iint
13681       enddo          ! i
13682       do i=1,nct
13683         do j=1,3
13684           gvdwc(j,i)=expon*gvdwc(j,i)
13685           gvdwx(j,i)=expon*gvdwx(j,i)
13686         enddo
13687       enddo
13688       return
13689       end subroutine eljk_short
13690 !-----------------------------------------------------------------------------
13691       subroutine ebp_long(evdw)
13692 !
13693 ! This subroutine calculates the interaction energy of nonbonded side chains
13694 ! assuming the Berne-Pechukas potential of interaction.
13695 !
13696       use calc_data
13697 !      implicit real*8 (a-h,o-z)
13698 !      include 'DIMENSIONS'
13699 !      include 'COMMON.GEO'
13700 !      include 'COMMON.VAR'
13701 !      include 'COMMON.LOCAL'
13702 !      include 'COMMON.CHAIN'
13703 !      include 'COMMON.DERIV'
13704 !      include 'COMMON.NAMES'
13705 !      include 'COMMON.INTERACT'
13706 !      include 'COMMON.IOUNITS'
13707 !      include 'COMMON.CALC'
13708       use comm_srutu
13709 !el      integer :: icall
13710 !el      common /srutu/ icall
13711 !     double precision rrsave(maxdim)
13712       logical :: lprn
13713 !el local variables
13714       integer :: iint,itypi,itypi1,itypj
13715       real(kind=8) :: rrij,xi,yi,zi,fac
13716       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13717       evdw=0.0D0
13718 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13719       evdw=0.0D0
13720 !     if (icall.eq.0) then
13721 !       lprn=.true.
13722 !     else
13723         lprn=.false.
13724 !     endif
13725 !el      ind=0
13726       do i=iatsc_s,iatsc_e
13727         itypi=itype(i,1)
13728         if (itypi.eq.ntyp1) cycle
13729         itypi1=itype(i+1,1)
13730         xi=c(1,nres+i)
13731         yi=c(2,nres+i)
13732         zi=c(3,nres+i)
13733         dxi=dc_norm(1,nres+i)
13734         dyi=dc_norm(2,nres+i)
13735         dzi=dc_norm(3,nres+i)
13736 !        dsci_inv=dsc_inv(itypi)
13737         dsci_inv=vbld_inv(i+nres)
13738 !
13739 ! Calculate SC interaction energy.
13740 !
13741         do iint=1,nint_gr(i)
13742           do j=istart(i,iint),iend(i,iint)
13743 !el            ind=ind+1
13744             itypj=itype(j,1)
13745             if (itypj.eq.ntyp1) cycle
13746 !            dscj_inv=dsc_inv(itypj)
13747             dscj_inv=vbld_inv(j+nres)
13748             chi1=chi(itypi,itypj)
13749             chi2=chi(itypj,itypi)
13750             chi12=chi1*chi2
13751             chip1=chip(itypi)
13752             chip2=chip(itypj)
13753             chip12=chip1*chip2
13754             alf1=alp(itypi)
13755             alf2=alp(itypj)
13756             alf12=0.5D0*(alf1+alf2)
13757             xj=c(1,nres+j)-xi
13758             yj=c(2,nres+j)-yi
13759             zj=c(3,nres+j)-zi
13760             dxj=dc_norm(1,nres+j)
13761             dyj=dc_norm(2,nres+j)
13762             dzj=dc_norm(3,nres+j)
13763             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13764             rij=dsqrt(rrij)
13765             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13766
13767             if (sss.lt.1.0d0) then
13768
13769 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13770               call sc_angular
13771 ! Calculate whole angle-dependent part of epsilon and contributions
13772 ! to its derivatives
13773               fac=(rrij*sigsq)**expon2
13774               e1=fac*fac*aa_aq(itypi,itypj)
13775               e2=fac*bb_aq(itypi,itypj)
13776               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13777               eps2der=evdwij*eps3rt
13778               eps3der=evdwij*eps2rt
13779               evdwij=evdwij*eps2rt*eps3rt
13780               evdw=evdw+evdwij*(1.0d0-sss)
13781               if (lprn) then
13782               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13783               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13784 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13785 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13786 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13787 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13788 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13789 !d     &          evdwij
13790               endif
13791 ! Calculate gradient components.
13792               e1=e1*eps1*eps2rt**2*eps3rt**2
13793               fac=-expon*(e1+evdwij)
13794               sigder=fac/sigsq
13795               fac=rrij*fac
13796 ! Calculate radial part of the gradient
13797               gg(1)=xj*fac
13798               gg(2)=yj*fac
13799               gg(3)=zj*fac
13800 ! Calculate the angular part of the gradient and sum add the contributions
13801 ! to the appropriate components of the Cartesian gradient.
13802               call sc_grad_scale(1.0d0-sss)
13803             endif
13804           enddo      ! j
13805         enddo        ! iint
13806       enddo          ! i
13807 !     stop
13808       return
13809       end subroutine ebp_long
13810 !-----------------------------------------------------------------------------
13811       subroutine ebp_short(evdw)
13812 !
13813 ! This subroutine calculates the interaction energy of nonbonded side chains
13814 ! assuming the Berne-Pechukas potential of interaction.
13815 !
13816       use calc_data
13817 !      implicit real*8 (a-h,o-z)
13818 !      include 'DIMENSIONS'
13819 !      include 'COMMON.GEO'
13820 !      include 'COMMON.VAR'
13821 !      include 'COMMON.LOCAL'
13822 !      include 'COMMON.CHAIN'
13823 !      include 'COMMON.DERIV'
13824 !      include 'COMMON.NAMES'
13825 !      include 'COMMON.INTERACT'
13826 !      include 'COMMON.IOUNITS'
13827 !      include 'COMMON.CALC'
13828       use comm_srutu
13829 !el      integer :: icall
13830 !el      common /srutu/ icall
13831 !     double precision rrsave(maxdim)
13832       logical :: lprn
13833 !el local variables
13834       integer :: iint,itypi,itypi1,itypj
13835       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13836       real(kind=8) :: sss,e1,e2,evdw
13837       evdw=0.0D0
13838 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13839       evdw=0.0D0
13840 !     if (icall.eq.0) then
13841 !       lprn=.true.
13842 !     else
13843         lprn=.false.
13844 !     endif
13845 !el      ind=0
13846       do i=iatsc_s,iatsc_e
13847         itypi=itype(i,1)
13848         if (itypi.eq.ntyp1) cycle
13849         itypi1=itype(i+1,1)
13850         xi=c(1,nres+i)
13851         yi=c(2,nres+i)
13852         zi=c(3,nres+i)
13853         dxi=dc_norm(1,nres+i)
13854         dyi=dc_norm(2,nres+i)
13855         dzi=dc_norm(3,nres+i)
13856 !        dsci_inv=dsc_inv(itypi)
13857         dsci_inv=vbld_inv(i+nres)
13858 !
13859 ! Calculate SC interaction energy.
13860 !
13861         do iint=1,nint_gr(i)
13862           do j=istart(i,iint),iend(i,iint)
13863 !el            ind=ind+1
13864             itypj=itype(j,1)
13865             if (itypj.eq.ntyp1) cycle
13866 !            dscj_inv=dsc_inv(itypj)
13867             dscj_inv=vbld_inv(j+nres)
13868             chi1=chi(itypi,itypj)
13869             chi2=chi(itypj,itypi)
13870             chi12=chi1*chi2
13871             chip1=chip(itypi)
13872             chip2=chip(itypj)
13873             chip12=chip1*chip2
13874             alf1=alp(itypi)
13875             alf2=alp(itypj)
13876             alf12=0.5D0*(alf1+alf2)
13877             xj=c(1,nres+j)-xi
13878             yj=c(2,nres+j)-yi
13879             zj=c(3,nres+j)-zi
13880             dxj=dc_norm(1,nres+j)
13881             dyj=dc_norm(2,nres+j)
13882             dzj=dc_norm(3,nres+j)
13883             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13884             rij=dsqrt(rrij)
13885             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13886
13887             if (sss.gt.0.0d0) then
13888
13889 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13890               call sc_angular
13891 ! Calculate whole angle-dependent part of epsilon and contributions
13892 ! to its derivatives
13893               fac=(rrij*sigsq)**expon2
13894               e1=fac*fac*aa_aq(itypi,itypj)
13895               e2=fac*bb_aq(itypi,itypj)
13896               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13897               eps2der=evdwij*eps3rt
13898               eps3der=evdwij*eps2rt
13899               evdwij=evdwij*eps2rt*eps3rt
13900               evdw=evdw+evdwij*sss
13901               if (lprn) then
13902               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13903               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13904 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13905 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13906 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13907 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13908 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13909 !d     &          evdwij
13910               endif
13911 ! Calculate gradient components.
13912               e1=e1*eps1*eps2rt**2*eps3rt**2
13913               fac=-expon*(e1+evdwij)
13914               sigder=fac/sigsq
13915               fac=rrij*fac
13916 ! Calculate radial part of the gradient
13917               gg(1)=xj*fac
13918               gg(2)=yj*fac
13919               gg(3)=zj*fac
13920 ! Calculate the angular part of the gradient and sum add the contributions
13921 ! to the appropriate components of the Cartesian gradient.
13922               call sc_grad_scale(sss)
13923             endif
13924           enddo      ! j
13925         enddo        ! iint
13926       enddo          ! i
13927 !     stop
13928       return
13929       end subroutine ebp_short
13930 !-----------------------------------------------------------------------------
13931       subroutine egb_long(evdw)
13932 !
13933 ! This subroutine calculates the interaction energy of nonbonded side chains
13934 ! assuming the Gay-Berne potential of interaction.
13935 !
13936       use calc_data
13937 !      implicit real*8 (a-h,o-z)
13938 !      include 'DIMENSIONS'
13939 !      include 'COMMON.GEO'
13940 !      include 'COMMON.VAR'
13941 !      include 'COMMON.LOCAL'
13942 !      include 'COMMON.CHAIN'
13943 !      include 'COMMON.DERIV'
13944 !      include 'COMMON.NAMES'
13945 !      include 'COMMON.INTERACT'
13946 !      include 'COMMON.IOUNITS'
13947 !      include 'COMMON.CALC'
13948 !      include 'COMMON.CONTROL'
13949       logical :: lprn
13950 !el local variables
13951       integer :: iint,itypi,itypi1,itypj,subchap
13952       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13953       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13954       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13955                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13956                     ssgradlipi,ssgradlipj
13957
13958
13959       evdw=0.0D0
13960 !cccc      energy_dec=.false.
13961 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13962       evdw=0.0D0
13963       lprn=.false.
13964 !     if (icall.eq.0) lprn=.false.
13965 !el      ind=0
13966       do i=iatsc_s,iatsc_e
13967         itypi=itype(i,1)
13968         if (itypi.eq.ntyp1) cycle
13969         itypi1=itype(i+1,1)
13970         xi=c(1,nres+i)
13971         yi=c(2,nres+i)
13972         zi=c(3,nres+i)
13973           xi=mod(xi,boxxsize)
13974           if (xi.lt.0) xi=xi+boxxsize
13975           yi=mod(yi,boxysize)
13976           if (yi.lt.0) yi=yi+boxysize
13977           zi=mod(zi,boxzsize)
13978           if (zi.lt.0) zi=zi+boxzsize
13979        if ((zi.gt.bordlipbot)    &
13980         .and.(zi.lt.bordliptop)) then
13981 !C the energy transfer exist
13982         if (zi.lt.buflipbot) then
13983 !C what fraction I am in
13984          fracinbuf=1.0d0-    &
13985              ((zi-bordlipbot)/lipbufthick)
13986 !C lipbufthick is thickenes of lipid buffore
13987          sslipi=sscalelip(fracinbuf)
13988          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13989         elseif (zi.gt.bufliptop) then
13990          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13991          sslipi=sscalelip(fracinbuf)
13992          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13993         else
13994          sslipi=1.0d0
13995          ssgradlipi=0.0
13996         endif
13997        else
13998          sslipi=0.0d0
13999          ssgradlipi=0.0
14000        endif
14001
14002         dxi=dc_norm(1,nres+i)
14003         dyi=dc_norm(2,nres+i)
14004         dzi=dc_norm(3,nres+i)
14005 !        dsci_inv=dsc_inv(itypi)
14006         dsci_inv=vbld_inv(i+nres)
14007 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14008 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14009 !
14010 ! Calculate SC interaction energy.
14011 !
14012         do iint=1,nint_gr(i)
14013           do j=istart(i,iint),iend(i,iint)
14014             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14015 !              call dyn_ssbond_ene(i,j,evdwij)
14016 !              evdw=evdw+evdwij
14017 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14018 !                              'evdw',i,j,evdwij,' ss'
14019 !              if (energy_dec) write (iout,*) &
14020 !                              'evdw',i,j,evdwij,' ss'
14021 !             do k=j+1,iend(i,iint)
14022 !C search over all next residues
14023 !              if (dyn_ss_mask(k)) then
14024 !C check if they are cysteins
14025 !C              write(iout,*) 'k=',k
14026
14027 !c              write(iout,*) "PRZED TRI", evdwij
14028 !               evdwij_przed_tri=evdwij
14029 !              call triple_ssbond_ene(i,j,k,evdwij)
14030 !c               if(evdwij_przed_tri.ne.evdwij) then
14031 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14032 !c               endif
14033
14034 !c              write(iout,*) "PO TRI", evdwij
14035 !C call the energy function that removes the artifical triple disulfide
14036 !C bond the soubroutine is located in ssMD.F
14037 !              evdw=evdw+evdwij
14038               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14039                             'evdw',i,j,evdwij,'tss'
14040 !              endif!dyn_ss_mask(k)
14041 !             enddo! k
14042
14043             ELSE
14044 !el            ind=ind+1
14045             itypj=itype(j,1)
14046             if (itypj.eq.ntyp1) cycle
14047 !            dscj_inv=dsc_inv(itypj)
14048             dscj_inv=vbld_inv(j+nres)
14049 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14050 !     &       1.0d0/vbld(j+nres)
14051 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14052             sig0ij=sigma(itypi,itypj)
14053             chi1=chi(itypi,itypj)
14054             chi2=chi(itypj,itypi)
14055             chi12=chi1*chi2
14056             chip1=chip(itypi)
14057             chip2=chip(itypj)
14058             chip12=chip1*chip2
14059             alf1=alp(itypi)
14060             alf2=alp(itypj)
14061             alf12=0.5D0*(alf1+alf2)
14062             xj=c(1,nres+j)
14063             yj=c(2,nres+j)
14064             zj=c(3,nres+j)
14065 ! Searching for nearest neighbour
14066           xj=mod(xj,boxxsize)
14067           if (xj.lt.0) xj=xj+boxxsize
14068           yj=mod(yj,boxysize)
14069           if (yj.lt.0) yj=yj+boxysize
14070           zj=mod(zj,boxzsize)
14071           if (zj.lt.0) zj=zj+boxzsize
14072        if ((zj.gt.bordlipbot)   &
14073       .and.(zj.lt.bordliptop)) then
14074 !C the energy transfer exist
14075         if (zj.lt.buflipbot) then
14076 !C what fraction I am in
14077          fracinbuf=1.0d0-  &
14078              ((zj-bordlipbot)/lipbufthick)
14079 !C lipbufthick is thickenes of lipid buffore
14080          sslipj=sscalelip(fracinbuf)
14081          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14082         elseif (zj.gt.bufliptop) then
14083          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14084          sslipj=sscalelip(fracinbuf)
14085          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14086         else
14087          sslipj=1.0d0
14088          ssgradlipj=0.0
14089         endif
14090        else
14091          sslipj=0.0d0
14092          ssgradlipj=0.0
14093        endif
14094       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14095        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14096       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14097        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14098
14099           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14100           xj_safe=xj
14101           yj_safe=yj
14102           zj_safe=zj
14103           subchap=0
14104           do xshift=-1,1
14105           do yshift=-1,1
14106           do zshift=-1,1
14107           xj=xj_safe+xshift*boxxsize
14108           yj=yj_safe+yshift*boxysize
14109           zj=zj_safe+zshift*boxzsize
14110           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14111           if(dist_temp.lt.dist_init) then
14112             dist_init=dist_temp
14113             xj_temp=xj
14114             yj_temp=yj
14115             zj_temp=zj
14116             subchap=1
14117           endif
14118           enddo
14119           enddo
14120           enddo
14121           if (subchap.eq.1) then
14122           xj=xj_temp-xi
14123           yj=yj_temp-yi
14124           zj=zj_temp-zi
14125           else
14126           xj=xj_safe-xi
14127           yj=yj_safe-yi
14128           zj=zj_safe-zi
14129           endif
14130
14131             dxj=dc_norm(1,nres+j)
14132             dyj=dc_norm(2,nres+j)
14133             dzj=dc_norm(3,nres+j)
14134             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14135             rij=dsqrt(rrij)
14136             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14137             sss_ele_cut=sscale_ele(1.0d0/(rij))
14138             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14139             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14140             if (sss_ele_cut.le.0.0) cycle
14141             if (sss.lt.1.0d0) then
14142
14143 ! Calculate angle-dependent terms of energy and contributions to their
14144 ! derivatives.
14145               call sc_angular
14146               sigsq=1.0D0/sigsq
14147               sig=sig0ij*dsqrt(sigsq)
14148               rij_shift=1.0D0/rij-sig+sig0ij
14149 ! for diagnostics; uncomment
14150 !              rij_shift=1.2*sig0ij
14151 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14152               if (rij_shift.le.0.0D0) then
14153                 evdw=1.0D20
14154 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14155 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14156 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14157                 return
14158               endif
14159               sigder=-sig*sigsq
14160 !---------------------------------------------------------------
14161               rij_shift=1.0D0/rij_shift
14162               fac=rij_shift**expon
14163               e1=fac*fac*aa
14164               e2=fac*bb
14165               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14166               eps2der=evdwij*eps3rt
14167               eps3der=evdwij*eps2rt
14168 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14169 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14170               evdwij=evdwij*eps2rt*eps3rt
14171               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14172               if (lprn) then
14173               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14174               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14175               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14176                 restyp(itypi,1),i,restyp(itypj,1),j,&
14177                 epsi,sigm,chi1,chi2,chip1,chip2,&
14178                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14179                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14180                 evdwij
14181               endif
14182
14183               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14184                               'evdw',i,j,evdwij
14185 !              if (energy_dec) write (iout,*) &
14186 !                              'evdw',i,j,evdwij,"egb_long"
14187
14188 ! Calculate gradient components.
14189               e1=e1*eps1*eps2rt**2*eps3rt**2
14190               fac=-expon*(e1+evdwij)*rij_shift
14191               sigder=fac*sigder
14192               fac=rij*fac
14193               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14194               *rij-sss_grad/(1.0-sss)*rij  &
14195             /sigmaii(itypi,itypj))
14196 !              fac=0.0d0
14197 ! Calculate the radial part of the gradient
14198               gg(1)=xj*fac
14199               gg(2)=yj*fac
14200               gg(3)=zj*fac
14201 ! Calculate angular part of the gradient.
14202               call sc_grad_scale(1.0d0-sss)
14203             ENDIF    !mask_dyn_ss
14204             endif
14205           enddo      ! j
14206         enddo        ! iint
14207       enddo          ! i
14208 !      write (iout,*) "Number of loop steps in EGB:",ind
14209 !ccc      energy_dec=.false.
14210       return
14211       end subroutine egb_long
14212 !-----------------------------------------------------------------------------
14213       subroutine egb_short(evdw)
14214 !
14215 ! This subroutine calculates the interaction energy of nonbonded side chains
14216 ! assuming the Gay-Berne potential of interaction.
14217 !
14218       use calc_data
14219 !      implicit real*8 (a-h,o-z)
14220 !      include 'DIMENSIONS'
14221 !      include 'COMMON.GEO'
14222 !      include 'COMMON.VAR'
14223 !      include 'COMMON.LOCAL'
14224 !      include 'COMMON.CHAIN'
14225 !      include 'COMMON.DERIV'
14226 !      include 'COMMON.NAMES'
14227 !      include 'COMMON.INTERACT'
14228 !      include 'COMMON.IOUNITS'
14229 !      include 'COMMON.CALC'
14230 !      include 'COMMON.CONTROL'
14231       logical :: lprn
14232 !el local variables
14233       integer :: iint,itypi,itypi1,itypj,subchap
14234       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14235       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14236       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14237                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14238                     ssgradlipi,ssgradlipj
14239       evdw=0.0D0
14240 !cccc      energy_dec=.false.
14241 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14242       evdw=0.0D0
14243       lprn=.false.
14244 !     if (icall.eq.0) lprn=.false.
14245 !el      ind=0
14246       do i=iatsc_s,iatsc_e
14247         itypi=itype(i,1)
14248         if (itypi.eq.ntyp1) cycle
14249         itypi1=itype(i+1,1)
14250         xi=c(1,nres+i)
14251         yi=c(2,nres+i)
14252         zi=c(3,nres+i)
14253           xi=mod(xi,boxxsize)
14254           if (xi.lt.0) xi=xi+boxxsize
14255           yi=mod(yi,boxysize)
14256           if (yi.lt.0) yi=yi+boxysize
14257           zi=mod(zi,boxzsize)
14258           if (zi.lt.0) zi=zi+boxzsize
14259        if ((zi.gt.bordlipbot)    &
14260         .and.(zi.lt.bordliptop)) then
14261 !C the energy transfer exist
14262         if (zi.lt.buflipbot) then
14263 !C what fraction I am in
14264          fracinbuf=1.0d0-    &
14265              ((zi-bordlipbot)/lipbufthick)
14266 !C lipbufthick is thickenes of lipid buffore
14267          sslipi=sscalelip(fracinbuf)
14268          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14269         elseif (zi.gt.bufliptop) then
14270          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14271          sslipi=sscalelip(fracinbuf)
14272          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14273         else
14274          sslipi=1.0d0
14275          ssgradlipi=0.0
14276         endif
14277        else
14278          sslipi=0.0d0
14279          ssgradlipi=0.0
14280        endif
14281
14282         dxi=dc_norm(1,nres+i)
14283         dyi=dc_norm(2,nres+i)
14284         dzi=dc_norm(3,nres+i)
14285 !        dsci_inv=dsc_inv(itypi)
14286         dsci_inv=vbld_inv(i+nres)
14287
14288         dxi=dc_norm(1,nres+i)
14289         dyi=dc_norm(2,nres+i)
14290         dzi=dc_norm(3,nres+i)
14291 !        dsci_inv=dsc_inv(itypi)
14292         dsci_inv=vbld_inv(i+nres)
14293 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14294 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14295 !
14296 ! Calculate SC interaction energy.
14297 !
14298         do iint=1,nint_gr(i)
14299           do j=istart(i,iint),iend(i,iint)
14300             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14301               call dyn_ssbond_ene(i,j,evdwij)
14302               evdw=evdw+evdwij
14303               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14304                               'evdw',i,j,evdwij,' ss'
14305              do k=j+1,iend(i,iint)
14306 !C search over all next residues
14307               if (dyn_ss_mask(k)) then
14308 !C check if they are cysteins
14309 !C              write(iout,*) 'k=',k
14310
14311 !c              write(iout,*) "PRZED TRI", evdwij
14312 !               evdwij_przed_tri=evdwij
14313               call triple_ssbond_ene(i,j,k,evdwij)
14314 !c               if(evdwij_przed_tri.ne.evdwij) then
14315 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14316 !c               endif
14317
14318 !c              write(iout,*) "PO TRI", evdwij
14319 !C call the energy function that removes the artifical triple disulfide
14320 !C bond the soubroutine is located in ssMD.F
14321               evdw=evdw+evdwij
14322               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14323                             'evdw',i,j,evdwij,'tss'
14324               endif!dyn_ss_mask(k)
14325              enddo! k
14326
14327 !              if (energy_dec) write (iout,*) &
14328 !                              'evdw',i,j,evdwij,' ss'
14329             ELSE
14330 !el            ind=ind+1
14331             itypj=itype(j,1)
14332             if (itypj.eq.ntyp1) cycle
14333 !            dscj_inv=dsc_inv(itypj)
14334             dscj_inv=vbld_inv(j+nres)
14335 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14336 !     &       1.0d0/vbld(j+nres)
14337 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14338             sig0ij=sigma(itypi,itypj)
14339             chi1=chi(itypi,itypj)
14340             chi2=chi(itypj,itypi)
14341             chi12=chi1*chi2
14342             chip1=chip(itypi)
14343             chip2=chip(itypj)
14344             chip12=chip1*chip2
14345             alf1=alp(itypi)
14346             alf2=alp(itypj)
14347             alf12=0.5D0*(alf1+alf2)
14348 !            xj=c(1,nres+j)-xi
14349 !            yj=c(2,nres+j)-yi
14350 !            zj=c(3,nres+j)-zi
14351             xj=c(1,nres+j)
14352             yj=c(2,nres+j)
14353             zj=c(3,nres+j)
14354 ! Searching for nearest neighbour
14355           xj=mod(xj,boxxsize)
14356           if (xj.lt.0) xj=xj+boxxsize
14357           yj=mod(yj,boxysize)
14358           if (yj.lt.0) yj=yj+boxysize
14359           zj=mod(zj,boxzsize)
14360           if (zj.lt.0) zj=zj+boxzsize
14361        if ((zj.gt.bordlipbot)   &
14362       .and.(zj.lt.bordliptop)) then
14363 !C the energy transfer exist
14364         if (zj.lt.buflipbot) then
14365 !C what fraction I am in
14366          fracinbuf=1.0d0-  &
14367              ((zj-bordlipbot)/lipbufthick)
14368 !C lipbufthick is thickenes of lipid buffore
14369          sslipj=sscalelip(fracinbuf)
14370          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14371         elseif (zj.gt.bufliptop) then
14372          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14373          sslipj=sscalelip(fracinbuf)
14374          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14375         else
14376          sslipj=1.0d0
14377          ssgradlipj=0.0
14378         endif
14379        else
14380          sslipj=0.0d0
14381          ssgradlipj=0.0
14382        endif
14383       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14384        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14385       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14386        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14387
14388           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14389           xj_safe=xj
14390           yj_safe=yj
14391           zj_safe=zj
14392           subchap=0
14393
14394           do xshift=-1,1
14395           do yshift=-1,1
14396           do zshift=-1,1
14397           xj=xj_safe+xshift*boxxsize
14398           yj=yj_safe+yshift*boxysize
14399           zj=zj_safe+zshift*boxzsize
14400           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14401           if(dist_temp.lt.dist_init) then
14402             dist_init=dist_temp
14403             xj_temp=xj
14404             yj_temp=yj
14405             zj_temp=zj
14406             subchap=1
14407           endif
14408           enddo
14409           enddo
14410           enddo
14411           if (subchap.eq.1) then
14412           xj=xj_temp-xi
14413           yj=yj_temp-yi
14414           zj=zj_temp-zi
14415           else
14416           xj=xj_safe-xi
14417           yj=yj_safe-yi
14418           zj=zj_safe-zi
14419           endif
14420
14421             dxj=dc_norm(1,nres+j)
14422             dyj=dc_norm(2,nres+j)
14423             dzj=dc_norm(3,nres+j)
14424             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14425             rij=dsqrt(rrij)
14426             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14427             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14428             sss_ele_cut=sscale_ele(1.0d0/(rij))
14429             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14430             if (sss_ele_cut.le.0.0) cycle
14431
14432             if (sss.gt.0.0d0) then
14433
14434 ! Calculate angle-dependent terms of energy and contributions to their
14435 ! derivatives.
14436               call sc_angular
14437               sigsq=1.0D0/sigsq
14438               sig=sig0ij*dsqrt(sigsq)
14439               rij_shift=1.0D0/rij-sig+sig0ij
14440 ! for diagnostics; uncomment
14441 !              rij_shift=1.2*sig0ij
14442 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14443               if (rij_shift.le.0.0D0) then
14444                 evdw=1.0D20
14445 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14446 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14447 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14448                 return
14449               endif
14450               sigder=-sig*sigsq
14451 !---------------------------------------------------------------
14452               rij_shift=1.0D0/rij_shift
14453               fac=rij_shift**expon
14454               e1=fac*fac*aa
14455               e2=fac*bb
14456               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14457               eps2der=evdwij*eps3rt
14458               eps3der=evdwij*eps2rt
14459 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14460 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14461               evdwij=evdwij*eps2rt*eps3rt
14462               evdw=evdw+evdwij*sss*sss_ele_cut
14463               if (lprn) then
14464               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14465               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14466               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14467                 restyp(itypi,1),i,restyp(itypj,1),j,&
14468                 epsi,sigm,chi1,chi2,chip1,chip2,&
14469                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14470                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14471                 evdwij
14472               endif
14473
14474               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14475                               'evdw',i,j,evdwij
14476 !              if (energy_dec) write (iout,*) &
14477 !                              'evdw',i,j,evdwij,"egb_short"
14478
14479 ! Calculate gradient components.
14480               e1=e1*eps1*eps2rt**2*eps3rt**2
14481               fac=-expon*(e1+evdwij)*rij_shift
14482               sigder=fac*sigder
14483               fac=rij*fac
14484               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14485             *rij+sss_grad/sss*rij  &
14486             /sigmaii(itypi,itypj))
14487
14488 !              fac=0.0d0
14489 ! Calculate the radial part of the gradient
14490               gg(1)=xj*fac
14491               gg(2)=yj*fac
14492               gg(3)=zj*fac
14493 ! Calculate angular part of the gradient.
14494               call sc_grad_scale(sss)
14495             endif
14496           ENDIF !mask_dyn_ss
14497           enddo      ! j
14498         enddo        ! iint
14499       enddo          ! i
14500 !      write (iout,*) "Number of loop steps in EGB:",ind
14501 !ccc      energy_dec=.false.
14502       return
14503       end subroutine egb_short
14504 !-----------------------------------------------------------------------------
14505       subroutine egbv_long(evdw)
14506 !
14507 ! This subroutine calculates the interaction energy of nonbonded side chains
14508 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14509 !
14510       use calc_data
14511 !      implicit real*8 (a-h,o-z)
14512 !      include 'DIMENSIONS'
14513 !      include 'COMMON.GEO'
14514 !      include 'COMMON.VAR'
14515 !      include 'COMMON.LOCAL'
14516 !      include 'COMMON.CHAIN'
14517 !      include 'COMMON.DERIV'
14518 !      include 'COMMON.NAMES'
14519 !      include 'COMMON.INTERACT'
14520 !      include 'COMMON.IOUNITS'
14521 !      include 'COMMON.CALC'
14522       use comm_srutu
14523 !el      integer :: icall
14524 !el      common /srutu/ icall
14525       logical :: lprn
14526 !el local variables
14527       integer :: iint,itypi,itypi1,itypj
14528       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14529       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14530       evdw=0.0D0
14531 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14532       evdw=0.0D0
14533       lprn=.false.
14534 !     if (icall.eq.0) lprn=.true.
14535 !el      ind=0
14536       do i=iatsc_s,iatsc_e
14537         itypi=itype(i,1)
14538         if (itypi.eq.ntyp1) cycle
14539         itypi1=itype(i+1,1)
14540         xi=c(1,nres+i)
14541         yi=c(2,nres+i)
14542         zi=c(3,nres+i)
14543         dxi=dc_norm(1,nres+i)
14544         dyi=dc_norm(2,nres+i)
14545         dzi=dc_norm(3,nres+i)
14546 !        dsci_inv=dsc_inv(itypi)
14547         dsci_inv=vbld_inv(i+nres)
14548 !
14549 ! Calculate SC interaction energy.
14550 !
14551         do iint=1,nint_gr(i)
14552           do j=istart(i,iint),iend(i,iint)
14553 !el            ind=ind+1
14554             itypj=itype(j,1)
14555             if (itypj.eq.ntyp1) cycle
14556 !            dscj_inv=dsc_inv(itypj)
14557             dscj_inv=vbld_inv(j+nres)
14558             sig0ij=sigma(itypi,itypj)
14559             r0ij=r0(itypi,itypj)
14560             chi1=chi(itypi,itypj)
14561             chi2=chi(itypj,itypi)
14562             chi12=chi1*chi2
14563             chip1=chip(itypi)
14564             chip2=chip(itypj)
14565             chip12=chip1*chip2
14566             alf1=alp(itypi)
14567             alf2=alp(itypj)
14568             alf12=0.5D0*(alf1+alf2)
14569             xj=c(1,nres+j)-xi
14570             yj=c(2,nres+j)-yi
14571             zj=c(3,nres+j)-zi
14572             dxj=dc_norm(1,nres+j)
14573             dyj=dc_norm(2,nres+j)
14574             dzj=dc_norm(3,nres+j)
14575             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14576             rij=dsqrt(rrij)
14577
14578             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14579
14580             if (sss.lt.1.0d0) then
14581
14582 ! Calculate angle-dependent terms of energy and contributions to their
14583 ! derivatives.
14584               call sc_angular
14585               sigsq=1.0D0/sigsq
14586               sig=sig0ij*dsqrt(sigsq)
14587               rij_shift=1.0D0/rij-sig+r0ij
14588 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14589               if (rij_shift.le.0.0D0) then
14590                 evdw=1.0D20
14591                 return
14592               endif
14593               sigder=-sig*sigsq
14594 !---------------------------------------------------------------
14595               rij_shift=1.0D0/rij_shift
14596               fac=rij_shift**expon
14597               e1=fac*fac*aa_aq(itypi,itypj)
14598               e2=fac*bb_aq(itypi,itypj)
14599               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14600               eps2der=evdwij*eps3rt
14601               eps3der=evdwij*eps2rt
14602               fac_augm=rrij**expon
14603               e_augm=augm(itypi,itypj)*fac_augm
14604               evdwij=evdwij*eps2rt*eps3rt
14605               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14606               if (lprn) then
14607               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14608               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14609               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14610                 restyp(itypi,1),i,restyp(itypj,1),j,&
14611                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14612                 chi1,chi2,chip1,chip2,&
14613                 eps1,eps2rt**2,eps3rt**2,&
14614                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14615                 evdwij+e_augm
14616               endif
14617 ! Calculate gradient components.
14618               e1=e1*eps1*eps2rt**2*eps3rt**2
14619               fac=-expon*(e1+evdwij)*rij_shift
14620               sigder=fac*sigder
14621               fac=rij*fac-2*expon*rrij*e_augm
14622 ! Calculate the radial part of the gradient
14623               gg(1)=xj*fac
14624               gg(2)=yj*fac
14625               gg(3)=zj*fac
14626 ! Calculate angular part of the gradient.
14627               call sc_grad_scale(1.0d0-sss)
14628             endif
14629           enddo      ! j
14630         enddo        ! iint
14631       enddo          ! i
14632       end subroutine egbv_long
14633 !-----------------------------------------------------------------------------
14634       subroutine egbv_short(evdw)
14635 !
14636 ! This subroutine calculates the interaction energy of nonbonded side chains
14637 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14638 !
14639       use calc_data
14640 !      implicit real*8 (a-h,o-z)
14641 !      include 'DIMENSIONS'
14642 !      include 'COMMON.GEO'
14643 !      include 'COMMON.VAR'
14644 !      include 'COMMON.LOCAL'
14645 !      include 'COMMON.CHAIN'
14646 !      include 'COMMON.DERIV'
14647 !      include 'COMMON.NAMES'
14648 !      include 'COMMON.INTERACT'
14649 !      include 'COMMON.IOUNITS'
14650 !      include 'COMMON.CALC'
14651       use comm_srutu
14652 !el      integer :: icall
14653 !el      common /srutu/ icall
14654       logical :: lprn
14655 !el local variables
14656       integer :: iint,itypi,itypi1,itypj
14657       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14658       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14659       evdw=0.0D0
14660 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14661       evdw=0.0D0
14662       lprn=.false.
14663 !     if (icall.eq.0) lprn=.true.
14664 !el      ind=0
14665       do i=iatsc_s,iatsc_e
14666         itypi=itype(i,1)
14667         if (itypi.eq.ntyp1) cycle
14668         itypi1=itype(i+1,1)
14669         xi=c(1,nres+i)
14670         yi=c(2,nres+i)
14671         zi=c(3,nres+i)
14672         dxi=dc_norm(1,nres+i)
14673         dyi=dc_norm(2,nres+i)
14674         dzi=dc_norm(3,nres+i)
14675 !        dsci_inv=dsc_inv(itypi)
14676         dsci_inv=vbld_inv(i+nres)
14677 !
14678 ! Calculate SC interaction energy.
14679 !
14680         do iint=1,nint_gr(i)
14681           do j=istart(i,iint),iend(i,iint)
14682 !el            ind=ind+1
14683             itypj=itype(j,1)
14684             if (itypj.eq.ntyp1) cycle
14685 !            dscj_inv=dsc_inv(itypj)
14686             dscj_inv=vbld_inv(j+nres)
14687             sig0ij=sigma(itypi,itypj)
14688             r0ij=r0(itypi,itypj)
14689             chi1=chi(itypi,itypj)
14690             chi2=chi(itypj,itypi)
14691             chi12=chi1*chi2
14692             chip1=chip(itypi)
14693             chip2=chip(itypj)
14694             chip12=chip1*chip2
14695             alf1=alp(itypi)
14696             alf2=alp(itypj)
14697             alf12=0.5D0*(alf1+alf2)
14698             xj=c(1,nres+j)-xi
14699             yj=c(2,nres+j)-yi
14700             zj=c(3,nres+j)-zi
14701             dxj=dc_norm(1,nres+j)
14702             dyj=dc_norm(2,nres+j)
14703             dzj=dc_norm(3,nres+j)
14704             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14705             rij=dsqrt(rrij)
14706
14707             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14708
14709             if (sss.gt.0.0d0) then
14710
14711 ! Calculate angle-dependent terms of energy and contributions to their
14712 ! derivatives.
14713               call sc_angular
14714               sigsq=1.0D0/sigsq
14715               sig=sig0ij*dsqrt(sigsq)
14716               rij_shift=1.0D0/rij-sig+r0ij
14717 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14718               if (rij_shift.le.0.0D0) then
14719                 evdw=1.0D20
14720                 return
14721               endif
14722               sigder=-sig*sigsq
14723 !---------------------------------------------------------------
14724               rij_shift=1.0D0/rij_shift
14725               fac=rij_shift**expon
14726               e1=fac*fac*aa_aq(itypi,itypj)
14727               e2=fac*bb_aq(itypi,itypj)
14728               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14729               eps2der=evdwij*eps3rt
14730               eps3der=evdwij*eps2rt
14731               fac_augm=rrij**expon
14732               e_augm=augm(itypi,itypj)*fac_augm
14733               evdwij=evdwij*eps2rt*eps3rt
14734               evdw=evdw+(evdwij+e_augm)*sss
14735               if (lprn) then
14736               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14737               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14738               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14739                 restyp(itypi,1),i,restyp(itypj,1),j,&
14740                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14741                 chi1,chi2,chip1,chip2,&
14742                 eps1,eps2rt**2,eps3rt**2,&
14743                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14744                 evdwij+e_augm
14745               endif
14746 ! Calculate gradient components.
14747               e1=e1*eps1*eps2rt**2*eps3rt**2
14748               fac=-expon*(e1+evdwij)*rij_shift
14749               sigder=fac*sigder
14750               fac=rij*fac-2*expon*rrij*e_augm
14751 ! Calculate the radial part of the gradient
14752               gg(1)=xj*fac
14753               gg(2)=yj*fac
14754               gg(3)=zj*fac
14755 ! Calculate angular part of the gradient.
14756               call sc_grad_scale(sss)
14757             endif
14758           enddo      ! j
14759         enddo        ! iint
14760       enddo          ! i
14761       end subroutine egbv_short
14762 !-----------------------------------------------------------------------------
14763       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14764 !
14765 ! This subroutine calculates the average interaction energy and its gradient
14766 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14767 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14768 ! The potential depends both on the distance of peptide-group centers and on
14769 ! the orientation of the CA-CA virtual bonds.
14770 !
14771 !      implicit real*8 (a-h,o-z)
14772
14773       use comm_locel
14774 #ifdef MPI
14775       include 'mpif.h'
14776 #endif
14777 !      include 'DIMENSIONS'
14778 !      include 'COMMON.CONTROL'
14779 !      include 'COMMON.SETUP'
14780 !      include 'COMMON.IOUNITS'
14781 !      include 'COMMON.GEO'
14782 !      include 'COMMON.VAR'
14783 !      include 'COMMON.LOCAL'
14784 !      include 'COMMON.CHAIN'
14785 !      include 'COMMON.DERIV'
14786 !      include 'COMMON.INTERACT'
14787 !      include 'COMMON.CONTACTS'
14788 !      include 'COMMON.TORSION'
14789 !      include 'COMMON.VECTORS'
14790 !      include 'COMMON.FFIELD'
14791 !      include 'COMMON.TIME1'
14792       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14793       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14794       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14795 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14796       real(kind=8),dimension(4) :: muij
14797 !el      integer :: num_conti,j1,j2
14798 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14799 !el                   dz_normi,xmedi,ymedi,zmedi
14800 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14801 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14802 !el          num_conti,j1,j2
14803 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14804 #ifdef MOMENT
14805       real(kind=8) :: scal_el=1.0d0
14806 #else
14807       real(kind=8) :: scal_el=0.5d0
14808 #endif
14809 ! 12/13/98
14810 ! 13-go grudnia roku pamietnego...
14811       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14812                                              0.0d0,1.0d0,0.0d0,&
14813                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14814 !el local variables
14815       integer :: i,j,k
14816       real(kind=8) :: fac
14817       real(kind=8) :: dxj,dyj,dzj
14818       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14819
14820 !      allocate(num_cont_hb(nres)) !(maxres)
14821 !d      write(iout,*) 'In EELEC'
14822 !d      do i=1,nloctyp
14823 !d        write(iout,*) 'Type',i
14824 !d        write(iout,*) 'B1',B1(:,i)
14825 !d        write(iout,*) 'B2',B2(:,i)
14826 !d        write(iout,*) 'CC',CC(:,:,i)
14827 !d        write(iout,*) 'DD',DD(:,:,i)
14828 !d        write(iout,*) 'EE',EE(:,:,i)
14829 !d      enddo
14830 !d      call check_vecgrad
14831 !d      stop
14832       if (icheckgrad.eq.1) then
14833         do i=1,nres-1
14834           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14835           do k=1,3
14836             dc_norm(k,i)=dc(k,i)*fac
14837           enddo
14838 !          write (iout,*) 'i',i,' fac',fac
14839         enddo
14840       endif
14841       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14842           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14843           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14844 !        call vec_and_deriv
14845 #ifdef TIMING
14846         time01=MPI_Wtime()
14847 #endif
14848 !        print *, "before set matrices"
14849         call set_matrices
14850 !        print *,"after set martices"
14851 #ifdef TIMING
14852         time_mat=time_mat+MPI_Wtime()-time01
14853 #endif
14854       endif
14855 !d      do i=1,nres-1
14856 !d        write (iout,*) 'i=',i
14857 !d        do k=1,3
14858 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14859 !d        enddo
14860 !d        do k=1,3
14861 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14862 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14863 !d        enddo
14864 !d      enddo
14865       t_eelecij=0.0d0
14866       ees=0.0D0
14867       evdw1=0.0D0
14868       eel_loc=0.0d0
14869       eello_turn3=0.0d0
14870       eello_turn4=0.0d0
14871 !el      ind=0
14872       do i=1,nres
14873         num_cont_hb(i)=0
14874       enddo
14875 !d      print '(a)','Enter EELEC'
14876 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14877 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14878 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14879       do i=1,nres
14880         gel_loc_loc(i)=0.0d0
14881         gcorr_loc(i)=0.0d0
14882       enddo
14883 !
14884 !
14885 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14886 !
14887 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14888 !
14889       do i=iturn3_start,iturn3_end
14890         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14891         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14892         dxi=dc(1,i)
14893         dyi=dc(2,i)
14894         dzi=dc(3,i)
14895         dx_normi=dc_norm(1,i)
14896         dy_normi=dc_norm(2,i)
14897         dz_normi=dc_norm(3,i)
14898         xmedi=c(1,i)+0.5d0*dxi
14899         ymedi=c(2,i)+0.5d0*dyi
14900         zmedi=c(3,i)+0.5d0*dzi
14901           xmedi=dmod(xmedi,boxxsize)
14902           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14903           ymedi=dmod(ymedi,boxysize)
14904           if (ymedi.lt.0) ymedi=ymedi+boxysize
14905           zmedi=dmod(zmedi,boxzsize)
14906           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14907         num_conti=0
14908         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14909         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14910         num_cont_hb(i)=num_conti
14911       enddo
14912       do i=iturn4_start,iturn4_end
14913         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14914           .or. itype(i+3,1).eq.ntyp1 &
14915           .or. itype(i+4,1).eq.ntyp1) cycle
14916         dxi=dc(1,i)
14917         dyi=dc(2,i)
14918         dzi=dc(3,i)
14919         dx_normi=dc_norm(1,i)
14920         dy_normi=dc_norm(2,i)
14921         dz_normi=dc_norm(3,i)
14922         xmedi=c(1,i)+0.5d0*dxi
14923         ymedi=c(2,i)+0.5d0*dyi
14924         zmedi=c(3,i)+0.5d0*dzi
14925           xmedi=dmod(xmedi,boxxsize)
14926           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14927           ymedi=dmod(ymedi,boxysize)
14928           if (ymedi.lt.0) ymedi=ymedi+boxysize
14929           zmedi=dmod(zmedi,boxzsize)
14930           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14931         num_conti=num_cont_hb(i)
14932         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14933         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14934           call eturn4(i,eello_turn4)
14935         num_cont_hb(i)=num_conti
14936       enddo   ! i
14937 !
14938 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14939 !
14940       do i=iatel_s,iatel_e
14941         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14942         dxi=dc(1,i)
14943         dyi=dc(2,i)
14944         dzi=dc(3,i)
14945         dx_normi=dc_norm(1,i)
14946         dy_normi=dc_norm(2,i)
14947         dz_normi=dc_norm(3,i)
14948         xmedi=c(1,i)+0.5d0*dxi
14949         ymedi=c(2,i)+0.5d0*dyi
14950         zmedi=c(3,i)+0.5d0*dzi
14951           xmedi=dmod(xmedi,boxxsize)
14952           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14953           ymedi=dmod(ymedi,boxysize)
14954           if (ymedi.lt.0) ymedi=ymedi+boxysize
14955           zmedi=dmod(zmedi,boxzsize)
14956           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14957 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14958         num_conti=num_cont_hb(i)
14959         do j=ielstart(i),ielend(i)
14960           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14961           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14962         enddo ! j
14963         num_cont_hb(i)=num_conti
14964       enddo   ! i
14965 !      write (iout,*) "Number of loop steps in EELEC:",ind
14966 !d      do i=1,nres
14967 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14968 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14969 !d      enddo
14970 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14971 !cc      eel_loc=eel_loc+eello_turn3
14972 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14973       return
14974       end subroutine eelec_scale
14975 !-----------------------------------------------------------------------------
14976       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14977 !      implicit real*8 (a-h,o-z)
14978
14979       use comm_locel
14980 !      include 'DIMENSIONS'
14981 #ifdef MPI
14982       include "mpif.h"
14983 #endif
14984 !      include 'COMMON.CONTROL'
14985 !      include 'COMMON.IOUNITS'
14986 !      include 'COMMON.GEO'
14987 !      include 'COMMON.VAR'
14988 !      include 'COMMON.LOCAL'
14989 !      include 'COMMON.CHAIN'
14990 !      include 'COMMON.DERIV'
14991 !      include 'COMMON.INTERACT'
14992 !      include 'COMMON.CONTACTS'
14993 !      include 'COMMON.TORSION'
14994 !      include 'COMMON.VECTORS'
14995 !      include 'COMMON.FFIELD'
14996 !      include 'COMMON.TIME1'
14997       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14998       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14999       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15000 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15001       real(kind=8),dimension(4) :: muij
15002       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15003                     dist_temp, dist_init,sss_grad
15004       integer xshift,yshift,zshift
15005
15006 !el      integer :: num_conti,j1,j2
15007 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15008 !el                   dz_normi,xmedi,ymedi,zmedi
15009 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15010 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15011 !el          num_conti,j1,j2
15012 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15013 #ifdef MOMENT
15014       real(kind=8) :: scal_el=1.0d0
15015 #else
15016       real(kind=8) :: scal_el=0.5d0
15017 #endif
15018 ! 12/13/98
15019 ! 13-go grudnia roku pamietnego...
15020       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15021                                              0.0d0,1.0d0,0.0d0,&
15022                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15023 !el local variables
15024       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15025       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15026       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15027       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15028       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15029       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15030       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15031                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15032                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15033                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15034                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15035                   ecosam,ecosbm,ecosgm,ghalf,time00
15036 !      integer :: maxconts
15037 !      maxconts = nres/4
15038 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15039 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15040 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15041 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15042 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15043 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15044 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15045 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15046 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15047 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15048 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15049 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15050 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15051
15052 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15053 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15054
15055 #ifdef MPI
15056           time00=MPI_Wtime()
15057 #endif
15058 !d      write (iout,*) "eelecij",i,j
15059 !el          ind=ind+1
15060           iteli=itel(i)
15061           itelj=itel(j)
15062           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15063           aaa=app(iteli,itelj)
15064           bbb=bpp(iteli,itelj)
15065           ael6i=ael6(iteli,itelj)
15066           ael3i=ael3(iteli,itelj)
15067           dxj=dc(1,j)
15068           dyj=dc(2,j)
15069           dzj=dc(3,j)
15070           dx_normj=dc_norm(1,j)
15071           dy_normj=dc_norm(2,j)
15072           dz_normj=dc_norm(3,j)
15073 !          xj=c(1,j)+0.5D0*dxj-xmedi
15074 !          yj=c(2,j)+0.5D0*dyj-ymedi
15075 !          zj=c(3,j)+0.5D0*dzj-zmedi
15076           xj=c(1,j)+0.5D0*dxj
15077           yj=c(2,j)+0.5D0*dyj
15078           zj=c(3,j)+0.5D0*dzj
15079           xj=mod(xj,boxxsize)
15080           if (xj.lt.0) xj=xj+boxxsize
15081           yj=mod(yj,boxysize)
15082           if (yj.lt.0) yj=yj+boxysize
15083           zj=mod(zj,boxzsize)
15084           if (zj.lt.0) zj=zj+boxzsize
15085       isubchap=0
15086       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15087       xj_safe=xj
15088       yj_safe=yj
15089       zj_safe=zj
15090       do xshift=-1,1
15091       do yshift=-1,1
15092       do zshift=-1,1
15093           xj=xj_safe+xshift*boxxsize
15094           yj=yj_safe+yshift*boxysize
15095           zj=zj_safe+zshift*boxzsize
15096           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15097           if(dist_temp.lt.dist_init) then
15098             dist_init=dist_temp
15099             xj_temp=xj
15100             yj_temp=yj
15101             zj_temp=zj
15102             isubchap=1
15103           endif
15104        enddo
15105        enddo
15106        enddo
15107        if (isubchap.eq.1) then
15108 !C          print *,i,j
15109           xj=xj_temp-xmedi
15110           yj=yj_temp-ymedi
15111           zj=zj_temp-zmedi
15112        else
15113           xj=xj_safe-xmedi
15114           yj=yj_safe-ymedi
15115           zj=zj_safe-zmedi
15116        endif
15117
15118           rij=xj*xj+yj*yj+zj*zj
15119           rrmij=1.0D0/rij
15120           rij=dsqrt(rij)
15121           rmij=1.0D0/rij
15122 ! For extracting the short-range part of Evdwpp
15123           sss=sscale(rij/rpp(iteli,itelj))
15124             sss_ele_cut=sscale_ele(rij)
15125             sss_ele_grad=sscagrad_ele(rij)
15126             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15127 !             sss_ele_cut=1.0d0
15128 !             sss_ele_grad=0.0d0
15129             if (sss_ele_cut.le.0.0) go to 128
15130
15131           r3ij=rrmij*rmij
15132           r6ij=r3ij*r3ij
15133           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15134           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15135           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15136           fac=cosa-3.0D0*cosb*cosg
15137           ev1=aaa*r6ij*r6ij
15138 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15139           if (j.eq.i+2) ev1=scal_el*ev1
15140           ev2=bbb*r6ij
15141           fac3=ael6i*r6ij
15142           fac4=ael3i*r3ij
15143           evdwij=ev1+ev2
15144           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15145           el2=fac4*fac
15146           eesij=el1+el2
15147 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15148           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15149           ees=ees+eesij*sss_ele_cut
15150           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15151 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15152 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15153 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15154 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15155
15156           if (energy_dec) then
15157               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15158               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15159           endif
15160
15161 !
15162 ! Calculate contributions to the Cartesian gradient.
15163 !
15164 #ifdef SPLITELE
15165           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15166           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15167           fac1=fac
15168           erij(1)=xj*rmij
15169           erij(2)=yj*rmij
15170           erij(3)=zj*rmij
15171 !
15172 ! Radial derivatives. First process both termini of the fragment (i,j)
15173 !
15174           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15175           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15176           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15177 !          do k=1,3
15178 !            ghalf=0.5D0*ggg(k)
15179 !            gelc(k,i)=gelc(k,i)+ghalf
15180 !            gelc(k,j)=gelc(k,j)+ghalf
15181 !          enddo
15182 ! 9/28/08 AL Gradient compotents will be summed only at the end
15183           do k=1,3
15184             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15185             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15186           enddo
15187 !
15188 ! Loop over residues i+1 thru j-1.
15189 !
15190 !grad          do k=i+1,j-1
15191 !grad            do l=1,3
15192 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15193 !grad            enddo
15194 !grad          enddo
15195           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15196           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15197           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15198           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15199           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15200           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15201 !          do k=1,3
15202 !            ghalf=0.5D0*ggg(k)
15203 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15204 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15205 !          enddo
15206 ! 9/28/08 AL Gradient compotents will be summed only at the end
15207           do k=1,3
15208             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15209             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15210           enddo
15211 !
15212 ! Loop over residues i+1 thru j-1.
15213 !
15214 !grad          do k=i+1,j-1
15215 !grad            do l=1,3
15216 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15217 !grad            enddo
15218 !grad          enddo
15219 #else
15220           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15221           facel=(el1+eesij)*sss_ele_cut
15222           fac1=fac
15223           fac=-3*rrmij*(facvdw+facvdw+facel)
15224           erij(1)=xj*rmij
15225           erij(2)=yj*rmij
15226           erij(3)=zj*rmij
15227 !
15228 ! Radial derivatives. First process both termini of the fragment (i,j)
15229 !
15230           ggg(1)=fac*xj
15231           ggg(2)=fac*yj
15232           ggg(3)=fac*zj
15233 !          do k=1,3
15234 !            ghalf=0.5D0*ggg(k)
15235 !            gelc(k,i)=gelc(k,i)+ghalf
15236 !            gelc(k,j)=gelc(k,j)+ghalf
15237 !          enddo
15238 ! 9/28/08 AL Gradient compotents will be summed only at the end
15239           do k=1,3
15240             gelc_long(k,j)=gelc(k,j)+ggg(k)
15241             gelc_long(k,i)=gelc(k,i)-ggg(k)
15242           enddo
15243 !
15244 ! Loop over residues i+1 thru j-1.
15245 !
15246 !grad          do k=i+1,j-1
15247 !grad            do l=1,3
15248 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15249 !grad            enddo
15250 !grad          enddo
15251 ! 9/28/08 AL Gradient compotents will be summed only at the end
15252           ggg(1)=facvdw*xj
15253           ggg(2)=facvdw*yj
15254           ggg(3)=facvdw*zj
15255           do k=1,3
15256             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15257             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15258           enddo
15259 #endif
15260 !
15261 ! Angular part
15262 !
15263           ecosa=2.0D0*fac3*fac1+fac4
15264           fac4=-3.0D0*fac4
15265           fac3=-6.0D0*fac3
15266           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15267           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15268           do k=1,3
15269             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15270             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15271           enddo
15272 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15273 !d   &          (dcosg(k),k=1,3)
15274           do k=1,3
15275             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15276           enddo
15277 !          do k=1,3
15278 !            ghalf=0.5D0*ggg(k)
15279 !            gelc(k,i)=gelc(k,i)+ghalf
15280 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15281 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15282 !            gelc(k,j)=gelc(k,j)+ghalf
15283 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15284 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15285 !          enddo
15286 !grad          do k=i+1,j-1
15287 !grad            do l=1,3
15288 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15289 !grad            enddo
15290 !grad          enddo
15291           do k=1,3
15292             gelc(k,i)=gelc(k,i) &
15293                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15294                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15295                      *sss_ele_cut
15296             gelc(k,j)=gelc(k,j) &
15297                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15298                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15299                      *sss_ele_cut
15300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15302           enddo
15303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15304               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15305               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15306 !
15307 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15308 !   energy of a peptide unit is assumed in the form of a second-order
15309 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15310 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15311 !   are computed for EVERY pair of non-contiguous peptide groups.
15312 !
15313           if (j.lt.nres-1) then
15314             j1=j+1
15315             j2=j-1
15316           else
15317             j1=j-1
15318             j2=j-2
15319           endif
15320           kkk=0
15321           do k=1,2
15322             do l=1,2
15323               kkk=kkk+1
15324               muij(kkk)=mu(k,i)*mu(l,j)
15325             enddo
15326           enddo
15327 !d         write (iout,*) 'EELEC: i',i,' j',j
15328 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15329 !d          write(iout,*) 'muij',muij
15330           ury=scalar(uy(1,i),erij)
15331           urz=scalar(uz(1,i),erij)
15332           vry=scalar(uy(1,j),erij)
15333           vrz=scalar(uz(1,j),erij)
15334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15338           fac=dsqrt(-ael6i)*r3ij
15339           a22=a22*fac
15340           a23=a23*fac
15341           a32=a32*fac
15342           a33=a33*fac
15343 !d          write (iout,'(4i5,4f10.5)')
15344 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15345 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15346 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15347 !d     &      uy(:,j),uz(:,j)
15348 !d          write (iout,'(4f10.5)')
15349 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15350 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15351 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15352 !d           write (iout,'(9f10.5/)')
15353 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15354 ! Derivatives of the elements of A in virtual-bond vectors
15355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15356           do k=1,3
15357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15369           enddo
15370 ! Compute radial contributions to the gradient
15371           facr=-3.0d0*rrmij
15372           a22der=a22*facr
15373           a23der=a23*facr
15374           a32der=a32*facr
15375           a33der=a33*facr
15376           agg(1,1)=a22der*xj
15377           agg(2,1)=a22der*yj
15378           agg(3,1)=a22der*zj
15379           agg(1,2)=a23der*xj
15380           agg(2,2)=a23der*yj
15381           agg(3,2)=a23der*zj
15382           agg(1,3)=a32der*xj
15383           agg(2,3)=a32der*yj
15384           agg(3,3)=a32der*zj
15385           agg(1,4)=a33der*xj
15386           agg(2,4)=a33der*yj
15387           agg(3,4)=a33der*zj
15388 ! Add the contributions coming from er
15389           fac3=-3.0d0*fac
15390           do k=1,3
15391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15395           enddo
15396           do k=1,3
15397 ! Derivatives in DC(i)
15398 !grad            ghalf1=0.5d0*agg(k,1)
15399 !grad            ghalf2=0.5d0*agg(k,2)
15400 !grad            ghalf3=0.5d0*agg(k,3)
15401 !grad            ghalf4=0.5d0*agg(k,4)
15402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15403             -3.0d0*uryg(k,2)*vry)!+ghalf1
15404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15405             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15407             -3.0d0*urzg(k,2)*vry)!+ghalf3
15408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15409             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15410 ! Derivatives in DC(i+1)
15411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15412             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15414             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15416             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15418             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15419 ! Derivatives in DC(j)
15420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15421             -3.0d0*vryg(k,2)*ury)!+ghalf1
15422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15423             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15425             -3.0d0*vryg(k,2)*urz)!+ghalf3
15426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15427             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15428 ! Derivatives in DC(j+1) or DC(nres-1)
15429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15430             -3.0d0*vryg(k,3)*ury)
15431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15432             -3.0d0*vrzg(k,3)*ury)
15433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15434             -3.0d0*vryg(k,3)*urz)
15435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15436             -3.0d0*vrzg(k,3)*urz)
15437 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15438 !grad              do l=1,4
15439 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15440 !grad              enddo
15441 !grad            endif
15442           enddo
15443           acipa(1,1)=a22
15444           acipa(1,2)=a23
15445           acipa(2,1)=a32
15446           acipa(2,2)=a33
15447           a22=-a22
15448           a23=-a23
15449           do l=1,2
15450             do k=1,3
15451               agg(k,l)=-agg(k,l)
15452               aggi(k,l)=-aggi(k,l)
15453               aggi1(k,l)=-aggi1(k,l)
15454               aggj(k,l)=-aggj(k,l)
15455               aggj1(k,l)=-aggj1(k,l)
15456             enddo
15457           enddo
15458           if (j.lt.nres-1) then
15459             a22=-a22
15460             a32=-a32
15461             do l=1,3,2
15462               do k=1,3
15463                 agg(k,l)=-agg(k,l)
15464                 aggi(k,l)=-aggi(k,l)
15465                 aggi1(k,l)=-aggi1(k,l)
15466                 aggj(k,l)=-aggj(k,l)
15467                 aggj1(k,l)=-aggj1(k,l)
15468               enddo
15469             enddo
15470           else
15471             a22=-a22
15472             a23=-a23
15473             a32=-a32
15474             a33=-a33
15475             do l=1,4
15476               do k=1,3
15477                 agg(k,l)=-agg(k,l)
15478                 aggi(k,l)=-aggi(k,l)
15479                 aggi1(k,l)=-aggi1(k,l)
15480                 aggj(k,l)=-aggj(k,l)
15481                 aggj1(k,l)=-aggj1(k,l)
15482               enddo
15483             enddo
15484           endif
15485           ENDIF ! WCORR
15486           IF (wel_loc.gt.0.0d0) THEN
15487 ! Contribution to the local-electrostatic energy coming from the i-j pair
15488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15489            +a33*muij(4)
15490 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15491 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15493                   'eelloc',i,j,eel_loc_ij
15494 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15495
15496           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15497 ! Partial derivatives in virtual-bond dihedral angles gamma
15498           if (i.gt.1) &
15499           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15500                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15501                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15502                  *sss_ele_cut
15503           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15504                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15505                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15506                  *sss_ele_cut
15507            xtemp(1)=xj
15508            xtemp(2)=yj
15509            xtemp(3)=zj
15510
15511 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15512           do l=1,3
15513             ggg(l)=(agg(l,1)*muij(1)+ &
15514                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15515             *sss_ele_cut &
15516              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15517
15518             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15519             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15520 !grad            ghalf=0.5d0*ggg(l)
15521 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15522 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15523           enddo
15524 !grad          do k=i+1,j2
15525 !grad            do l=1,3
15526 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15527 !grad            enddo
15528 !grad          enddo
15529 ! Remaining derivatives of eello
15530           do l=1,3
15531             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15532                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15533             *sss_ele_cut
15534
15535             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15536                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15537             *sss_ele_cut
15538
15539             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15540                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15541             *sss_ele_cut
15542
15543             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15544                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15545             *sss_ele_cut
15546
15547           enddo
15548           ENDIF
15549 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15550 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15551           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15552              .and. num_conti.le.maxconts) then
15553 !            write (iout,*) i,j," entered corr"
15554 !
15555 ! Calculate the contact function. The ith column of the array JCONT will
15556 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15557 ! greater than I). The arrays FACONT and GACONT will contain the values of
15558 ! the contact function and its derivative.
15559 !           r0ij=1.02D0*rpp(iteli,itelj)
15560 !           r0ij=1.11D0*rpp(iteli,itelj)
15561             r0ij=2.20D0*rpp(iteli,itelj)
15562 !           r0ij=1.55D0*rpp(iteli,itelj)
15563             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15564 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15565             if (fcont.gt.0.0D0) then
15566               num_conti=num_conti+1
15567               if (num_conti.gt.maxconts) then
15568 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15569                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15570                                ' will skip next contacts for this conf.',num_conti
15571               else
15572                 jcont_hb(num_conti,i)=j
15573 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15574 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15575                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15576                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15577 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15578 !  terms.
15579                 d_cont(num_conti,i)=rij
15580 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15581 !     --- Electrostatic-interaction matrix ---
15582                 a_chuj(1,1,num_conti,i)=a22
15583                 a_chuj(1,2,num_conti,i)=a23
15584                 a_chuj(2,1,num_conti,i)=a32
15585                 a_chuj(2,2,num_conti,i)=a33
15586 !     --- Gradient of rij
15587                 do kkk=1,3
15588                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15589                 enddo
15590                 kkll=0
15591                 do k=1,2
15592                   do l=1,2
15593                     kkll=kkll+1
15594                     do m=1,3
15595                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15596                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15597                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15598                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15599                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15600                     enddo
15601                   enddo
15602                 enddo
15603                 ENDIF
15604                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15605 ! Calculate contact energies
15606                 cosa4=4.0D0*cosa
15607                 wij=cosa-3.0D0*cosb*cosg
15608                 cosbg1=cosb+cosg
15609                 cosbg2=cosb-cosg
15610 !               fac3=dsqrt(-ael6i)/r0ij**3
15611                 fac3=dsqrt(-ael6i)*r3ij
15612 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15613                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15614                 if (ees0tmp.gt.0) then
15615                   ees0pij=dsqrt(ees0tmp)
15616                 else
15617                   ees0pij=0
15618                 endif
15619 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15620                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15621                 if (ees0tmp.gt.0) then
15622                   ees0mij=dsqrt(ees0tmp)
15623                 else
15624                   ees0mij=0
15625                 endif
15626 !               ees0mij=0.0D0
15627                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15628                      *sss_ele_cut
15629
15630                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15631                      *sss_ele_cut
15632
15633 ! Diagnostics. Comment out or remove after debugging!
15634 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15635 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15636 !               ees0m(num_conti,i)=0.0D0
15637 ! End diagnostics.
15638 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15639 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15640 ! Angular derivatives of the contact function
15641                 ees0pij1=fac3/ees0pij
15642                 ees0mij1=fac3/ees0mij
15643                 fac3p=-3.0D0*fac3*rrmij
15644                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15645                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15646 !               ees0mij1=0.0D0
15647                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15648                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15649                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15650                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15651                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15652                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15653                 ecosap=ecosa1+ecosa2
15654                 ecosbp=ecosb1+ecosb2
15655                 ecosgp=ecosg1+ecosg2
15656                 ecosam=ecosa1-ecosa2
15657                 ecosbm=ecosb1-ecosb2
15658                 ecosgm=ecosg1-ecosg2
15659 ! Diagnostics
15660 !               ecosap=ecosa1
15661 !               ecosbp=ecosb1
15662 !               ecosgp=ecosg1
15663 !               ecosam=0.0D0
15664 !               ecosbm=0.0D0
15665 !               ecosgm=0.0D0
15666 ! End diagnostics
15667                 facont_hb(num_conti,i)=fcont
15668                 fprimcont=fprimcont/rij
15669 !d              facont_hb(num_conti,i)=1.0D0
15670 ! Following line is for diagnostics.
15671 !d              fprimcont=0.0D0
15672                 do k=1,3
15673                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15674                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15675                 enddo
15676                 do k=1,3
15677                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15678                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15679                 enddo
15680 !                gggp(1)=gggp(1)+ees0pijp*xj
15681 !                gggp(2)=gggp(2)+ees0pijp*yj
15682 !                gggp(3)=gggp(3)+ees0pijp*zj
15683 !                gggm(1)=gggm(1)+ees0mijp*xj
15684 !                gggm(2)=gggm(2)+ees0mijp*yj
15685 !                gggm(3)=gggm(3)+ees0mijp*zj
15686                 gggp(1)=gggp(1)+ees0pijp*xj &
15687                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15688                 gggp(2)=gggp(2)+ees0pijp*yj &
15689                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15690                 gggp(3)=gggp(3)+ees0pijp*zj &
15691                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15692
15693                 gggm(1)=gggm(1)+ees0mijp*xj &
15694                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15695
15696                 gggm(2)=gggm(2)+ees0mijp*yj &
15697                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15698
15699                 gggm(3)=gggm(3)+ees0mijp*zj &
15700                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15701
15702 ! Derivatives due to the contact function
15703                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15704                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15705                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15706                 do k=1,3
15707 !
15708 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15709 !          following the change of gradient-summation algorithm.
15710 !
15711 !grad                  ghalfp=0.5D0*gggp(k)
15712 !grad                  ghalfm=0.5D0*gggm(k)
15713 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15714 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15715 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15716 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15717 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15718 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15719 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15720 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15721 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15722 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15723 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15724 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15725 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15726 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15727                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15728                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15729                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15730                      *sss_ele_cut
15731
15732                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15733                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15734                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15735                      *sss_ele_cut
15736
15737                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15738                      *sss_ele_cut
15739
15740                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15741                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15742                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15743                      *sss_ele_cut
15744
15745                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15746                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15747                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15748                      *sss_ele_cut
15749
15750                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15751                      *sss_ele_cut
15752
15753                 enddo
15754               ENDIF ! wcorr
15755               endif  ! num_conti.le.maxconts
15756             endif  ! fcont.gt.0
15757           endif    ! j.gt.i+1
15758           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15759             do k=1,4
15760               do l=1,3
15761                 ghalf=0.5d0*agg(l,k)
15762                 aggi(l,k)=aggi(l,k)+ghalf
15763                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15764                 aggj(l,k)=aggj(l,k)+ghalf
15765               enddo
15766             enddo
15767             if (j.eq.nres-1 .and. i.lt.j-2) then
15768               do k=1,4
15769                 do l=1,3
15770                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15771                 enddo
15772               enddo
15773             endif
15774           endif
15775  128      continue
15776 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15777       return
15778       end subroutine eelecij_scale
15779 !-----------------------------------------------------------------------------
15780       subroutine evdwpp_short(evdw1)
15781 !
15782 ! Compute Evdwpp
15783 !
15784 !      implicit real*8 (a-h,o-z)
15785 !      include 'DIMENSIONS'
15786 !      include 'COMMON.CONTROL'
15787 !      include 'COMMON.IOUNITS'
15788 !      include 'COMMON.GEO'
15789 !      include 'COMMON.VAR'
15790 !      include 'COMMON.LOCAL'
15791 !      include 'COMMON.CHAIN'
15792 !      include 'COMMON.DERIV'
15793 !      include 'COMMON.INTERACT'
15794 !      include 'COMMON.CONTACTS'
15795 !      include 'COMMON.TORSION'
15796 !      include 'COMMON.VECTORS'
15797 !      include 'COMMON.FFIELD'
15798       real(kind=8),dimension(3) :: ggg
15799 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15800 #ifdef MOMENT
15801       real(kind=8) :: scal_el=1.0d0
15802 #else
15803       real(kind=8) :: scal_el=0.5d0
15804 #endif
15805 !el local variables
15806       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15807       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15808       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15809                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15810                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15811       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15812                     dist_temp, dist_init,sss_grad
15813       integer xshift,yshift,zshift
15814
15815
15816       evdw1=0.0D0
15817 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15818 !     & " iatel_e_vdw",iatel_e_vdw
15819       call flush(iout)
15820       do i=iatel_s_vdw,iatel_e_vdw
15821         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15822         dxi=dc(1,i)
15823         dyi=dc(2,i)
15824         dzi=dc(3,i)
15825         dx_normi=dc_norm(1,i)
15826         dy_normi=dc_norm(2,i)
15827         dz_normi=dc_norm(3,i)
15828         xmedi=c(1,i)+0.5d0*dxi
15829         ymedi=c(2,i)+0.5d0*dyi
15830         zmedi=c(3,i)+0.5d0*dzi
15831           xmedi=dmod(xmedi,boxxsize)
15832           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15833           ymedi=dmod(ymedi,boxysize)
15834           if (ymedi.lt.0) ymedi=ymedi+boxysize
15835           zmedi=dmod(zmedi,boxzsize)
15836           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15837         num_conti=0
15838 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15839 !     &   ' ielend',ielend_vdw(i)
15840         call flush(iout)
15841         do j=ielstart_vdw(i),ielend_vdw(i)
15842           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15843 !el          ind=ind+1
15844           iteli=itel(i)
15845           itelj=itel(j)
15846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15847           aaa=app(iteli,itelj)
15848           bbb=bpp(iteli,itelj)
15849           dxj=dc(1,j)
15850           dyj=dc(2,j)
15851           dzj=dc(3,j)
15852           dx_normj=dc_norm(1,j)
15853           dy_normj=dc_norm(2,j)
15854           dz_normj=dc_norm(3,j)
15855 !          xj=c(1,j)+0.5D0*dxj-xmedi
15856 !          yj=c(2,j)+0.5D0*dyj-ymedi
15857 !          zj=c(3,j)+0.5D0*dzj-zmedi
15858           xj=c(1,j)+0.5D0*dxj
15859           yj=c(2,j)+0.5D0*dyj
15860           zj=c(3,j)+0.5D0*dzj
15861           xj=mod(xj,boxxsize)
15862           if (xj.lt.0) xj=xj+boxxsize
15863           yj=mod(yj,boxysize)
15864           if (yj.lt.0) yj=yj+boxysize
15865           zj=mod(zj,boxzsize)
15866           if (zj.lt.0) zj=zj+boxzsize
15867       isubchap=0
15868       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15869       xj_safe=xj
15870       yj_safe=yj
15871       zj_safe=zj
15872       do xshift=-1,1
15873       do yshift=-1,1
15874       do zshift=-1,1
15875           xj=xj_safe+xshift*boxxsize
15876           yj=yj_safe+yshift*boxysize
15877           zj=zj_safe+zshift*boxzsize
15878           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15879           if(dist_temp.lt.dist_init) then
15880             dist_init=dist_temp
15881             xj_temp=xj
15882             yj_temp=yj
15883             zj_temp=zj
15884             isubchap=1
15885           endif
15886        enddo
15887        enddo
15888        enddo
15889        if (isubchap.eq.1) then
15890 !C          print *,i,j
15891           xj=xj_temp-xmedi
15892           yj=yj_temp-ymedi
15893           zj=zj_temp-zmedi
15894        else
15895           xj=xj_safe-xmedi
15896           yj=yj_safe-ymedi
15897           zj=zj_safe-zmedi
15898        endif
15899
15900           rij=xj*xj+yj*yj+zj*zj
15901           rrmij=1.0D0/rij
15902           rij=dsqrt(rij)
15903           sss=sscale(rij/rpp(iteli,itelj))
15904             sss_ele_cut=sscale_ele(rij)
15905             sss_ele_grad=sscagrad_ele(rij)
15906             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15907             if (sss_ele_cut.le.0.0) cycle
15908           if (sss.gt.0.0d0) then
15909             rmij=1.0D0/rij
15910             r3ij=rrmij*rmij
15911             r6ij=r3ij*r3ij
15912             ev1=aaa*r6ij*r6ij
15913 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15914             if (j.eq.i+2) ev1=scal_el*ev1
15915             ev2=bbb*r6ij
15916             evdwij=ev1+ev2
15917             if (energy_dec) then
15918               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15919             endif
15920             evdw1=evdw1+evdwij*sss*sss_ele_cut
15921 !
15922 ! Calculate contributions to the Cartesian gradient.
15923 !
15924             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15925 !            ggg(1)=facvdw*xj
15926 !            ggg(2)=facvdw*yj
15927 !            ggg(3)=facvdw*zj
15928           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15929           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15930           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15931           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15932           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15933           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15934
15935             do k=1,3
15936               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15937               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15938             enddo
15939           endif
15940         enddo ! j
15941       enddo   ! i
15942       return
15943       end subroutine evdwpp_short
15944 !-----------------------------------------------------------------------------
15945       subroutine escp_long(evdw2,evdw2_14)
15946 !
15947 ! This subroutine calculates the excluded-volume interaction energy between
15948 ! peptide-group centers and side chains and its gradient in virtual-bond and
15949 ! side-chain vectors.
15950 !
15951 !      implicit real*8 (a-h,o-z)
15952 !      include 'DIMENSIONS'
15953 !      include 'COMMON.GEO'
15954 !      include 'COMMON.VAR'
15955 !      include 'COMMON.LOCAL'
15956 !      include 'COMMON.CHAIN'
15957 !      include 'COMMON.DERIV'
15958 !      include 'COMMON.INTERACT'
15959 !      include 'COMMON.FFIELD'
15960 !      include 'COMMON.IOUNITS'
15961 !      include 'COMMON.CONTROL'
15962       real(kind=8),dimension(3) :: ggg
15963 !el local variables
15964       integer :: i,iint,j,k,iteli,itypj,subchap
15965       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15966       real(kind=8) :: evdw2,evdw2_14,evdwij
15967       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15968                     dist_temp, dist_init
15969
15970       evdw2=0.0D0
15971       evdw2_14=0.0d0
15972 !d    print '(a)','Enter ESCP'
15973 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15974       do i=iatscp_s,iatscp_e
15975         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15976         iteli=itel(i)
15977         xi=0.5D0*(c(1,i)+c(1,i+1))
15978         yi=0.5D0*(c(2,i)+c(2,i+1))
15979         zi=0.5D0*(c(3,i)+c(3,i+1))
15980           xi=mod(xi,boxxsize)
15981           if (xi.lt.0) xi=xi+boxxsize
15982           yi=mod(yi,boxysize)
15983           if (yi.lt.0) yi=yi+boxysize
15984           zi=mod(zi,boxzsize)
15985           if (zi.lt.0) zi=zi+boxzsize
15986
15987         do iint=1,nscp_gr(i)
15988
15989         do j=iscpstart(i,iint),iscpend(i,iint)
15990           itypj=itype(j,1)
15991           if (itypj.eq.ntyp1) cycle
15992 ! Uncomment following three lines for SC-p interactions
15993 !         xj=c(1,nres+j)-xi
15994 !         yj=c(2,nres+j)-yi
15995 !         zj=c(3,nres+j)-zi
15996 ! Uncomment following three lines for Ca-p interactions
15997           xj=c(1,j)
15998           yj=c(2,j)
15999           zj=c(3,j)
16000           xj=mod(xj,boxxsize)
16001           if (xj.lt.0) xj=xj+boxxsize
16002           yj=mod(yj,boxysize)
16003           if (yj.lt.0) yj=yj+boxysize
16004           zj=mod(zj,boxzsize)
16005           if (zj.lt.0) zj=zj+boxzsize
16006       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16007       xj_safe=xj
16008       yj_safe=yj
16009       zj_safe=zj
16010       subchap=0
16011       do xshift=-1,1
16012       do yshift=-1,1
16013       do zshift=-1,1
16014           xj=xj_safe+xshift*boxxsize
16015           yj=yj_safe+yshift*boxysize
16016           zj=zj_safe+zshift*boxzsize
16017           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16018           if(dist_temp.lt.dist_init) then
16019             dist_init=dist_temp
16020             xj_temp=xj
16021             yj_temp=yj
16022             zj_temp=zj
16023             subchap=1
16024           endif
16025        enddo
16026        enddo
16027        enddo
16028        if (subchap.eq.1) then
16029           xj=xj_temp-xi
16030           yj=yj_temp-yi
16031           zj=zj_temp-zi
16032        else
16033           xj=xj_safe-xi
16034           yj=yj_safe-yi
16035           zj=zj_safe-zi
16036        endif
16037           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16038
16039           rij=dsqrt(1.0d0/rrij)
16040             sss_ele_cut=sscale_ele(rij)
16041             sss_ele_grad=sscagrad_ele(rij)
16042 !            print *,sss_ele_cut,sss_ele_grad,&
16043 !            (rij),r_cut_ele,rlamb_ele
16044             if (sss_ele_cut.le.0.0) cycle
16045           sss=sscale((rij/rscp(itypj,iteli)))
16046           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16047           if (sss.lt.1.0d0) then
16048
16049             fac=rrij**expon2
16050             e1=fac*fac*aad(itypj,iteli)
16051             e2=fac*bad(itypj,iteli)
16052             if (iabs(j-i) .le. 2) then
16053               e1=scal14*e1
16054               e2=scal14*e2
16055               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16056             endif
16057             evdwij=e1+e2
16058             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16059             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16060                 'evdw2',i,j,sss,evdwij
16061 !
16062 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16063 !
16064             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16065             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16066             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16067             ggg(1)=xj*fac
16068             ggg(2)=yj*fac
16069             ggg(3)=zj*fac
16070 ! Uncomment following three lines for SC-p interactions
16071 !           do k=1,3
16072 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16073 !           enddo
16074 ! Uncomment following line for SC-p interactions
16075 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16076             do k=1,3
16077               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16078               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16079             enddo
16080           endif
16081         enddo
16082
16083         enddo ! iint
16084       enddo ! i
16085       do i=1,nct
16086         do j=1,3
16087           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16088           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16089           gradx_scp(j,i)=expon*gradx_scp(j,i)
16090         enddo
16091       enddo
16092 !******************************************************************************
16093 !
16094 !                              N O T E !!!
16095 !
16096 ! To save time the factor EXPON has been extracted from ALL components
16097 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16098 ! use!
16099 !
16100 !******************************************************************************
16101       return
16102       end subroutine escp_long
16103 !-----------------------------------------------------------------------------
16104       subroutine escp_short(evdw2,evdw2_14)
16105 !
16106 ! This subroutine calculates the excluded-volume interaction energy between
16107 ! peptide-group centers and side chains and its gradient in virtual-bond and
16108 ! side-chain vectors.
16109 !
16110 !      implicit real*8 (a-h,o-z)
16111 !      include 'DIMENSIONS'
16112 !      include 'COMMON.GEO'
16113 !      include 'COMMON.VAR'
16114 !      include 'COMMON.LOCAL'
16115 !      include 'COMMON.CHAIN'
16116 !      include 'COMMON.DERIV'
16117 !      include 'COMMON.INTERACT'
16118 !      include 'COMMON.FFIELD'
16119 !      include 'COMMON.IOUNITS'
16120 !      include 'COMMON.CONTROL'
16121       real(kind=8),dimension(3) :: ggg
16122 !el local variables
16123       integer :: i,iint,j,k,iteli,itypj,subchap
16124       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16125       real(kind=8) :: evdw2,evdw2_14,evdwij
16126       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16127                     dist_temp, dist_init
16128
16129       evdw2=0.0D0
16130       evdw2_14=0.0d0
16131 !d    print '(a)','Enter ESCP'
16132 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16133       do i=iatscp_s,iatscp_e
16134         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16135         iteli=itel(i)
16136         xi=0.5D0*(c(1,i)+c(1,i+1))
16137         yi=0.5D0*(c(2,i)+c(2,i+1))
16138         zi=0.5D0*(c(3,i)+c(3,i+1))
16139           xi=mod(xi,boxxsize)
16140           if (xi.lt.0) xi=xi+boxxsize
16141           yi=mod(yi,boxysize)
16142           if (yi.lt.0) yi=yi+boxysize
16143           zi=mod(zi,boxzsize)
16144           if (zi.lt.0) zi=zi+boxzsize
16145
16146         do iint=1,nscp_gr(i)
16147
16148         do j=iscpstart(i,iint),iscpend(i,iint)
16149           itypj=itype(j,1)
16150           if (itypj.eq.ntyp1) cycle
16151 ! Uncomment following three lines for SC-p interactions
16152 !         xj=c(1,nres+j)-xi
16153 !         yj=c(2,nres+j)-yi
16154 !         zj=c(3,nres+j)-zi
16155 ! Uncomment following three lines for Ca-p interactions
16156 !          xj=c(1,j)-xi
16157 !          yj=c(2,j)-yi
16158 !          zj=c(3,j)-zi
16159           xj=c(1,j)
16160           yj=c(2,j)
16161           zj=c(3,j)
16162           xj=mod(xj,boxxsize)
16163           if (xj.lt.0) xj=xj+boxxsize
16164           yj=mod(yj,boxysize)
16165           if (yj.lt.0) yj=yj+boxysize
16166           zj=mod(zj,boxzsize)
16167           if (zj.lt.0) zj=zj+boxzsize
16168       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16169       xj_safe=xj
16170       yj_safe=yj
16171       zj_safe=zj
16172       subchap=0
16173       do xshift=-1,1
16174       do yshift=-1,1
16175       do zshift=-1,1
16176           xj=xj_safe+xshift*boxxsize
16177           yj=yj_safe+yshift*boxysize
16178           zj=zj_safe+zshift*boxzsize
16179           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16180           if(dist_temp.lt.dist_init) then
16181             dist_init=dist_temp
16182             xj_temp=xj
16183             yj_temp=yj
16184             zj_temp=zj
16185             subchap=1
16186           endif
16187        enddo
16188        enddo
16189        enddo
16190        if (subchap.eq.1) then
16191           xj=xj_temp-xi
16192           yj=yj_temp-yi
16193           zj=zj_temp-zi
16194        else
16195           xj=xj_safe-xi
16196           yj=yj_safe-yi
16197           zj=zj_safe-zi
16198        endif
16199
16200           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16201           rij=dsqrt(1.0d0/rrij)
16202             sss_ele_cut=sscale_ele(rij)
16203             sss_ele_grad=sscagrad_ele(rij)
16204 !            print *,sss_ele_cut,sss_ele_grad,&
16205 !            (rij),r_cut_ele,rlamb_ele
16206             if (sss_ele_cut.le.0.0) cycle
16207           sss=sscale(rij/rscp(itypj,iteli))
16208           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16209           if (sss.gt.0.0d0) then
16210
16211             fac=rrij**expon2
16212             e1=fac*fac*aad(itypj,iteli)
16213             e2=fac*bad(itypj,iteli)
16214             if (iabs(j-i) .le. 2) then
16215               e1=scal14*e1
16216               e2=scal14*e2
16217               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16218             endif
16219             evdwij=e1+e2
16220             evdw2=evdw2+evdwij*sss*sss_ele_cut
16221             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16222                 'evdw2',i,j,sss,evdwij
16223 !
16224 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16225 !
16226             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16227             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16228             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16229
16230             ggg(1)=xj*fac
16231             ggg(2)=yj*fac
16232             ggg(3)=zj*fac
16233 ! Uncomment following three lines for SC-p interactions
16234 !           do k=1,3
16235 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16236 !           enddo
16237 ! Uncomment following line for SC-p interactions
16238 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16239             do k=1,3
16240               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16241               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16242             enddo
16243           endif
16244         enddo
16245
16246         enddo ! iint
16247       enddo ! i
16248       do i=1,nct
16249         do j=1,3
16250           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16251           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16252           gradx_scp(j,i)=expon*gradx_scp(j,i)
16253         enddo
16254       enddo
16255 !******************************************************************************
16256 !
16257 !                              N O T E !!!
16258 !
16259 ! To save time the factor EXPON has been extracted from ALL components
16260 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16261 ! use!
16262 !
16263 !******************************************************************************
16264       return
16265       end subroutine escp_short
16266 !-----------------------------------------------------------------------------
16267 ! energy_p_new-sep_barrier.F
16268 !-----------------------------------------------------------------------------
16269       subroutine sc_grad_scale(scalfac)
16270 !      implicit real*8 (a-h,o-z)
16271       use calc_data
16272 !      include 'DIMENSIONS'
16273 !      include 'COMMON.CHAIN'
16274 !      include 'COMMON.DERIV'
16275 !      include 'COMMON.CALC'
16276 !      include 'COMMON.IOUNITS'
16277       real(kind=8),dimension(3) :: dcosom1,dcosom2
16278       real(kind=8) :: scalfac
16279 !el local variables
16280 !      integer :: i,j,k,l
16281
16282       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16283       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16284       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16285            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16286 ! diagnostics only
16287 !      eom1=0.0d0
16288 !      eom2=0.0d0
16289 !      eom12=evdwij*eps1_om12
16290 ! end diagnostics
16291 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16292 !     &  " sigder",sigder
16293 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16294 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16295       do k=1,3
16296         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16297         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16298       enddo
16299       do k=1,3
16300         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16301          *sss_ele_cut
16302       enddo
16303 !      write (iout,*) "gg",(gg(k),k=1,3)
16304       do k=1,3
16305         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16306                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16307                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16308                  *sss_ele_cut
16309         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16310                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16311                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16312          *sss_ele_cut
16313 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16314 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16315 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16316 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16317       enddo
16318 !
16319 ! Calculate the components of the gradient in DC and X
16320 !
16321       do l=1,3
16322         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16323         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16324       enddo
16325       return
16326       end subroutine sc_grad_scale
16327 !-----------------------------------------------------------------------------
16328 ! energy_split-sep.F
16329 !-----------------------------------------------------------------------------
16330       subroutine etotal_long(energia)
16331 !
16332 ! Compute the long-range slow-varying contributions to the energy
16333 !
16334 !      implicit real*8 (a-h,o-z)
16335 !      include 'DIMENSIONS'
16336       use MD_data, only: totT,usampl,eq_time
16337 #ifndef ISNAN
16338       external proc_proc
16339 #ifdef WINPGI
16340 !MS$ATTRIBUTES C ::  proc_proc
16341 #endif
16342 #endif
16343 #ifdef MPI
16344       include "mpif.h"
16345       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16346 #endif
16347 !      include 'COMMON.SETUP'
16348 !      include 'COMMON.IOUNITS'
16349 !      include 'COMMON.FFIELD'
16350 !      include 'COMMON.DERIV'
16351 !      include 'COMMON.INTERACT'
16352 !      include 'COMMON.SBRIDGE'
16353 !      include 'COMMON.CHAIN'
16354 !      include 'COMMON.VAR'
16355 !      include 'COMMON.LOCAL'
16356 !      include 'COMMON.MD'
16357       real(kind=8),dimension(0:n_ene) :: energia
16358 !el local variables
16359       integer :: i,n_corr,n_corr1,ierror,ierr
16360       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16361                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16362                   ecorr,ecorr5,ecorr6,eturn6,time00
16363 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16364 !elwrite(iout,*)"in etotal long"
16365
16366       if (modecalc.eq.12.or.modecalc.eq.14) then
16367 #ifdef MPI
16368 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16369 #else
16370         call int_from_cart1(.false.)
16371 #endif
16372       endif
16373 !elwrite(iout,*)"in etotal long"
16374
16375 #ifdef MPI
16376 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16377 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16378       call flush(iout)
16379       if (nfgtasks.gt.1) then
16380         time00=MPI_Wtime()
16381 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16382         if (fg_rank.eq.0) then
16383           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16384 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16385 !          call flush(iout)
16386 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16387 ! FG slaves as WEIGHTS array.
16388           weights_(1)=wsc
16389           weights_(2)=wscp
16390           weights_(3)=welec
16391           weights_(4)=wcorr
16392           weights_(5)=wcorr5
16393           weights_(6)=wcorr6
16394           weights_(7)=wel_loc
16395           weights_(8)=wturn3
16396           weights_(9)=wturn4
16397           weights_(10)=wturn6
16398           weights_(11)=wang
16399           weights_(12)=wscloc
16400           weights_(13)=wtor
16401           weights_(14)=wtor_d
16402           weights_(15)=wstrain
16403           weights_(16)=wvdwpp
16404           weights_(17)=wbond
16405           weights_(18)=scal14
16406           weights_(21)=wsccor
16407 ! FG Master broadcasts the WEIGHTS_ array
16408           call MPI_Bcast(weights_(1),n_ene,&
16409               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16410         else
16411 ! FG slaves receive the WEIGHTS array
16412           call MPI_Bcast(weights(1),n_ene,&
16413               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16414           wsc=weights(1)
16415           wscp=weights(2)
16416           welec=weights(3)
16417           wcorr=weights(4)
16418           wcorr5=weights(5)
16419           wcorr6=weights(6)
16420           wel_loc=weights(7)
16421           wturn3=weights(8)
16422           wturn4=weights(9)
16423           wturn6=weights(10)
16424           wang=weights(11)
16425           wscloc=weights(12)
16426           wtor=weights(13)
16427           wtor_d=weights(14)
16428           wstrain=weights(15)
16429           wvdwpp=weights(16)
16430           wbond=weights(17)
16431           scal14=weights(18)
16432           wsccor=weights(21)
16433         endif
16434         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16435           king,FG_COMM,IERR)
16436          time_Bcast=time_Bcast+MPI_Wtime()-time00
16437          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16438 !        call chainbuild_cart
16439 !        call int_from_cart1(.false.)
16440       endif
16441 !      write (iout,*) 'Processor',myrank,
16442 !     &  ' calling etotal_short ipot=',ipot
16443 !      call flush(iout)
16444 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16445 #endif
16446 !d    print *,'nnt=',nnt,' nct=',nct
16447 !
16448 !elwrite(iout,*)"in etotal long"
16449 ! Compute the side-chain and electrostatic interaction energy
16450 !
16451       goto (101,102,103,104,105,106) ipot
16452 ! Lennard-Jones potential.
16453   101 call elj_long(evdw)
16454 !d    print '(a)','Exit ELJ'
16455       goto 107
16456 ! Lennard-Jones-Kihara potential (shifted).
16457   102 call eljk_long(evdw)
16458       goto 107
16459 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16460   103 call ebp_long(evdw)
16461       goto 107
16462 ! Gay-Berne potential (shifted LJ, angular dependence).
16463   104 call egb_long(evdw)
16464       goto 107
16465 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16466   105 call egbv_long(evdw)
16467       goto 107
16468 ! Soft-sphere potential
16469   106 call e_softsphere(evdw)
16470 !
16471 ! Calculate electrostatic (H-bonding) energy of the main chain.
16472 !
16473   107 continue
16474       call vec_and_deriv
16475       if (ipot.lt.6) then
16476 #ifdef SPLITELE
16477          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16478              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16479              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16480              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16481 #else
16482          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16483              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16484              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16485              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16486 #endif
16487            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16488          else
16489             ees=0
16490             evdw1=0
16491             eel_loc=0
16492             eello_turn3=0
16493             eello_turn4=0
16494          endif
16495       else
16496 !        write (iout,*) "Soft-spheer ELEC potential"
16497         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16498          eello_turn4)
16499       endif
16500 !
16501 ! Calculate excluded-volume interaction energy between peptide groups
16502 ! and side chains.
16503 !
16504       if (ipot.lt.6) then
16505        if(wscp.gt.0d0) then
16506         call escp_long(evdw2,evdw2_14)
16507        else
16508         evdw2=0
16509         evdw2_14=0
16510        endif
16511       else
16512         call escp_soft_sphere(evdw2,evdw2_14)
16513       endif
16514 !
16515 ! 12/1/95 Multi-body terms
16516 !
16517       n_corr=0
16518       n_corr1=0
16519       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16520           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16521          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16522 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16523 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16524       else
16525          ecorr=0.0d0
16526          ecorr5=0.0d0
16527          ecorr6=0.0d0
16528          eturn6=0.0d0
16529       endif
16530       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16531          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16532       endif
16533 !
16534 ! If performing constraint dynamics, call the constraint energy
16535 !  after the equilibration time
16536       if(usampl.and.totT.gt.eq_time) then
16537          call EconstrQ
16538          call Econstr_back
16539       else
16540          Uconst=0.0d0
16541          Uconst_back=0.0d0
16542       endif
16543 !
16544 ! Sum the energies
16545 !
16546       do i=1,n_ene
16547         energia(i)=0.0d0
16548       enddo
16549       energia(1)=evdw
16550 #ifdef SCP14
16551       energia(2)=evdw2-evdw2_14
16552       energia(18)=evdw2_14
16553 #else
16554       energia(2)=evdw2
16555       energia(18)=0.0d0
16556 #endif
16557 #ifdef SPLITELE
16558       energia(3)=ees
16559       energia(16)=evdw1
16560 #else
16561       energia(3)=ees+evdw1
16562       energia(16)=0.0d0
16563 #endif
16564       energia(4)=ecorr
16565       energia(5)=ecorr5
16566       energia(6)=ecorr6
16567       energia(7)=eel_loc
16568       energia(8)=eello_turn3
16569       energia(9)=eello_turn4
16570       energia(10)=eturn6
16571       energia(20)=Uconst+Uconst_back
16572       call sum_energy(energia,.true.)
16573 !      write (iout,*) "Exit ETOTAL_LONG"
16574       call flush(iout)
16575       return
16576       end subroutine etotal_long
16577 !-----------------------------------------------------------------------------
16578       subroutine etotal_short(energia)
16579 !
16580 ! Compute the short-range fast-varying contributions to the energy
16581 !
16582 !      implicit real*8 (a-h,o-z)
16583 !      include 'DIMENSIONS'
16584 #ifndef ISNAN
16585       external proc_proc
16586 #ifdef WINPGI
16587 !MS$ATTRIBUTES C ::  proc_proc
16588 #endif
16589 #endif
16590 #ifdef MPI
16591       include "mpif.h"
16592       integer :: ierror,ierr
16593       real(kind=8),dimension(n_ene) :: weights_
16594       real(kind=8) :: time00
16595 #endif
16596 !      include 'COMMON.SETUP'
16597 !      include 'COMMON.IOUNITS'
16598 !      include 'COMMON.FFIELD'
16599 !      include 'COMMON.DERIV'
16600 !      include 'COMMON.INTERACT'
16601 !      include 'COMMON.SBRIDGE'
16602 !      include 'COMMON.CHAIN'
16603 !      include 'COMMON.VAR'
16604 !      include 'COMMON.LOCAL'
16605       real(kind=8),dimension(0:n_ene) :: energia
16606 !el local variables
16607       integer :: i,nres6
16608       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16609       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16610       nres6=6*nres
16611
16612 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16613 !      call flush(iout)
16614       if (modecalc.eq.12.or.modecalc.eq.14) then
16615 #ifdef MPI
16616         if (fg_rank.eq.0) call int_from_cart1(.false.)
16617 #else
16618         call int_from_cart1(.false.)
16619 #endif
16620       endif
16621 #ifdef MPI
16622 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16623 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16624 !      call flush(iout)
16625       if (nfgtasks.gt.1) then
16626         time00=MPI_Wtime()
16627 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16628         if (fg_rank.eq.0) then
16629           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16630 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16631 !          call flush(iout)
16632 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16633 ! FG slaves as WEIGHTS array.
16634           weights_(1)=wsc
16635           weights_(2)=wscp
16636           weights_(3)=welec
16637           weights_(4)=wcorr
16638           weights_(5)=wcorr5
16639           weights_(6)=wcorr6
16640           weights_(7)=wel_loc
16641           weights_(8)=wturn3
16642           weights_(9)=wturn4
16643           weights_(10)=wturn6
16644           weights_(11)=wang
16645           weights_(12)=wscloc
16646           weights_(13)=wtor
16647           weights_(14)=wtor_d
16648           weights_(15)=wstrain
16649           weights_(16)=wvdwpp
16650           weights_(17)=wbond
16651           weights_(18)=scal14
16652           weights_(21)=wsccor
16653 ! FG Master broadcasts the WEIGHTS_ array
16654           call MPI_Bcast(weights_(1),n_ene,&
16655               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16656         else
16657 ! FG slaves receive the WEIGHTS array
16658           call MPI_Bcast(weights(1),n_ene,&
16659               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16660           wsc=weights(1)
16661           wscp=weights(2)
16662           welec=weights(3)
16663           wcorr=weights(4)
16664           wcorr5=weights(5)
16665           wcorr6=weights(6)
16666           wel_loc=weights(7)
16667           wturn3=weights(8)
16668           wturn4=weights(9)
16669           wturn6=weights(10)
16670           wang=weights(11)
16671           wscloc=weights(12)
16672           wtor=weights(13)
16673           wtor_d=weights(14)
16674           wstrain=weights(15)
16675           wvdwpp=weights(16)
16676           wbond=weights(17)
16677           scal14=weights(18)
16678           wsccor=weights(21)
16679         endif
16680 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16681         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16682           king,FG_COMM,IERR)
16683 !        write (iout,*) "Processor",myrank," BROADCAST c"
16684         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16685           king,FG_COMM,IERR)
16686 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16687         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16688           king,FG_COMM,IERR)
16689 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16690         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16691           king,FG_COMM,IERR)
16692 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16693         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16694           king,FG_COMM,IERR)
16695 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16696         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16697           king,FG_COMM,IERR)
16698 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16699         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16700           king,FG_COMM,IERR)
16701 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16702         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16703           king,FG_COMM,IERR)
16704 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16705         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16706           king,FG_COMM,IERR)
16707          time_Bcast=time_Bcast+MPI_Wtime()-time00
16708 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16709       endif
16710 !      write (iout,*) 'Processor',myrank,
16711 !     &  ' calling etotal_short ipot=',ipot
16712 !      call flush(iout)
16713 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16714 #endif
16715 !      call int_from_cart1(.false.)
16716 !
16717 ! Compute the side-chain and electrostatic interaction energy
16718 !
16719       goto (101,102,103,104,105,106) ipot
16720 ! Lennard-Jones potential.
16721   101 call elj_short(evdw)
16722 !d    print '(a)','Exit ELJ'
16723       goto 107
16724 ! Lennard-Jones-Kihara potential (shifted).
16725   102 call eljk_short(evdw)
16726       goto 107
16727 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16728   103 call ebp_short(evdw)
16729       goto 107
16730 ! Gay-Berne potential (shifted LJ, angular dependence).
16731   104 call egb_short(evdw)
16732       goto 107
16733 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16734   105 call egbv_short(evdw)
16735       goto 107
16736 ! Soft-sphere potential - already dealt with in the long-range part
16737   106 evdw=0.0d0
16738 !  106 call e_softsphere_short(evdw)
16739 !
16740 ! Calculate electrostatic (H-bonding) energy of the main chain.
16741 !
16742   107 continue
16743 !
16744 ! Calculate the short-range part of Evdwpp
16745 !
16746       call evdwpp_short(evdw1)
16747 !
16748 ! Calculate the short-range part of ESCp
16749 !
16750       if (ipot.lt.6) then
16751         call escp_short(evdw2,evdw2_14)
16752       endif
16753 !
16754 ! Calculate the bond-stretching energy
16755 !
16756       call ebond(estr)
16757 !
16758 ! Calculate the disulfide-bridge and other energy and the contributions
16759 ! from other distance constraints.
16760       call edis(ehpb)
16761 !
16762 ! Calculate the virtual-bond-angle energy.
16763 !
16764 ! Calculate the SC local energy.
16765 !
16766       call vec_and_deriv
16767       call esc(escloc)
16768 !
16769       if (wang.gt.0d0) then
16770        if (tor_mode.eq.0) then
16771          call ebend(ebe)
16772        else
16773 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16774 !C energy function
16775          call ebend_kcc(ebe)
16776        endif
16777       else
16778         ebe=0.0d0
16779       endif
16780       ethetacnstr=0.0d0
16781       if (with_theta_constr) call etheta_constr(ethetacnstr)
16782
16783 !       write(iout,*) "in etotal afer ebe",ipot
16784
16785 !      print *,"Processor",myrank," computed UB"
16786 !
16787 ! Calculate the SC local energy.
16788 !
16789       call esc(escloc)
16790 !elwrite(iout,*) "in etotal afer esc",ipot
16791 !      print *,"Processor",myrank," computed USC"
16792 !
16793 ! Calculate the virtual-bond torsional energy.
16794 !
16795 !d    print *,'nterm=',nterm
16796 !      if (wtor.gt.0) then
16797 !       call etor(etors,edihcnstr)
16798 !      else
16799 !       etors=0
16800 !       edihcnstr=0
16801 !      endif
16802       if (wtor.gt.0.0d0) then
16803          if (tor_mode.eq.0) then
16804            call etor(etors)
16805          else
16806 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16807 !C energy function
16808            call etor_kcc(etors)
16809          endif
16810       else
16811         etors=0.0d0
16812       endif
16813       edihcnstr=0.0d0
16814       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16815
16816 ! Calculate the virtual-bond torsional energy.
16817 !
16818 !
16819 ! 6/23/01 Calculate double-torsional energy
16820 !
16821       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16822       call etor_d(etors_d)
16823       endif
16824 !
16825 ! 21/5/07 Calculate local sicdechain correlation energy
16826 !
16827       if (wsccor.gt.0.0d0) then
16828         call eback_sc_corr(esccor)
16829       else
16830         esccor=0.0d0
16831       endif
16832 !
16833 ! Put energy components into an array
16834 !
16835       do i=1,n_ene
16836         energia(i)=0.0d0
16837       enddo
16838       energia(1)=evdw
16839 #ifdef SCP14
16840       energia(2)=evdw2-evdw2_14
16841       energia(18)=evdw2_14
16842 #else
16843       energia(2)=evdw2
16844       energia(18)=0.0d0
16845 #endif
16846 #ifdef SPLITELE
16847       energia(16)=evdw1
16848 #else
16849       energia(3)=evdw1
16850 #endif
16851       energia(11)=ebe
16852       energia(12)=escloc
16853       energia(13)=etors
16854       energia(14)=etors_d
16855       energia(15)=ehpb
16856       energia(17)=estr
16857       energia(19)=edihcnstr
16858       energia(21)=esccor
16859 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16860       call flush(iout)
16861       call sum_energy(energia,.true.)
16862 !      write (iout,*) "Exit ETOTAL_SHORT"
16863       call flush(iout)
16864       return
16865       end subroutine etotal_short
16866 !-----------------------------------------------------------------------------
16867 ! gnmr1.f
16868 !-----------------------------------------------------------------------------
16869       real(kind=8) function gnmr1(y,ymin,ymax)
16870 !      implicit none
16871       real(kind=8) :: y,ymin,ymax
16872       real(kind=8) :: wykl=4.0d0
16873       if (y.lt.ymin) then
16874         gnmr1=(ymin-y)**wykl/wykl
16875       else if (y.gt.ymax) then
16876         gnmr1=(y-ymax)**wykl/wykl
16877       else
16878         gnmr1=0.0d0
16879       endif
16880       return
16881       end function gnmr1
16882 !-----------------------------------------------------------------------------
16883       real(kind=8) function gnmr1prim(y,ymin,ymax)
16884 !      implicit none
16885       real(kind=8) :: y,ymin,ymax
16886       real(kind=8) :: wykl=4.0d0
16887       if (y.lt.ymin) then
16888         gnmr1prim=-(ymin-y)**(wykl-1)
16889       else if (y.gt.ymax) then
16890         gnmr1prim=(y-ymax)**(wykl-1)
16891       else
16892         gnmr1prim=0.0d0
16893       endif
16894       return
16895       end function gnmr1prim
16896 !----------------------------------------------------------------------------
16897       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16898       real(kind=8) y,ymin,ymax,sigma
16899       real(kind=8) wykl /4.0d0/
16900       if (y.lt.ymin) then
16901         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16902       else if (y.gt.ymax) then
16903         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16904       else
16905         rlornmr1=0.0d0
16906       endif
16907       return
16908       end function rlornmr1
16909 !------------------------------------------------------------------------------
16910       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16911       real(kind=8) y,ymin,ymax,sigma
16912       real(kind=8) wykl /4.0d0/
16913       if (y.lt.ymin) then
16914         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16915         ((ymin-y)**wykl+sigma**wykl)**2
16916       else if (y.gt.ymax) then
16917         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16918         ((y-ymax)**wykl+sigma**wykl)**2
16919       else
16920         rlornmr1prim=0.0d0
16921       endif
16922       return
16923       end function rlornmr1prim
16924
16925       real(kind=8) function harmonic(y,ymax)
16926 !      implicit none
16927       real(kind=8) :: y,ymax
16928       real(kind=8) :: wykl=2.0d0
16929       harmonic=(y-ymax)**wykl
16930       return
16931       end function harmonic
16932 !-----------------------------------------------------------------------------
16933       real(kind=8) function harmonicprim(y,ymax)
16934       real(kind=8) :: y,ymin,ymax
16935       real(kind=8) :: wykl=2.0d0
16936       harmonicprim=(y-ymax)*wykl
16937       return
16938       end function harmonicprim
16939 !-----------------------------------------------------------------------------
16940 ! gradient_p.F
16941 !-----------------------------------------------------------------------------
16942       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16943
16944       use io_base, only:intout,briefout
16945 !      implicit real*8 (a-h,o-z)
16946 !      include 'DIMENSIONS'
16947 !      include 'COMMON.CHAIN'
16948 !      include 'COMMON.DERIV'
16949 !      include 'COMMON.VAR'
16950 !      include 'COMMON.INTERACT'
16951 !      include 'COMMON.FFIELD'
16952 !      include 'COMMON.MD'
16953 !      include 'COMMON.IOUNITS'
16954       real(kind=8),external :: ufparm
16955       integer :: uiparm(1)
16956       real(kind=8) :: urparm(1)
16957       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16958       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16959       integer :: n,nf,ind,ind1,i,k,j
16960 !
16961 ! This subroutine calculates total internal coordinate gradient.
16962 ! Depending on the number of function evaluations, either whole energy
16963 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16964 ! internal coordinates are reevaluated or only the cartesian-in-internal
16965 ! coordinate derivatives are evaluated. The subroutine was designed to work
16966 ! with SUMSL.
16967 !
16968 !
16969       icg=mod(nf,2)+1
16970
16971 !d      print *,'grad',nf,icg
16972       if (nf-nfl+1) 20,30,40
16973    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16974 !    write (iout,*) 'grad 20'
16975       if (nf.eq.0) return
16976       goto 40
16977    30 call var_to_geom(n,x)
16978       call chainbuild
16979 !    write (iout,*) 'grad 30'
16980 !
16981 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16982 !
16983    40 call cartder
16984 !     write (iout,*) 'grad 40'
16985 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16986 !
16987 ! Convert the Cartesian gradient into internal-coordinate gradient.
16988 !
16989       ind=0
16990       ind1=0
16991       do i=1,nres-2
16992       gthetai=0.0D0
16993       gphii=0.0D0
16994       do j=i+1,nres-1
16995           ind=ind+1
16996 !         ind=indmat(i,j)
16997 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16998         do k=1,3
16999             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17000           enddo
17001         do k=1,3
17002           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17003           enddo
17004         enddo
17005       do j=i+1,nres-1
17006           ind1=ind1+1
17007 !         ind1=indmat(i,j)
17008 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17009         do k=1,3
17010           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17011           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17012           enddo
17013         enddo
17014       if (i.gt.1) g(i-1)=gphii
17015       if (n.gt.nphi) g(nphi+i)=gthetai
17016       enddo
17017       if (n.le.nphi+ntheta) goto 10
17018       do i=2,nres-1
17019       if (itype(i,1).ne.10) then
17020           galphai=0.0D0
17021         gomegai=0.0D0
17022         do k=1,3
17023           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17024           enddo
17025         do k=1,3
17026           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17027           enddo
17028           g(ialph(i,1))=galphai
17029         g(ialph(i,1)+nside)=gomegai
17030         endif
17031       enddo
17032 !
17033 ! Add the components corresponding to local energy terms.
17034 !
17035    10 continue
17036       do i=1,nvar
17037 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17038         g(i)=g(i)+gloc(i,icg)
17039       enddo
17040 ! Uncomment following three lines for diagnostics.
17041 !d    call intout
17042 !elwrite(iout,*) "in gradient after calling intout"
17043 !d    call briefout(0,0.0d0)
17044 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17045       return
17046       end subroutine gradient
17047 !-----------------------------------------------------------------------------
17048       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17049
17050       use comm_chu
17051 !      implicit real*8 (a-h,o-z)
17052 !      include 'DIMENSIONS'
17053 !      include 'COMMON.DERIV'
17054 !      include 'COMMON.IOUNITS'
17055 !      include 'COMMON.GEO'
17056       integer :: n,nf
17057 !el      integer :: jjj
17058 !el      common /chuju/ jjj
17059       real(kind=8) :: energia(0:n_ene)
17060       integer :: uiparm(1)
17061       real(kind=8) :: urparm(1)
17062       real(kind=8) :: f
17063       real(kind=8),external :: ufparm
17064       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17065 !     if (jjj.gt.0) then
17066 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17067 !     endif
17068       nfl=nf
17069       icg=mod(nf,2)+1
17070 !d      print *,'func',nf,nfl,icg
17071       call var_to_geom(n,x)
17072       call zerograd
17073       call chainbuild
17074 !d    write (iout,*) 'ETOTAL called from FUNC'
17075       call etotal(energia)
17076       call sum_gradient
17077       f=energia(0)
17078 !     if (jjj.gt.0) then
17079 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17080 !       write (iout,*) 'f=',etot
17081 !       jjj=0
17082 !     endif
17083       return
17084       end subroutine func
17085 !-----------------------------------------------------------------------------
17086       subroutine cartgrad
17087 !      implicit real*8 (a-h,o-z)
17088 !      include 'DIMENSIONS'
17089       use energy_data
17090       use MD_data, only: totT,usampl,eq_time
17091 #ifdef MPI
17092       include 'mpif.h'
17093 #endif
17094 !      include 'COMMON.CHAIN'
17095 !      include 'COMMON.DERIV'
17096 !      include 'COMMON.VAR'
17097 !      include 'COMMON.INTERACT'
17098 !      include 'COMMON.FFIELD'
17099 !      include 'COMMON.MD'
17100 !      include 'COMMON.IOUNITS'
17101 !      include 'COMMON.TIME1'
17102 !
17103       integer :: i,j
17104
17105 ! This subrouting calculates total Cartesian coordinate gradient.
17106 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17107 !
17108 !#define DEBUG
17109 #ifdef TIMING
17110       time00=MPI_Wtime()
17111 #endif
17112       icg=1
17113       call sum_gradient
17114 #ifdef TIMING
17115 #endif
17116 !#define DEBUG
17117 !el      write (iout,*) "After sum_gradient"
17118 #ifdef DEBUG
17119 !el      write (iout,*) "After sum_gradient"
17120       do i=1,nres-1
17121         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17122         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17123       enddo
17124 #endif
17125 !#undef DEBUG
17126 ! If performing constraint dynamics, add the gradients of the constraint energy
17127       if(usampl.and.totT.gt.eq_time) then
17128          do i=1,nct
17129            do j=1,3
17130              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17131              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17132            enddo
17133          enddo
17134          do i=1,nres-3
17135            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17136          enddo
17137          do i=1,nres-2
17138            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17139          enddo
17140       endif
17141 !elwrite (iout,*) "After sum_gradient"
17142 #ifdef TIMING
17143       time01=MPI_Wtime()
17144 #endif
17145       call intcartderiv
17146 !elwrite (iout,*) "After sum_gradient"
17147 #ifdef TIMING
17148       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17149 #endif
17150 !     call checkintcartgrad
17151 !     write(iout,*) 'calling int_to_cart'
17152 !#define DEBUG
17153 #ifdef DEBUG
17154       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17155 #endif
17156       do i=0,nct
17157         do j=1,3
17158           gcart(j,i)=gradc(j,i,icg)
17159           gxcart(j,i)=gradx(j,i,icg)
17160 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17161         enddo
17162 #ifdef DEBUG
17163         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17164           (gxcart(j,i),j=1,3),gloc(i,icg)
17165 #endif
17166       enddo
17167 #ifdef TIMING
17168       time01=MPI_Wtime()
17169 #endif
17170 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17171       call int_to_cart
17172 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17173
17174 #ifdef TIMING
17175             time_inttocart=time_inttocart+MPI_Wtime()-time01
17176 #endif
17177 #ifdef DEBUG
17178             write (iout,*) "gcart and gxcart after int_to_cart"
17179             do i=0,nres-1
17180             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17181                 (gxcart(j,i),j=1,3)
17182             enddo
17183 #endif
17184 !#undef DEBUG
17185 #ifdef CARGRAD
17186 #ifdef DEBUG
17187             write (iout,*) "CARGRAD"
17188 #endif
17189             do i=nres,0,-1
17190             do j=1,3
17191               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17192       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17193             enddo
17194       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17195       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17196             enddo
17197       ! Correction: dummy residues
17198             if (nnt.gt.1) then
17199               do j=1,3
17200       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17201                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17202               enddo
17203             endif
17204             if (nct.lt.nres) then
17205               do j=1,3
17206       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17207                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17208               enddo
17209             endif
17210 #endif
17211 #ifdef TIMING
17212             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17213 #endif
17214 !#undef DEBUG
17215             return
17216             end subroutine cartgrad
17217       !-----------------------------------------------------------------------------
17218             subroutine zerograd
17219       !      implicit real*8 (a-h,o-z)
17220       !      include 'DIMENSIONS'
17221       !      include 'COMMON.DERIV'
17222       !      include 'COMMON.CHAIN'
17223       !      include 'COMMON.VAR'
17224       !      include 'COMMON.MD'
17225       !      include 'COMMON.SCCOR'
17226       !
17227       !el local variables
17228             integer :: i,j,intertyp,k
17229       ! Initialize Cartesian-coordinate gradient
17230       !
17231       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17232       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17233
17234       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17235       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17236       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17237       !      allocate(gradcorr_long(3,nres))
17238       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17239       !      allocate(gcorr6_turn_long(3,nres))
17240       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17241
17242       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17243
17244       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17245       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17246
17247       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17248       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17249
17250       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17251       !      allocate(gscloc(3,nres)) !(3,maxres)
17252       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17253
17254
17255
17256       !      common /deriv_scloc/
17257       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17258       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17259       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17260       !      common /mpgrad/
17261       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17262
17263
17264
17265       !          gradc(j,i,icg)=0.0d0
17266       !          gradx(j,i,icg)=0.0d0
17267
17268       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17269       !elwrite(iout,*) "icg",icg
17270             do i=-1,nres
17271             do j=1,3
17272               gvdwx(j,i)=0.0D0
17273               gradx_scp(j,i)=0.0D0
17274               gvdwc(j,i)=0.0D0
17275               gvdwc_scp(j,i)=0.0D0
17276               gvdwc_scpp(j,i)=0.0d0
17277               gelc(j,i)=0.0D0
17278               gelc_long(j,i)=0.0D0
17279               gradb(j,i)=0.0d0
17280               gradbx(j,i)=0.0d0
17281               gvdwpp(j,i)=0.0d0
17282               gel_loc(j,i)=0.0d0
17283               gel_loc_long(j,i)=0.0d0
17284               ghpbc(j,i)=0.0D0
17285               ghpbx(j,i)=0.0D0
17286               gcorr3_turn(j,i)=0.0d0
17287               gcorr4_turn(j,i)=0.0d0
17288               gradcorr(j,i)=0.0d0
17289               gradcorr_long(j,i)=0.0d0
17290               gradcorr5_long(j,i)=0.0d0
17291               gradcorr6_long(j,i)=0.0d0
17292               gcorr6_turn_long(j,i)=0.0d0
17293               gradcorr5(j,i)=0.0d0
17294               gradcorr6(j,i)=0.0d0
17295               gcorr6_turn(j,i)=0.0d0
17296               gsccorc(j,i)=0.0d0
17297               gsccorx(j,i)=0.0d0
17298               gradc(j,i,icg)=0.0d0
17299               gradx(j,i,icg)=0.0d0
17300               gscloc(j,i)=0.0d0
17301               gsclocx(j,i)=0.0d0
17302               gliptran(j,i)=0.0d0
17303               gliptranx(j,i)=0.0d0
17304               gliptranc(j,i)=0.0d0
17305               gshieldx(j,i)=0.0d0
17306               gshieldc(j,i)=0.0d0
17307               gshieldc_loc(j,i)=0.0d0
17308               gshieldx_ec(j,i)=0.0d0
17309               gshieldc_ec(j,i)=0.0d0
17310               gshieldc_loc_ec(j,i)=0.0d0
17311               gshieldx_t3(j,i)=0.0d0
17312               gshieldc_t3(j,i)=0.0d0
17313               gshieldc_loc_t3(j,i)=0.0d0
17314               gshieldx_t4(j,i)=0.0d0
17315               gshieldc_t4(j,i)=0.0d0
17316               gshieldc_loc_t4(j,i)=0.0d0
17317               gshieldx_ll(j,i)=0.0d0
17318               gshieldc_ll(j,i)=0.0d0
17319               gshieldc_loc_ll(j,i)=0.0d0
17320               gg_tube(j,i)=0.0d0
17321               gg_tube_sc(j,i)=0.0d0
17322               gradafm(j,i)=0.0d0
17323               gradb_nucl(j,i)=0.0d0
17324               gradbx_nucl(j,i)=0.0d0
17325               gvdwpp_nucl(j,i)=0.0d0
17326               gvdwpp(j,i)=0.0d0
17327               gelpp(j,i)=0.0d0
17328               gvdwpsb(j,i)=0.0d0
17329               gvdwpsb1(j,i)=0.0d0
17330               gvdwsbc(j,i)=0.0d0
17331               gvdwsbx(j,i)=0.0d0
17332               gelsbc(j,i)=0.0d0
17333               gradcorr_nucl(j,i)=0.0d0
17334               gradcorr3_nucl(j,i)=0.0d0
17335               gradxorr_nucl(j,i)=0.0d0
17336               gradxorr3_nucl(j,i)=0.0d0
17337               gelsbx(j,i)=0.0d0
17338               gsbloc(j,i)=0.0d0
17339               gsblocx(j,i)=0.0d0
17340               gradpepcat(j,i)=0.0d0
17341               gradpepcatx(j,i)=0.0d0
17342               gradcatcat(j,i)=0.0d0
17343               gvdwx_scbase(j,i)=0.0d0
17344               gvdwc_scbase(j,i)=0.0d0
17345               gvdwx_pepbase(j,i)=0.0d0
17346               gvdwc_pepbase(j,i)=0.0d0
17347               gvdwx_scpho(j,i)=0.0d0
17348               gvdwc_scpho(j,i)=0.0d0
17349               gvdwc_peppho(j,i)=0.0d0
17350             enddo
17351              enddo
17352             do i=0,nres
17353             do j=1,3
17354               do intertyp=1,3
17355                gloc_sc(intertyp,i,icg)=0.0d0
17356               enddo
17357             enddo
17358             enddo
17359             do i=1,nres
17360              do j=1,maxcontsshi
17361              shield_list(j,i)=0
17362             do k=1,3
17363       !C           print *,i,j,k
17364                grad_shield_side(k,j,i)=0.0d0
17365                grad_shield_loc(k,j,i)=0.0d0
17366              enddo
17367              enddo
17368              ishield_list(i)=0
17369             enddo
17370
17371       !
17372       ! Initialize the gradient of local energy terms.
17373       !
17374       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17375       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17376       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17377       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17378       !      allocate(gel_loc_turn3(nres))
17379       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17380       !      allocate(gsccor_loc(nres))      !(maxres)
17381
17382             do i=1,4*nres
17383             gloc(i,icg)=0.0D0
17384             enddo
17385             do i=1,nres
17386             gel_loc_loc(i)=0.0d0
17387             gcorr_loc(i)=0.0d0
17388             g_corr5_loc(i)=0.0d0
17389             g_corr6_loc(i)=0.0d0
17390             gel_loc_turn3(i)=0.0d0
17391             gel_loc_turn4(i)=0.0d0
17392             gel_loc_turn6(i)=0.0d0
17393             gsccor_loc(i)=0.0d0
17394             enddo
17395       ! initialize gcart and gxcart
17396       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17397             do i=0,nres
17398             do j=1,3
17399               gcart(j,i)=0.0d0
17400               gxcart(j,i)=0.0d0
17401             enddo
17402             enddo
17403             return
17404             end subroutine zerograd
17405       !-----------------------------------------------------------------------------
17406             real(kind=8) function fdum()
17407             fdum=0.0D0
17408             return
17409             end function fdum
17410       !-----------------------------------------------------------------------------
17411       ! intcartderiv.F
17412       !-----------------------------------------------------------------------------
17413             subroutine intcartderiv
17414       !      implicit real*8 (a-h,o-z)
17415       !      include 'DIMENSIONS'
17416 #ifdef MPI
17417             include 'mpif.h'
17418 #endif
17419       !      include 'COMMON.SETUP'
17420       !      include 'COMMON.CHAIN'
17421       !      include 'COMMON.VAR'
17422       !      include 'COMMON.GEO'
17423       !      include 'COMMON.INTERACT'
17424       !      include 'COMMON.DERIV'
17425       !      include 'COMMON.IOUNITS'
17426       !      include 'COMMON.LOCAL'
17427       !      include 'COMMON.SCCOR'
17428             real(kind=8) :: pi4,pi34
17429             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17430             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17431                       dcosomega,dsinomega !(3,3,maxres)
17432             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17433
17434             integer :: i,j,k
17435             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17436                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17437                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17438                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17439             integer :: nres2
17440             nres2=2*nres
17441
17442       !el from module energy-------------
17443       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17444       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17445       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17446
17447       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17448       !el      allocate(dsintau(3,3,3,0:nres2))
17449       !el      allocate(dtauangle(3,3,3,0:nres2))
17450       !el      allocate(domicron(3,2,2,0:nres2))
17451       !el      allocate(dcosomicron(3,2,2,0:nres2))
17452
17453
17454
17455 #if defined(MPI) && defined(PARINTDER)
17456             if (nfgtasks.gt.1 .and. me.eq.king) &
17457             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17458 #endif
17459             pi4 = 0.5d0*pipol
17460             pi34 = 3*pi4
17461
17462       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17463       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17464
17465       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17466             do i=1,nres
17467             do j=1,3
17468               dtheta(j,1,i)=0.0d0
17469               dtheta(j,2,i)=0.0d0
17470               dphi(j,1,i)=0.0d0
17471               dphi(j,2,i)=0.0d0
17472               dphi(j,3,i)=0.0d0
17473             enddo
17474             enddo
17475       ! Derivatives of theta's
17476 #if defined(MPI) && defined(PARINTDER)
17477       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17478             do i=max0(ithet_start-1,3),ithet_end
17479 #else
17480             do i=3,nres
17481 #endif
17482             cost=dcos(theta(i))
17483             sint=sqrt(1-cost*cost)
17484             do j=1,3
17485               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17486               vbld(i-1)
17487               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17488               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17489               vbld(i)
17490               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17491             enddo
17492             enddo
17493 #if defined(MPI) && defined(PARINTDER)
17494       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17495             do i=max0(ithet_start-1,3),ithet_end
17496 #else
17497             do i=3,nres
17498 #endif
17499             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17500             cost1=dcos(omicron(1,i))
17501             sint1=sqrt(1-cost1*cost1)
17502             cost2=dcos(omicron(2,i))
17503             sint2=sqrt(1-cost2*cost2)
17504              do j=1,3
17505       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17506               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17507               cost1*dc_norm(j,i-2))/ &
17508               vbld(i-1)
17509               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17510               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17511               +cost1*(dc_norm(j,i-1+nres)))/ &
17512               vbld(i-1+nres)
17513               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17514       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17515       !C Looks messy but better than if in loop
17516               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17517               +cost2*dc_norm(j,i-1))/ &
17518               vbld(i)
17519               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17520               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17521                +cost2*(-dc_norm(j,i-1+nres)))/ &
17522               vbld(i-1+nres)
17523       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17524               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17525             enddo
17526              endif
17527             enddo
17528       !elwrite(iout,*) "after vbld write"
17529       ! Derivatives of phi:
17530       ! If phi is 0 or 180 degrees, then the formulas
17531       ! have to be derived by power series expansion of the
17532       ! conventional formulas around 0 and 180.
17533 #ifdef PARINTDER
17534             do i=iphi1_start,iphi1_end
17535 #else
17536             do i=4,nres
17537 #endif
17538       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17539       ! the conventional case
17540             sint=dsin(theta(i))
17541             sint1=dsin(theta(i-1))
17542             sing=dsin(phi(i))
17543             cost=dcos(theta(i))
17544             cost1=dcos(theta(i-1))
17545             cosg=dcos(phi(i))
17546             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17547             fac0=1.0d0/(sint1*sint)
17548             fac1=cost*fac0
17549             fac2=cost1*fac0
17550             fac3=cosg*cost1/(sint1*sint1)
17551             fac4=cosg*cost/(sint*sint)
17552       !    Obtaining the gamma derivatives from sine derivative
17553              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17554                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17555                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17556              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17557              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17558              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17559              do j=1,3
17560                 ctgt=cost/sint
17561                 ctgt1=cost1/sint1
17562                 cosg_inv=1.0d0/cosg
17563                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17564                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17565                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17566                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17567                 dsinphi(j,2,i)= &
17568                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17569                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17570                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17571                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17572                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17573       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17574                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17575                 endif
17576       ! Bug fixed 3/24/05 (AL)
17577              enddo
17578       !   Obtaining the gamma derivatives from cosine derivative
17579             else
17580                do j=1,3
17581                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17582                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17583                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17584                dc_norm(j,i-3))/vbld(i-2)
17585                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17586                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17587                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17588                dcostheta(j,1,i)
17589                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17590                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17591                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17592                dc_norm(j,i-1))/vbld(i)
17593                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17594 !#define DEBUG
17595 #ifdef DEBUG
17596                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17597 #endif
17598 !#undef DEBUG
17599                endif
17600              enddo
17601             endif
17602             enddo
17603       !alculate derivative of Tauangle
17604 #ifdef PARINTDER
17605             do i=itau_start,itau_end
17606 #else
17607             do i=3,nres
17608       !elwrite(iout,*) " vecpr",i,nres
17609 #endif
17610              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17611       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17612       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17613       !c dtauangle(j,intertyp,dervityp,residue number)
17614       !c INTERTYP=1 SC...Ca...Ca..Ca
17615       ! the conventional case
17616             sint=dsin(theta(i))
17617             sint1=dsin(omicron(2,i-1))
17618             sing=dsin(tauangle(1,i))
17619             cost=dcos(theta(i))
17620             cost1=dcos(omicron(2,i-1))
17621             cosg=dcos(tauangle(1,i))
17622       !elwrite(iout,*) " vecpr5",i,nres
17623             do j=1,3
17624       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17625       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17626             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17627       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17628             enddo
17629             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17630             fac0=1.0d0/(sint1*sint)
17631             fac1=cost*fac0
17632             fac2=cost1*fac0
17633             fac3=cosg*cost1/(sint1*sint1)
17634             fac4=cosg*cost/(sint*sint)
17635       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17636       !    Obtaining the gamma derivatives from sine derivative
17637              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17638                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17639                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17640              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17641              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17642              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17643             do j=1,3
17644                 ctgt=cost/sint
17645                 ctgt1=cost1/sint1
17646                 cosg_inv=1.0d0/cosg
17647                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17648              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17649              *vbld_inv(i-2+nres)
17650                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17651                 dsintau(j,1,2,i)= &
17652                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17653                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17654       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17655                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17656       ! Bug fixed 3/24/05 (AL)
17657                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17658                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17659       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17660                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17661              enddo
17662       !   Obtaining the gamma derivatives from cosine derivative
17663             else
17664                do j=1,3
17665                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17666                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17667                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17668                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17669                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17670                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17671                dcostheta(j,1,i)
17672                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17673                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17674                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17675                dc_norm(j,i-1))/vbld(i)
17676                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17677       !         write (iout,*) "else",i
17678              enddo
17679             endif
17680       !        do k=1,3
17681       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17682       !        enddo
17683             enddo
17684       !C Second case Ca...Ca...Ca...SC
17685 #ifdef PARINTDER
17686             do i=itau_start,itau_end
17687 #else
17688             do i=4,nres
17689 #endif
17690              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17691               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17692       ! the conventional case
17693             sint=dsin(omicron(1,i))
17694             sint1=dsin(theta(i-1))
17695             sing=dsin(tauangle(2,i))
17696             cost=dcos(omicron(1,i))
17697             cost1=dcos(theta(i-1))
17698             cosg=dcos(tauangle(2,i))
17699       !        do j=1,3
17700       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17701       !        enddo
17702             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17703             fac0=1.0d0/(sint1*sint)
17704             fac1=cost*fac0
17705             fac2=cost1*fac0
17706             fac3=cosg*cost1/(sint1*sint1)
17707             fac4=cosg*cost/(sint*sint)
17708       !    Obtaining the gamma derivatives from sine derivative
17709              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17710                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17711                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17712              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17713              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17714              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17715             do j=1,3
17716                 ctgt=cost/sint
17717                 ctgt1=cost1/sint1
17718                 cosg_inv=1.0d0/cosg
17719                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17720                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17721       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17722       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17723                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17724                 dsintau(j,2,2,i)= &
17725                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17726                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17727       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17728       !     & sing*ctgt*domicron(j,1,2,i),
17729       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17730                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17731       ! Bug fixed 3/24/05 (AL)
17732                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17733                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17734       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17735                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17736              enddo
17737       !   Obtaining the gamma derivatives from cosine derivative
17738             else
17739                do j=1,3
17740                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17741                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17742                dc_norm(j,i-3))/vbld(i-2)
17743                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17744                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17745                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17746                dcosomicron(j,1,1,i)
17747                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17748                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17749                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17750                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17751                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17752       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17753              enddo
17754             endif
17755             enddo
17756
17757       !CC third case SC...Ca...Ca...SC
17758 #ifdef PARINTDER
17759
17760             do i=itau_start,itau_end
17761 #else
17762             do i=3,nres
17763 #endif
17764       ! the conventional case
17765             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17766             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17767             sint=dsin(omicron(1,i))
17768             sint1=dsin(omicron(2,i-1))
17769             sing=dsin(tauangle(3,i))
17770             cost=dcos(omicron(1,i))
17771             cost1=dcos(omicron(2,i-1))
17772             cosg=dcos(tauangle(3,i))
17773             do j=1,3
17774             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17775       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17776             enddo
17777             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17778             fac0=1.0d0/(sint1*sint)
17779             fac1=cost*fac0
17780             fac2=cost1*fac0
17781             fac3=cosg*cost1/(sint1*sint1)
17782             fac4=cosg*cost/(sint*sint)
17783       !    Obtaining the gamma derivatives from sine derivative
17784              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17785                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17786                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17787              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17788              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17789              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17790             do j=1,3
17791                 ctgt=cost/sint
17792                 ctgt1=cost1/sint1
17793                 cosg_inv=1.0d0/cosg
17794                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17795                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17796                   *vbld_inv(i-2+nres)
17797                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17798                 dsintau(j,3,2,i)= &
17799                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17800                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17801                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17802       ! Bug fixed 3/24/05 (AL)
17803                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17804                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17805                   *vbld_inv(i-1+nres)
17806       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17807                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17808              enddo
17809       !   Obtaining the gamma derivatives from cosine derivative
17810             else
17811                do j=1,3
17812                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17813                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17814                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17815                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17816                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17817                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17818                dcosomicron(j,1,1,i)
17819                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17820                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17821                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17822                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17823                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17824       !          write(iout,*) "else",i
17825              enddo
17826             endif
17827             enddo
17828
17829 #ifdef CRYST_SC
17830       !   Derivatives of side-chain angles alpha and omega
17831 #if defined(MPI) && defined(PARINTDER)
17832             do i=ibond_start,ibond_end
17833 #else
17834             do i=2,nres-1
17835 #endif
17836               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17837                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17838                  fac6=fac5/vbld(i)
17839                  fac7=fac5*fac5
17840                  fac8=fac5/vbld(i+1)
17841                  fac9=fac5/vbld(i+nres)
17842                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17843                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17844                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17845                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17846                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17847                  sina=sqrt(1-cosa*cosa)
17848                  sino=dsin(omeg(i))
17849       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17850                  do j=1,3
17851                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17852                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17853                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17854                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17855                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17856                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17857                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17858                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17859                   vbld(i+nres))
17860                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17861                 enddo
17862       ! obtaining the derivatives of omega from sines
17863                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17864                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17865                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17866                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17867                    dsin(theta(i+1)))
17868                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17869                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17870                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17871                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17872                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17873                    coso_inv=1.0d0/dcos(omeg(i))
17874                    do j=1,3
17875                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17876                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17877                    (sino*dc_norm(j,i-1))/vbld(i)
17878                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17879                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17880                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17881                    -sino*dc_norm(j,i)/vbld(i+1)
17882                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17883                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17884                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17885                    vbld(i+nres)
17886                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17887                   enddo
17888                else
17889       !   obtaining the derivatives of omega from cosines
17890                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17891                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17892                  fac12=fac10*sina
17893                  fac13=fac12*fac12
17894                  fac14=sina*sina
17895                  do j=1,3
17896                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17897                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17898                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17899                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17900                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17901                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17902                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17903                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17904                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17905                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17906                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17907                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17908                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17909                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17910                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17911                 enddo
17912               endif
17913              else
17914                do j=1,3
17915                  do k=1,3
17916                    dalpha(k,j,i)=0.0d0
17917                    domega(k,j,i)=0.0d0
17918                  enddo
17919                enddo
17920              endif
17921              enddo
17922 #endif
17923 #if defined(MPI) && defined(PARINTDER)
17924             if (nfgtasks.gt.1) then
17925 #ifdef DEBUG
17926       !d      write (iout,*) "Gather dtheta"
17927       !d      call flush(iout)
17928             write (iout,*) "dtheta before gather"
17929             do i=1,nres
17930             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17931             enddo
17932 #endif
17933             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17934             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17935             king,FG_COMM,IERROR)
17936 !#define DEBUG
17937 #ifdef DEBUG
17938       !d      write (iout,*) "Gather dphi"
17939       !d      call flush(iout)
17940             write (iout,*) "dphi before gather"
17941             do i=1,nres
17942             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17943             enddo
17944 #endif
17945 !#undef DEBUG
17946             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17947             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17948             king,FG_COMM,IERROR)
17949       !d      write (iout,*) "Gather dalpha"
17950       !d      call flush(iout)
17951 #ifdef CRYST_SC
17952             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17953             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17954             king,FG_COMM,IERROR)
17955       !d      write (iout,*) "Gather domega"
17956       !d      call flush(iout)
17957             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17958             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17959             king,FG_COMM,IERROR)
17960 #endif
17961             endif
17962 #endif
17963 !#define DEBUG
17964 #ifdef DEBUG
17965             write (iout,*) "dtheta after gather"
17966             do i=1,nres
17967             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17968             enddo
17969             write (iout,*) "dphi after gather"
17970             do i=1,nres
17971             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17972             enddo
17973             write (iout,*) "dalpha after gather"
17974             do i=1,nres
17975             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17976             enddo
17977             write (iout,*) "domega after gather"
17978             do i=1,nres
17979             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17980             enddo
17981 #endif
17982 !#undef DEBUG
17983             return
17984             end subroutine intcartderiv
17985       !-----------------------------------------------------------------------------
17986             subroutine checkintcartgrad
17987       !      implicit real*8 (a-h,o-z)
17988       !      include 'DIMENSIONS'
17989 #ifdef MPI
17990             include 'mpif.h'
17991 #endif
17992       !      include 'COMMON.CHAIN'
17993       !      include 'COMMON.VAR'
17994       !      include 'COMMON.GEO'
17995       !      include 'COMMON.INTERACT'
17996       !      include 'COMMON.DERIV'
17997       !      include 'COMMON.IOUNITS'
17998       !      include 'COMMON.SETUP'
17999             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18000             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18001             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18002             real(kind=8),dimension(3) :: dc_norm_s
18003             real(kind=8) :: aincr=1.0d-5
18004             integer :: i,j
18005             real(kind=8) :: dcji
18006             do i=1,nres
18007             phi_s(i)=phi(i)
18008             theta_s(i)=theta(i)
18009             alph_s(i)=alph(i)
18010             omeg_s(i)=omeg(i)
18011             enddo
18012       ! Check theta gradient
18013             write (iout,*) &
18014              "Analytical (upper) and numerical (lower) gradient of theta"
18015             write (iout,*)
18016             do i=3,nres
18017             do j=1,3
18018               dcji=dc(j,i-2)
18019               dc(j,i-2)=dcji+aincr
18020               call chainbuild_cart
18021               call int_from_cart1(.false.)
18022           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18023           dc(j,i-2)=dcji
18024           dcji=dc(j,i-1)
18025           dc(j,i-1)=dc(j,i-1)+aincr
18026           call chainbuild_cart
18027           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18028           dc(j,i-1)=dcji
18029         enddo
18030 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18031 !el          (dtheta(j,2,i),j=1,3)
18032 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18033 !el          (dthetanum(j,2,i),j=1,3)
18034 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18035 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18036 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18037 !el        write (iout,*)
18038       enddo
18039 ! Check gamma gradient
18040       write (iout,*) &
18041        "Analytical (upper) and numerical (lower) gradient of gamma"
18042       do i=4,nres
18043         do j=1,3
18044           dcji=dc(j,i-3)
18045           dc(j,i-3)=dcji+aincr
18046           call chainbuild_cart
18047           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18048               dc(j,i-3)=dcji
18049           dcji=dc(j,i-2)
18050           dc(j,i-2)=dcji+aincr
18051           call chainbuild_cart
18052           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18053           dc(j,i-2)=dcji
18054           dcji=dc(j,i-1)
18055           dc(j,i-1)=dc(j,i-1)+aincr
18056           call chainbuild_cart
18057           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18058           dc(j,i-1)=dcji
18059         enddo
18060 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18061 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18062 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18063 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18064 !el        write (iout,'(5x,3(3f10.5,5x))') &
18065 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18066 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18067 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18068 !el        write (iout,*)
18069       enddo
18070 ! Check alpha gradient
18071       write (iout,*) &
18072        "Analytical (upper) and numerical (lower) gradient of alpha"
18073       do i=2,nres-1
18074        if(itype(i,1).ne.10) then
18075                  do j=1,3
18076                   dcji=dc(j,i-1)
18077                    dc(j,i-1)=dcji+aincr
18078               call chainbuild_cart
18079               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18080                  /aincr
18081                   dc(j,i-1)=dcji
18082               dcji=dc(j,i)
18083               dc(j,i)=dcji+aincr
18084               call chainbuild_cart
18085               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18086                  /aincr
18087               dc(j,i)=dcji
18088               dcji=dc(j,i+nres)
18089               dc(j,i+nres)=dc(j,i+nres)+aincr
18090               call chainbuild_cart
18091               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18092                  /aincr
18093              dc(j,i+nres)=dcji
18094             enddo
18095           endif
18096 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18097 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18098 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18099 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18100 !el        write (iout,'(5x,3(3f10.5,5x))') &
18101 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18102 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18103 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18104 !el        write (iout,*)
18105       enddo
18106 !     Check omega gradient
18107       write (iout,*) &
18108        "Analytical (upper) and numerical (lower) gradient of omega"
18109       do i=2,nres-1
18110        if(itype(i,1).ne.10) then
18111                  do j=1,3
18112                   dcji=dc(j,i-1)
18113                    dc(j,i-1)=dcji+aincr
18114               call chainbuild_cart
18115               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18116                  /aincr
18117                   dc(j,i-1)=dcji
18118               dcji=dc(j,i)
18119               dc(j,i)=dcji+aincr
18120               call chainbuild_cart
18121               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18122                  /aincr
18123               dc(j,i)=dcji
18124               dcji=dc(j,i+nres)
18125               dc(j,i+nres)=dc(j,i+nres)+aincr
18126               call chainbuild_cart
18127               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18128                  /aincr
18129              dc(j,i+nres)=dcji
18130             enddo
18131           endif
18132 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18133 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18134 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18135 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18136 !el        write (iout,'(5x,3(3f10.5,5x))') &
18137 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18138 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18139 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18140 !el        write (iout,*)
18141       enddo
18142       return
18143       end subroutine checkintcartgrad
18144 !-----------------------------------------------------------------------------
18145 ! q_measure.F
18146 !-----------------------------------------------------------------------------
18147       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18148 !      implicit real*8 (a-h,o-z)
18149 !      include 'DIMENSIONS'
18150 !      include 'COMMON.IOUNITS'
18151 !      include 'COMMON.CHAIN'
18152 !      include 'COMMON.INTERACT'
18153 !      include 'COMMON.VAR'
18154       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18155       integer :: kkk,nsep=3
18156       real(kind=8) :: qm      !dist,
18157       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18158       logical :: lprn=.false.
18159       logical :: flag
18160 !      real(kind=8) :: sigm,x
18161
18162 !el      sigm(x)=0.25d0*x     ! local function
18163       qqmax=1.0d10
18164       do kkk=1,nperm
18165       qq = 0.0d0
18166       nl=0
18167        if(flag) then
18168         do il=seg1+nsep,seg2
18169           do jl=seg1,il-nsep
18170             nl=nl+1
18171             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18172                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18173                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18174             dij=dist(il,jl)
18175             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18176             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18177               nl=nl+1
18178               d0ijCM=dsqrt( &
18179                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18180                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18181                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18182               dijCM=dist(il+nres,jl+nres)
18183               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18184             endif
18185             qq = qq+qqij+qqijCM
18186           enddo
18187         enddo
18188         qq = qq/nl
18189       else
18190       do il=seg1,seg2
18191         if((seg3-il).lt.3) then
18192              secseg=il+3
18193         else
18194              secseg=seg3
18195         endif
18196           do jl=secseg,seg4
18197             nl=nl+1
18198             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18199                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18200                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18201             dij=dist(il,jl)
18202             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18203             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18204               nl=nl+1
18205               d0ijCM=dsqrt( &
18206                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18207                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18208                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18209               dijCM=dist(il+nres,jl+nres)
18210               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18211             endif
18212             qq = qq+qqij+qqijCM
18213           enddo
18214         enddo
18215       qq = qq/nl
18216       endif
18217       if (qqmax.le.qq) qqmax=qq
18218       enddo
18219       qwolynes=1.0d0-qqmax
18220       return
18221       end function qwolynes
18222 !-----------------------------------------------------------------------------
18223       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18224 !      implicit real*8 (a-h,o-z)
18225 !      include 'DIMENSIONS'
18226 !      include 'COMMON.IOUNITS'
18227 !      include 'COMMON.CHAIN'
18228 !      include 'COMMON.INTERACT'
18229 !      include 'COMMON.VAR'
18230 !      include 'COMMON.MD'
18231       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18232       integer :: nsep=3, kkk
18233 !el      real(kind=8) :: dist
18234       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18235       logical :: lprn=.false.
18236       logical :: flag
18237       real(kind=8) :: sim,dd0,fac,ddqij
18238 !el      sigm(x)=0.25d0*x           ! local function
18239       do kkk=1,nperm
18240       do i=0,nres
18241         do j=1,3
18242           dqwol(j,i)=0.0d0
18243           dxqwol(j,i)=0.0d0
18244         enddo
18245       enddo
18246       nl=0
18247        if(flag) then
18248         do il=seg1+nsep,seg2
18249           do jl=seg1,il-nsep
18250             nl=nl+1
18251             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18252                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18253                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18254             dij=dist(il,jl)
18255             sim = 1.0d0/sigm(d0ij)
18256             sim = sim*sim
18257             dd0 = dij-d0ij
18258             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18259           do k=1,3
18260               ddqij = (c(k,il)-c(k,jl))*fac
18261               dqwol(k,il)=dqwol(k,il)+ddqij
18262               dqwol(k,jl)=dqwol(k,jl)-ddqij
18263             enddo
18264
18265             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18266               nl=nl+1
18267               d0ijCM=dsqrt( &
18268                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18269                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18270                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18271               dijCM=dist(il+nres,jl+nres)
18272               sim = 1.0d0/sigm(d0ijCM)
18273               sim = sim*sim
18274               dd0=dijCM-d0ijCM
18275               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18276               do k=1,3
18277                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18278                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18279                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18280               enddo
18281             endif
18282           enddo
18283         enddo
18284        else
18285         do il=seg1,seg2
18286         if((seg3-il).lt.3) then
18287              secseg=il+3
18288         else
18289              secseg=seg3
18290         endif
18291           do jl=secseg,seg4
18292             nl=nl+1
18293             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18294                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18295                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18296             dij=dist(il,jl)
18297             sim = 1.0d0/sigm(d0ij)
18298             sim = sim*sim
18299             dd0 = dij-d0ij
18300             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18301             do k=1,3
18302               ddqij = (c(k,il)-c(k,jl))*fac
18303               dqwol(k,il)=dqwol(k,il)+ddqij
18304               dqwol(k,jl)=dqwol(k,jl)-ddqij
18305             enddo
18306             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18307               nl=nl+1
18308               d0ijCM=dsqrt( &
18309                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18310                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18311                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18312               dijCM=dist(il+nres,jl+nres)
18313               sim = 1.0d0/sigm(d0ijCM)
18314               sim=sim*sim
18315               dd0 = dijCM-d0ijCM
18316               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18317               do k=1,3
18318                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18319                dxqwol(k,il)=dxqwol(k,il)+ddqij
18320                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18321               enddo
18322             endif
18323           enddo
18324         enddo
18325       endif
18326       enddo
18327        do i=0,nres
18328          do j=1,3
18329            dqwol(j,i)=dqwol(j,i)/nl
18330            dxqwol(j,i)=dxqwol(j,i)/nl
18331          enddo
18332        enddo
18333       return
18334       end subroutine qwolynes_prim
18335 !-----------------------------------------------------------------------------
18336       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18337 !      implicit real*8 (a-h,o-z)
18338 !      include 'DIMENSIONS'
18339 !      include 'COMMON.IOUNITS'
18340 !      include 'COMMON.CHAIN'
18341 !      include 'COMMON.INTERACT'
18342 !      include 'COMMON.VAR'
18343       integer :: seg1,seg2,seg3,seg4
18344       logical :: flag
18345       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18346       real(kind=8),dimension(3,0:2*nres) :: cdummy
18347       real(kind=8) :: q1,q2
18348       real(kind=8) :: delta=1.0d-10
18349       integer :: i,j
18350
18351       do i=0,nres
18352         do j=1,3
18353           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18354           cdummy(j,i)=c(j,i)
18355           c(j,i)=c(j,i)+delta
18356           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18357           qwolan(j,i)=(q2-q1)/delta
18358           c(j,i)=cdummy(j,i)
18359         enddo
18360       enddo
18361       do i=0,nres
18362         do j=1,3
18363           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18364           cdummy(j,i+nres)=c(j,i+nres)
18365           c(j,i+nres)=c(j,i+nres)+delta
18366           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18367           qwolxan(j,i)=(q2-q1)/delta
18368           c(j,i+nres)=cdummy(j,i+nres)
18369         enddo
18370       enddo
18371 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18372 !      do i=0,nct
18373 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18374 !      enddo
18375 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18376 !      do i=0,nct
18377 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18378 !      enddo
18379       return
18380       end subroutine qwol_num
18381 !-----------------------------------------------------------------------------
18382       subroutine EconstrQ
18383 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18384 !      implicit real*8 (a-h,o-z)
18385 !      include 'DIMENSIONS'
18386 !      include 'COMMON.CONTROL'
18387 !      include 'COMMON.VAR'
18388 !      include 'COMMON.MD'
18389       use MD_data
18390 !#ifndef LANG0
18391 !      include 'COMMON.LANGEVIN'
18392 !#else
18393 !      include 'COMMON.LANGEVIN.lang0'
18394 !#endif
18395 !      include 'COMMON.CHAIN'
18396 !      include 'COMMON.DERIV'
18397 !      include 'COMMON.GEO'
18398 !      include 'COMMON.LOCAL'
18399 !      include 'COMMON.INTERACT'
18400 !      include 'COMMON.IOUNITS'
18401 !      include 'COMMON.NAMES'
18402 !      include 'COMMON.TIME1'
18403       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18404       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18405                    duconst,duxconst
18406       integer :: kstart,kend,lstart,lend,idummy
18407       real(kind=8) :: delta=1.0d-7
18408       integer :: i,j,k,ii
18409       do i=0,nres
18410          do j=1,3
18411             duconst(j,i)=0.0d0
18412             dudconst(j,i)=0.0d0
18413             duxconst(j,i)=0.0d0
18414             dudxconst(j,i)=0.0d0
18415          enddo
18416       enddo
18417       Uconst=0.0d0
18418       do i=1,nfrag
18419          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18420            idummy,idummy)
18421          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18422 ! Calculating the derivatives of Constraint energy with respect to Q
18423          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18424            qinfrag(i,iset))
18425 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18426 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18427 !         hmnum=(hm2-hm1)/delta
18428 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18429 !     &   qinfrag(i,iset))
18430 !         write(iout,*) "harmonicnum frag", hmnum
18431 ! Calculating the derivatives of Q with respect to cartesian coordinates
18432          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18433           idummy,idummy)
18434 !         write(iout,*) "dqwol "
18435 !         do ii=1,nres
18436 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18437 !         enddo
18438 !         write(iout,*) "dxqwol "
18439 !         do ii=1,nres
18440 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18441 !         enddo
18442 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18443 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18444 !     &  ,idummy,idummy)
18445 !  The gradients of Uconst in Cs
18446          do ii=0,nres
18447             do j=1,3
18448                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18449                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18450             enddo
18451          enddo
18452       enddo
18453       do i=1,npair
18454          kstart=ifrag(1,ipair(1,i,iset),iset)
18455          kend=ifrag(2,ipair(1,i,iset),iset)
18456          lstart=ifrag(1,ipair(2,i,iset),iset)
18457          lend=ifrag(2,ipair(2,i,iset),iset)
18458          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18459          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18460 !  Calculating dU/dQ
18461          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18462 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18463 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18464 !         hmnum=(hm2-hm1)/delta
18465 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18466 !     &   qinpair(i,iset))
18467 !         write(iout,*) "harmonicnum pair ", hmnum
18468 ! Calculating dQ/dXi
18469          call qwolynes_prim(kstart,kend,.false.,&
18470           lstart,lend)
18471 !         write(iout,*) "dqwol "
18472 !         do ii=1,nres
18473 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18474 !         enddo
18475 !         write(iout,*) "dxqwol "
18476 !         do ii=1,nres
18477 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18478 !        enddo
18479 ! Calculating numerical gradients
18480 !        call qwol_num(kstart,kend,.false.
18481 !     &  ,lstart,lend)
18482 ! The gradients of Uconst in Cs
18483          do ii=0,nres
18484             do j=1,3
18485                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18486                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18487             enddo
18488          enddo
18489       enddo
18490 !      write(iout,*) "Uconst inside subroutine ", Uconst
18491 ! Transforming the gradients from Cs to dCs for the backbone
18492       do i=0,nres
18493          do j=i+1,nres
18494            do k=1,3
18495              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18496            enddo
18497          enddo
18498       enddo
18499 !  Transforming the gradients from Cs to dCs for the side chains
18500       do i=1,nres
18501          do j=1,3
18502            dudxconst(j,i)=duxconst(j,i)
18503          enddo
18504       enddo
18505 !      write(iout,*) "dU/ddc backbone "
18506 !       do ii=0,nres
18507 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18508 !      enddo
18509 !      write(iout,*) "dU/ddX side chain "
18510 !      do ii=1,nres
18511 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18512 !      enddo
18513 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18514 !      call dEconstrQ_num
18515       return
18516       end subroutine EconstrQ
18517 !-----------------------------------------------------------------------------
18518       subroutine dEconstrQ_num
18519 ! Calculating numerical dUconst/ddc and dUconst/ddx
18520 !      implicit real*8 (a-h,o-z)
18521 !      include 'DIMENSIONS'
18522 !      include 'COMMON.CONTROL'
18523 !      include 'COMMON.VAR'
18524 !      include 'COMMON.MD'
18525       use MD_data
18526 !#ifndef LANG0
18527 !      include 'COMMON.LANGEVIN'
18528 !#else
18529 !      include 'COMMON.LANGEVIN.lang0'
18530 !#endif
18531 !      include 'COMMON.CHAIN'
18532 !      include 'COMMON.DERIV'
18533 !      include 'COMMON.GEO'
18534 !      include 'COMMON.LOCAL'
18535 !      include 'COMMON.INTERACT'
18536 !      include 'COMMON.IOUNITS'
18537 !      include 'COMMON.NAMES'
18538 !      include 'COMMON.TIME1'
18539       real(kind=8) :: uzap1,uzap2
18540       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18541       integer :: kstart,kend,lstart,lend,idummy
18542       real(kind=8) :: delta=1.0d-7
18543 !el local variables
18544       integer :: i,ii,j
18545 !     real(kind=8) ::
18546 !     For the backbone
18547       do i=0,nres-1
18548          do j=1,3
18549             dUcartan(j,i)=0.0d0
18550             cdummy(j,i)=dc(j,i)
18551             dc(j,i)=dc(j,i)+delta
18552             call chainbuild_cart
18553           uzap2=0.0d0
18554             do ii=1,nfrag
18555              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18556                 idummy,idummy)
18557                uzap2=uzap2+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                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18567                  qinpair(ii,iset))
18568             enddo
18569             dc(j,i)=cdummy(j,i)
18570             call chainbuild_cart
18571             uzap1=0.0d0
18572              do ii=1,nfrag
18573              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18574                 idummy,idummy)
18575                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18576                 qinfrag(ii,iset))
18577             enddo
18578             do ii=1,npair
18579                kstart=ifrag(1,ipair(1,ii,iset),iset)
18580                kend=ifrag(2,ipair(1,ii,iset),iset)
18581                lstart=ifrag(1,ipair(2,ii,iset),iset)
18582                lend=ifrag(2,ipair(2,ii,iset),iset)
18583                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18584                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18585                 qinpair(ii,iset))
18586             enddo
18587             ducartan(j,i)=(uzap2-uzap1)/(delta)
18588          enddo
18589       enddo
18590 ! Calculating numerical gradients for dU/ddx
18591       do i=0,nres-1
18592          duxcartan(j,i)=0.0d0
18593          do j=1,3
18594             cdummy(j,i)=dc(j,i+nres)
18595             dc(j,i+nres)=dc(j,i+nres)+delta
18596             call chainbuild_cart
18597           uzap2=0.0d0
18598             do ii=1,nfrag
18599              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18600                 idummy,idummy)
18601                uzap2=uzap2+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                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18611                 qinpair(ii,iset))
18612             enddo
18613             dc(j,i+nres)=cdummy(j,i)
18614             call chainbuild_cart
18615             uzap1=0.0d0
18616              do ii=1,nfrag
18617                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18618                 ifrag(2,ii,iset),.true.,idummy,idummy)
18619                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18620                 qinfrag(ii,iset))
18621             enddo
18622             do ii=1,npair
18623                kstart=ifrag(1,ipair(1,ii,iset),iset)
18624                kend=ifrag(2,ipair(1,ii,iset),iset)
18625                lstart=ifrag(1,ipair(2,ii,iset),iset)
18626                lend=ifrag(2,ipair(2,ii,iset),iset)
18627                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18628                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18629                 qinpair(ii,iset))
18630             enddo
18631             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18632          enddo
18633       enddo
18634       write(iout,*) "Numerical dUconst/ddc backbone "
18635       do ii=0,nres
18636         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18637       enddo
18638 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18639 !      do ii=1,nres
18640 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18641 !      enddo
18642       return
18643       end subroutine dEconstrQ_num
18644 !-----------------------------------------------------------------------------
18645 ! ssMD.F
18646 !-----------------------------------------------------------------------------
18647       subroutine check_energies
18648
18649 !      use random, only: ran_number
18650
18651 !      implicit none
18652 !     Includes
18653 !      include 'DIMENSIONS'
18654 !      include 'COMMON.CHAIN'
18655 !      include 'COMMON.VAR'
18656 !      include 'COMMON.IOUNITS'
18657 !      include 'COMMON.SBRIDGE'
18658 !      include 'COMMON.LOCAL'
18659 !      include 'COMMON.GEO'
18660
18661 !     External functions
18662 !EL      double precision ran_number
18663 !EL      external ran_number
18664
18665 !     Local variables
18666       integer :: i,j,k,l,lmax,p,pmax
18667       real(kind=8) :: rmin,rmax
18668       real(kind=8) :: eij
18669
18670       real(kind=8) :: d
18671       real(kind=8) :: wi,rij,tj,pj
18672 !      return
18673
18674       i=5
18675       j=14
18676
18677       d=dsc(1)
18678       rmin=2.0D0
18679       rmax=12.0D0
18680
18681       lmax=10000
18682       pmax=1
18683
18684       do k=1,3
18685         c(k,i)=0.0D0
18686         c(k,j)=0.0D0
18687         c(k,nres+i)=0.0D0
18688         c(k,nres+j)=0.0D0
18689       enddo
18690
18691       do l=1,lmax
18692
18693 !t        wi=ran_number(0.0D0,pi)
18694 !        wi=ran_number(0.0D0,pi/6.0D0)
18695 !        wi=0.0D0
18696 !t        tj=ran_number(0.0D0,pi)
18697 !t        pj=ran_number(0.0D0,pi)
18698 !        pj=ran_number(0.0D0,pi/6.0D0)
18699 !        pj=0.0D0
18700
18701         do p=1,pmax
18702 !t           rij=ran_number(rmin,rmax)
18703
18704            c(1,j)=d*sin(pj)*cos(tj)
18705            c(2,j)=d*sin(pj)*sin(tj)
18706            c(3,j)=d*cos(pj)
18707
18708            c(3,nres+i)=-rij
18709
18710            c(1,i)=d*sin(wi)
18711            c(3,i)=-rij-d*cos(wi)
18712
18713            do k=1,3
18714               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18715               dc_norm(k,nres+i)=dc(k,nres+i)/d
18716               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18717               dc_norm(k,nres+j)=dc(k,nres+j)/d
18718            enddo
18719
18720            call dyn_ssbond_ene(i,j,eij)
18721         enddo
18722       enddo
18723       call exit(1)
18724       return
18725       end subroutine check_energies
18726 !-----------------------------------------------------------------------------
18727       subroutine dyn_ssbond_ene(resi,resj,eij)
18728 !      implicit none
18729 !      Includes
18730       use calc_data
18731       use comm_sschecks
18732 !      include 'DIMENSIONS'
18733 !      include 'COMMON.SBRIDGE'
18734 !      include 'COMMON.CHAIN'
18735 !      include 'COMMON.DERIV'
18736 !      include 'COMMON.LOCAL'
18737 !      include 'COMMON.INTERACT'
18738 !      include 'COMMON.VAR'
18739 !      include 'COMMON.IOUNITS'
18740 !      include 'COMMON.CALC'
18741 #ifndef CLUST
18742 #ifndef WHAM
18743        use MD_data
18744 !      include 'COMMON.MD'
18745 !      use MD, only: totT,t_bath
18746 #endif
18747 #endif
18748 !     External functions
18749 !EL      double precision h_base
18750 !EL      external h_base
18751
18752 !     Input arguments
18753       integer :: resi,resj
18754
18755 !     Output arguments
18756       real(kind=8) :: eij
18757
18758 !     Local variables
18759       logical :: havebond
18760       integer itypi,itypj
18761       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18762       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18763       real(kind=8),dimension(3) :: dcosom1,dcosom2
18764       real(kind=8) :: ed
18765       real(kind=8) :: pom1,pom2
18766       real(kind=8) :: ljA,ljB,ljXs
18767       real(kind=8),dimension(1:3) :: d_ljB
18768       real(kind=8) :: ssA,ssB,ssC,ssXs
18769       real(kind=8) :: ssxm,ljxm,ssm,ljm
18770       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18771       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18772       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18773 !-------FIRST METHOD
18774       real(kind=8) :: xm
18775       real(kind=8),dimension(1:3) :: d_xm
18776 !-------END FIRST METHOD
18777 !-------SECOND METHOD
18778 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18779 !-------END SECOND METHOD
18780
18781 !-------TESTING CODE
18782 !el      logical :: checkstop,transgrad
18783 !el      common /sschecks/ checkstop,transgrad
18784
18785       integer :: icheck,nicheck,jcheck,njcheck
18786       real(kind=8),dimension(-1:1) :: echeck
18787       real(kind=8) :: deps,ssx0,ljx0
18788 !-------END TESTING CODE
18789
18790       eij=0.0d0
18791       i=resi
18792       j=resj
18793
18794 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18795 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18796
18797       itypi=itype(i,1)
18798       dxi=dc_norm(1,nres+i)
18799       dyi=dc_norm(2,nres+i)
18800       dzi=dc_norm(3,nres+i)
18801       dsci_inv=vbld_inv(i+nres)
18802
18803       itypj=itype(j,1)
18804       xj=c(1,nres+j)-c(1,nres+i)
18805       yj=c(2,nres+j)-c(2,nres+i)
18806       zj=c(3,nres+j)-c(3,nres+i)
18807       dxj=dc_norm(1,nres+j)
18808       dyj=dc_norm(2,nres+j)
18809       dzj=dc_norm(3,nres+j)
18810       dscj_inv=vbld_inv(j+nres)
18811
18812       chi1=chi(itypi,itypj)
18813       chi2=chi(itypj,itypi)
18814       chi12=chi1*chi2
18815       chip1=chip(itypi)
18816       chip2=chip(itypj)
18817       chip12=chip1*chip2
18818       alf1=alp(itypi)
18819       alf2=alp(itypj)
18820       alf12=0.5D0*(alf1+alf2)
18821
18822       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18823       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18824 !     The following are set in sc_angular
18825 !      erij(1)=xj*rij
18826 !      erij(2)=yj*rij
18827 !      erij(3)=zj*rij
18828 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18829 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18830 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18831       call sc_angular
18832       rij=1.0D0/rij  ! Reset this so it makes sense
18833
18834       sig0ij=sigma(itypi,itypj)
18835       sig=sig0ij*dsqrt(1.0D0/sigsq)
18836
18837       ljXs=sig-sig0ij
18838       ljA=eps1*eps2rt**2*eps3rt**2
18839       ljB=ljA*bb_aq(itypi,itypj)
18840       ljA=ljA*aa_aq(itypi,itypj)
18841       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18842
18843       ssXs=d0cm
18844       deltat1=1.0d0-om1
18845       deltat2=1.0d0+om2
18846       deltat12=om2-om1+2.0d0
18847       cosphi=om12-om1*om2
18848       ssA=akcm
18849       ssB=akct*deltat12
18850       ssC=ss_depth &
18851            +akth*(deltat1*deltat1+deltat2*deltat2) &
18852            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18853       ssxm=ssXs-0.5D0*ssB/ssA
18854
18855 !-------TESTING CODE
18856 !$$$c     Some extra output
18857 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18858 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18859 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18860 !$$$      if (ssx0.gt.0.0d0) then
18861 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18862 !$$$      else
18863 !$$$        ssx0=ssxm
18864 !$$$      endif
18865 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18866 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18867 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18868 !$$$      return
18869 !-------END TESTING CODE
18870
18871 !-------TESTING CODE
18872 !     Stop and plot energy and derivative as a function of distance
18873       if (checkstop) then
18874         ssm=ssC-0.25D0*ssB*ssB/ssA
18875         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18876         if (ssm.lt.ljm .and. &
18877              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18878           nicheck=1000
18879           njcheck=1
18880           deps=0.5d-7
18881         else
18882           checkstop=.false.
18883         endif
18884       endif
18885       if (.not.checkstop) then
18886         nicheck=0
18887         njcheck=-1
18888       endif
18889
18890       do icheck=0,nicheck
18891       do jcheck=-1,njcheck
18892       if (checkstop) rij=(ssxm-1.0d0)+ &
18893              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18894 !-------END TESTING CODE
18895
18896       if (rij.gt.ljxm) then
18897         havebond=.false.
18898         ljd=rij-ljXs
18899         fac=(1.0D0/ljd)**expon
18900         e1=fac*fac*aa_aq(itypi,itypj)
18901         e2=fac*bb_aq(itypi,itypj)
18902         eij=eps1*eps2rt*eps3rt*(e1+e2)
18903         eps2der=eij*eps3rt
18904         eps3der=eij*eps2rt
18905         eij=eij*eps2rt*eps3rt
18906
18907         sigder=-sig/sigsq
18908         e1=e1*eps1*eps2rt**2*eps3rt**2
18909         ed=-expon*(e1+eij)/ljd
18910         sigder=ed*sigder
18911         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18912         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18913         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18914              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18915       else if (rij.lt.ssxm) then
18916         havebond=.true.
18917         ssd=rij-ssXs
18918         eij=ssA*ssd*ssd+ssB*ssd+ssC
18919
18920         ed=2*akcm*ssd+akct*deltat12
18921         pom1=akct*ssd
18922         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18923         eom1=-2*akth*deltat1-pom1-om2*pom2
18924         eom2= 2*akth*deltat2+pom1-om1*pom2
18925         eom12=pom2
18926       else
18927         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18928
18929         d_ssxm(1)=0.5D0*akct/ssA
18930         d_ssxm(2)=-d_ssxm(1)
18931         d_ssxm(3)=0.0D0
18932
18933         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18934         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18935         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18936         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18937
18938 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18939         xm=0.5d0*(ssxm+ljxm)
18940         do k=1,3
18941           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18942         enddo
18943         if (rij.lt.xm) then
18944           havebond=.true.
18945           ssm=ssC-0.25D0*ssB*ssB/ssA
18946           d_ssm(1)=0.5D0*akct*ssB/ssA
18947           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18948           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18949           d_ssm(3)=omega
18950           f1=(rij-xm)/(ssxm-xm)
18951           f2=(rij-ssxm)/(xm-ssxm)
18952           h1=h_base(f1,hd1)
18953           h2=h_base(f2,hd2)
18954           eij=ssm*h1+Ht*h2
18955           delta_inv=1.0d0/(xm-ssxm)
18956           deltasq_inv=delta_inv*delta_inv
18957           fac=ssm*hd1-Ht*hd2
18958           fac1=deltasq_inv*fac*(xm-rij)
18959           fac2=deltasq_inv*fac*(rij-ssxm)
18960           ed=delta_inv*(Ht*hd2-ssm*hd1)
18961           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18962           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18963           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18964         else
18965           havebond=.false.
18966           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18967           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18968           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18969           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18970                alf12/eps3rt)
18971           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18972           f1=(rij-ljxm)/(xm-ljxm)
18973           f2=(rij-xm)/(ljxm-xm)
18974           h1=h_base(f1,hd1)
18975           h2=h_base(f2,hd2)
18976           eij=Ht*h1+ljm*h2
18977           delta_inv=1.0d0/(ljxm-xm)
18978           deltasq_inv=delta_inv*delta_inv
18979           fac=Ht*hd1-ljm*hd2
18980           fac1=deltasq_inv*fac*(ljxm-rij)
18981           fac2=deltasq_inv*fac*(rij-xm)
18982           ed=delta_inv*(ljm*hd2-Ht*hd1)
18983           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18984           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18985           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18986         endif
18987 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18988
18989 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18990 !$$$        ssd=rij-ssXs
18991 !$$$        ljd=rij-ljXs
18992 !$$$        fac1=rij-ljxm
18993 !$$$        fac2=rij-ssxm
18994 !$$$
18995 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18996 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18997 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18998 !$$$
18999 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19000 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19001 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19002 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19003 !$$$        d_ssm(3)=omega
19004 !$$$
19005 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19006 !$$$        do k=1,3
19007 !$$$          d_ljm(k)=ljm*d_ljB(k)
19008 !$$$        enddo
19009 !$$$        ljm=ljm*ljB
19010 !$$$
19011 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19012 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19013 !$$$        d_ss(2)=akct*ssd
19014 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19015 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19016 !$$$        d_ss(3)=omega
19017 !$$$
19018 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19019 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19020 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19021 !$$$        do k=1,3
19022 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19023 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19024 !$$$        enddo
19025 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19026 !$$$
19027 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19028 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19029 !$$$        h1=h_base(f1,hd1)
19030 !$$$        h2=h_base(f2,hd2)
19031 !$$$        eij=ss*h1+ljf*h2
19032 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19033 !$$$        deltasq_inv=delta_inv*delta_inv
19034 !$$$        fac=ljf*hd2-ss*hd1
19035 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19036 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19037 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19038 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19039 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19040 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19041 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19042 !$$$
19043 !$$$        havebond=.false.
19044 !$$$        if (ed.gt.0.0d0) havebond=.true.
19045 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19046
19047       endif
19048
19049       if (havebond) then
19050 !#ifndef CLUST
19051 !#ifndef WHAM
19052 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19053 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19054 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19055 !        endif
19056 !#endif
19057 !#endif
19058         dyn_ssbond_ij(i,j)=eij
19059       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19060         dyn_ssbond_ij(i,j)=1.0d300
19061 !#ifndef CLUST
19062 !#ifndef WHAM
19063 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19064 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19065 !#endif
19066 !#endif
19067       endif
19068
19069 !-------TESTING CODE
19070 !el      if (checkstop) then
19071         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19072              "CHECKSTOP",rij,eij,ed
19073         echeck(jcheck)=eij
19074 !el      endif
19075       enddo
19076       if (checkstop) then
19077         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19078       endif
19079       enddo
19080       if (checkstop) then
19081         transgrad=.true.
19082         checkstop=.false.
19083       endif
19084 !-------END TESTING CODE
19085
19086       do k=1,3
19087         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19088         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19089       enddo
19090       do k=1,3
19091         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19092       enddo
19093       do k=1,3
19094         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19095              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19096              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19097         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19098              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19099              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19100       enddo
19101 !grad      do k=i,j-1
19102 !grad        do l=1,3
19103 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19104 !grad        enddo
19105 !grad      enddo
19106
19107       do l=1,3
19108         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19109         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19110       enddo
19111
19112       return
19113       end subroutine dyn_ssbond_ene
19114 !--------------------------------------------------------------------------
19115          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19116 !      implicit none
19117 !      Includes
19118       use calc_data
19119       use comm_sschecks
19120 !      include 'DIMENSIONS'
19121 !      include 'COMMON.SBRIDGE'
19122 !      include 'COMMON.CHAIN'
19123 !      include 'COMMON.DERIV'
19124 !      include 'COMMON.LOCAL'
19125 !      include 'COMMON.INTERACT'
19126 !      include 'COMMON.VAR'
19127 !      include 'COMMON.IOUNITS'
19128 !      include 'COMMON.CALC'
19129 #ifndef CLUST
19130 #ifndef WHAM
19131        use MD_data
19132 !      include 'COMMON.MD'
19133 !      use MD, only: totT,t_bath
19134 #endif
19135 #endif
19136       double precision h_base
19137       external h_base
19138
19139 !c     Input arguments
19140       integer resi,resj,resk,m,itypi,itypj,itypk
19141
19142 !c     Output arguments
19143       double precision eij,eij1,eij2,eij3
19144
19145 !c     Local variables
19146       logical havebond
19147 !c      integer itypi,itypj,k,l
19148       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19149       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19150       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19151       double precision sig0ij,ljd,sig,fac,e1,e2
19152       double precision dcosom1(3),dcosom2(3),ed
19153       double precision pom1,pom2
19154       double precision ljA,ljB,ljXs
19155       double precision d_ljB(1:3)
19156       double precision ssA,ssB,ssC,ssXs
19157       double precision ssxm,ljxm,ssm,ljm
19158       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19159       eij=0.0
19160       if (dtriss.eq.0) return
19161       i=resi
19162       j=resj
19163       k=resk
19164 !C      write(iout,*) resi,resj,resk
19165       itypi=itype(i,1)
19166       dxi=dc_norm(1,nres+i)
19167       dyi=dc_norm(2,nres+i)
19168       dzi=dc_norm(3,nres+i)
19169       dsci_inv=vbld_inv(i+nres)
19170       xi=c(1,nres+i)
19171       yi=c(2,nres+i)
19172       zi=c(3,nres+i)
19173       itypj=itype(j,1)
19174       xj=c(1,nres+j)
19175       yj=c(2,nres+j)
19176       zj=c(3,nres+j)
19177
19178       dxj=dc_norm(1,nres+j)
19179       dyj=dc_norm(2,nres+j)
19180       dzj=dc_norm(3,nres+j)
19181       dscj_inv=vbld_inv(j+nres)
19182       itypk=itype(k,1)
19183       xk=c(1,nres+k)
19184       yk=c(2,nres+k)
19185       zk=c(3,nres+k)
19186
19187       dxk=dc_norm(1,nres+k)
19188       dyk=dc_norm(2,nres+k)
19189       dzk=dc_norm(3,nres+k)
19190       dscj_inv=vbld_inv(k+nres)
19191       xij=xj-xi
19192       xik=xk-xi
19193       xjk=xk-xj
19194       yij=yj-yi
19195       yik=yk-yi
19196       yjk=yk-yj
19197       zij=zj-zi
19198       zik=zk-zi
19199       zjk=zk-zj
19200       rrij=(xij*xij+yij*yij+zij*zij)
19201       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19202       rrik=(xik*xik+yik*yik+zik*zik)
19203       rik=dsqrt(rrik)
19204       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19205       rjk=dsqrt(rrjk)
19206 !C there are three combination of distances for each trisulfide bonds
19207 !C The first case the ith atom is the center
19208 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19209 !C distance y is second distance the a,b,c,d are parameters derived for
19210 !C this problem d parameter was set as a penalty currenlty set to 1.
19211       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19212       eij1=0.0d0
19213       else
19214       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19215       endif
19216 !C second case jth atom is center
19217       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19218       eij2=0.0d0
19219       else
19220       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19221       endif
19222 !C the third case kth atom is the center
19223       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19224       eij3=0.0d0
19225       else
19226       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19227       endif
19228 !C      eij2=0.0
19229 !C      eij3=0.0
19230 !C      eij1=0.0
19231       eij=eij1+eij2+eij3
19232 !C      write(iout,*)i,j,k,eij
19233 !C The energy penalty calculated now time for the gradient part
19234 !C derivative over rij
19235       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19236       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19237             gg(1)=xij*fac/rij
19238             gg(2)=yij*fac/rij
19239             gg(3)=zij*fac/rij
19240       do m=1,3
19241         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19242         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19243       enddo
19244
19245       do l=1,3
19246         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19247         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19248       enddo
19249 !C now derivative over rik
19250       fac=-eij1**2/dtriss* &
19251       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19252       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19253             gg(1)=xik*fac/rik
19254             gg(2)=yik*fac/rik
19255             gg(3)=zik*fac/rik
19256       do m=1,3
19257         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19258         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19259       enddo
19260       do l=1,3
19261         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19262         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19263       enddo
19264 !C now derivative over rjk
19265       fac=-eij2**2/dtriss* &
19266       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19267       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19268             gg(1)=xjk*fac/rjk
19269             gg(2)=yjk*fac/rjk
19270             gg(3)=zjk*fac/rjk
19271       do m=1,3
19272         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19273         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19274       enddo
19275       do l=1,3
19276         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19277         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19278       enddo
19279       return
19280       end subroutine triple_ssbond_ene
19281
19282
19283
19284 !-----------------------------------------------------------------------------
19285       real(kind=8) function h_base(x,deriv)
19286 !     A smooth function going 0->1 in range [0,1]
19287 !     It should NOT be called outside range [0,1], it will not work there.
19288       implicit none
19289
19290 !     Input arguments
19291       real(kind=8) :: x
19292
19293 !     Output arguments
19294       real(kind=8) :: deriv
19295
19296 !     Local variables
19297       real(kind=8) :: xsq
19298
19299
19300 !     Two parabolas put together.  First derivative zero at extrema
19301 !$$$      if (x.lt.0.5D0) then
19302 !$$$        h_base=2.0D0*x*x
19303 !$$$        deriv=4.0D0*x
19304 !$$$      else
19305 !$$$        deriv=1.0D0-x
19306 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19307 !$$$        deriv=4.0D0*deriv
19308 !$$$      endif
19309
19310 !     Third degree polynomial.  First derivative zero at extrema
19311       h_base=x*x*(3.0d0-2.0d0*x)
19312       deriv=6.0d0*x*(1.0d0-x)
19313
19314 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19315 !$$$      xsq=x*x
19316 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19317 !$$$      deriv=x-1.0d0
19318 !$$$      deriv=deriv*deriv
19319 !$$$      deriv=30.0d0*xsq*deriv
19320
19321       return
19322       end function h_base
19323 !-----------------------------------------------------------------------------
19324       subroutine dyn_set_nss
19325 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19326 !      implicit none
19327       use MD_data, only: totT,t_bath
19328 !     Includes
19329 !      include 'DIMENSIONS'
19330 #ifdef MPI
19331       include "mpif.h"
19332 #endif
19333 !      include 'COMMON.SBRIDGE'
19334 !      include 'COMMON.CHAIN'
19335 !      include 'COMMON.IOUNITS'
19336 !      include 'COMMON.SETUP'
19337 !      include 'COMMON.MD'
19338 !     Local variables
19339       real(kind=8) :: emin
19340       integer :: i,j,imin,ierr
19341       integer :: diff,allnss,newnss
19342       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19343                 newihpb,newjhpb
19344       logical :: found
19345       integer,dimension(0:nfgtasks) :: i_newnss
19346       integer,dimension(0:nfgtasks) :: displ
19347       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19348       integer :: g_newnss
19349
19350       allnss=0
19351       do i=1,nres-1
19352         do j=i+1,nres
19353           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19354             allnss=allnss+1
19355             allflag(allnss)=0
19356             allihpb(allnss)=i
19357             alljhpb(allnss)=j
19358           endif
19359         enddo
19360       enddo
19361
19362 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19363
19364  1    emin=1.0d300
19365       do i=1,allnss
19366         if (allflag(i).eq.0 .and. &
19367              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19368           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19369           imin=i
19370         endif
19371       enddo
19372       if (emin.lt.1.0d300) then
19373         allflag(imin)=1
19374         do i=1,allnss
19375           if (allflag(i).eq.0 .and. &
19376                (allihpb(i).eq.allihpb(imin) .or. &
19377                alljhpb(i).eq.allihpb(imin) .or. &
19378                allihpb(i).eq.alljhpb(imin) .or. &
19379                alljhpb(i).eq.alljhpb(imin))) then
19380             allflag(i)=-1
19381           endif
19382         enddo
19383         goto 1
19384       endif
19385
19386 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19387
19388       newnss=0
19389       do i=1,allnss
19390         if (allflag(i).eq.1) then
19391           newnss=newnss+1
19392           newihpb(newnss)=allihpb(i)
19393           newjhpb(newnss)=alljhpb(i)
19394         endif
19395       enddo
19396
19397 #ifdef MPI
19398       if (nfgtasks.gt.1)then
19399
19400         call MPI_Reduce(newnss,g_newnss,1,&
19401           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19402         call MPI_Gather(newnss,1,MPI_INTEGER,&
19403                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19404         displ(0)=0
19405         do i=1,nfgtasks-1,1
19406           displ(i)=i_newnss(i-1)+displ(i-1)
19407         enddo
19408         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19409                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19410                          king,FG_COMM,IERR)
19411         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19412                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19413                          king,FG_COMM,IERR)
19414         if(fg_rank.eq.0) then
19415 !         print *,'g_newnss',g_newnss
19416 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19417 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19418          newnss=g_newnss
19419          do i=1,newnss
19420           newihpb(i)=g_newihpb(i)
19421           newjhpb(i)=g_newjhpb(i)
19422          enddo
19423         endif
19424       endif
19425 #endif
19426
19427       diff=newnss-nss
19428
19429 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19430 !       print *,newnss,nss,maxdim
19431       do i=1,nss
19432         found=.false.
19433 !        print *,newnss
19434         do j=1,newnss
19435 !!          print *,j
19436           if (idssb(i).eq.newihpb(j) .and. &
19437                jdssb(i).eq.newjhpb(j)) found=.true.
19438         enddo
19439 #ifndef CLUST
19440 #ifndef WHAM
19441 !        write(iout,*) "found",found,i,j
19442         if (.not.found.and.fg_rank.eq.0) &
19443             write(iout,'(a15,f12.2,f8.1,2i5)') &
19444              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19445 #endif
19446 #endif
19447       enddo
19448
19449       do i=1,newnss
19450         found=.false.
19451         do j=1,nss
19452 !          print *,i,j
19453           if (newihpb(i).eq.idssb(j) .and. &
19454                newjhpb(i).eq.jdssb(j)) found=.true.
19455         enddo
19456 #ifndef CLUST
19457 #ifndef WHAM
19458 !        write(iout,*) "found",found,i,j
19459         if (.not.found.and.fg_rank.eq.0) &
19460             write(iout,'(a15,f12.2,f8.1,2i5)') &
19461              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19462 #endif
19463 #endif
19464       enddo
19465
19466       nss=newnss
19467       do i=1,nss
19468         idssb(i)=newihpb(i)
19469         jdssb(i)=newjhpb(i)
19470       enddo
19471
19472       return
19473       end subroutine dyn_set_nss
19474 ! Lipid transfer energy function
19475       subroutine Eliptransfer(eliptran)
19476 !C this is done by Adasko
19477 !C      print *,"wchodze"
19478 !C structure of box:
19479 !C      water
19480 !C--bordliptop-- buffore starts
19481 !C--bufliptop--- here true lipid starts
19482 !C      lipid
19483 !C--buflipbot--- lipid ends buffore starts
19484 !C--bordlipbot--buffore ends
19485       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19486       integer :: i
19487       eliptran=0.0
19488 !      print *, "I am in eliptran"
19489       do i=ilip_start,ilip_end
19490 !C       do i=1,1
19491         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19492          cycle
19493
19494         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19495         if (positi.le.0.0) positi=positi+boxzsize
19496 !C        print *,i
19497 !C first for peptide groups
19498 !c for each residue check if it is in lipid or lipid water border area
19499        if ((positi.gt.bordlipbot)  &
19500       .and.(positi.lt.bordliptop)) then
19501 !C the energy transfer exist
19502         if (positi.lt.buflipbot) then
19503 !C what fraction I am in
19504          fracinbuf=1.0d0-      &
19505              ((positi-bordlipbot)/lipbufthick)
19506 !C lipbufthick is thickenes of lipid buffore
19507          sslip=sscalelip(fracinbuf)
19508          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19509          eliptran=eliptran+sslip*pepliptran
19510          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19511          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19512 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19513
19514 !C        print *,"doing sccale for lower part"
19515 !C         print *,i,sslip,fracinbuf,ssgradlip
19516         elseif (positi.gt.bufliptop) then
19517          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19518          sslip=sscalelip(fracinbuf)
19519          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19520          eliptran=eliptran+sslip*pepliptran
19521          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19522          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19523 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19524 !C          print *, "doing sscalefor top part"
19525 !C         print *,i,sslip,fracinbuf,ssgradlip
19526         else
19527          eliptran=eliptran+pepliptran
19528 !C         print *,"I am in true lipid"
19529         endif
19530 !C       else
19531 !C       eliptran=elpitran+0.0 ! I am in water
19532        endif
19533        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19534        enddo
19535 ! here starts the side chain transfer
19536        do i=ilip_start,ilip_end
19537         if (itype(i,1).eq.ntyp1) cycle
19538         positi=(mod(c(3,i+nres),boxzsize))
19539         if (positi.le.0) positi=positi+boxzsize
19540 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19541 !c for each residue check if it is in lipid or lipid water border area
19542 !C       respos=mod(c(3,i+nres),boxzsize)
19543 !C       print *,positi,bordlipbot,buflipbot
19544        if ((positi.gt.bordlipbot) &
19545        .and.(positi.lt.bordliptop)) then
19546 !C the energy transfer exist
19547         if (positi.lt.buflipbot) then
19548          fracinbuf=1.0d0-   &
19549            ((positi-bordlipbot)/lipbufthick)
19550 !C lipbufthick is thickenes of lipid buffore
19551          sslip=sscalelip(fracinbuf)
19552          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19553          eliptran=eliptran+sslip*liptranene(itype(i,1))
19554          gliptranx(3,i)=gliptranx(3,i) &
19555       +ssgradlip*liptranene(itype(i,1))
19556          gliptranc(3,i-1)= gliptranc(3,i-1) &
19557       +ssgradlip*liptranene(itype(i,1))
19558 !C         print *,"doing sccale for lower part"
19559         elseif (positi.gt.bufliptop) then
19560          fracinbuf=1.0d0-  &
19561       ((bordliptop-positi)/lipbufthick)
19562          sslip=sscalelip(fracinbuf)
19563          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19564          eliptran=eliptran+sslip*liptranene(itype(i,1))
19565          gliptranx(3,i)=gliptranx(3,i)  &
19566        +ssgradlip*liptranene(itype(i,1))
19567          gliptranc(3,i-1)= gliptranc(3,i-1) &
19568       +ssgradlip*liptranene(itype(i,1))
19569 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19570         else
19571          eliptran=eliptran+liptranene(itype(i,1))
19572 !C         print *,"I am in true lipid"
19573         endif
19574         endif ! if in lipid or buffor
19575 !C       else
19576 !C       eliptran=elpitran+0.0 ! I am in water
19577         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19578        enddo
19579        return
19580        end  subroutine Eliptransfer
19581 !----------------------------------NANO FUNCTIONS
19582 !C-----------------------------------------------------------------------
19583 !C-----------------------------------------------------------
19584 !C This subroutine is to mimic the histone like structure but as well can be
19585 !C utilizet to nanostructures (infinit) small modification has to be used to
19586 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19587 !C gradient has to be modified at the ends
19588 !C The energy function is Kihara potential
19589 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19590 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19591 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19592 !C simple Kihara potential
19593       subroutine calctube(Etube)
19594       real(kind=8),dimension(3) :: vectube
19595       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19596        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19597        sc_aa_tube,sc_bb_tube
19598       integer :: i,j,iti
19599       Etube=0.0d0
19600       do i=itube_start,itube_end
19601         enetube(i)=0.0d0
19602         enetube(i+nres)=0.0d0
19603       enddo
19604 !C first we calculate the distance from tube center
19605 !C for UNRES
19606        do i=itube_start,itube_end
19607 !C lets ommit dummy atoms for now
19608        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19609 !C now calculate distance from center of tube and direction vectors
19610       xmin=boxxsize
19611       ymin=boxysize
19612 ! Find minimum distance in periodic box
19613         do j=-1,1
19614          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19615          vectube(1)=vectube(1)+boxxsize*j
19616          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19617          vectube(2)=vectube(2)+boxysize*j
19618          xminact=abs(vectube(1)-tubecenter(1))
19619          yminact=abs(vectube(2)-tubecenter(2))
19620            if (xmin.gt.xminact) then
19621             xmin=xminact
19622             xtemp=vectube(1)
19623            endif
19624            if (ymin.gt.yminact) then
19625              ymin=yminact
19626              ytemp=vectube(2)
19627             endif
19628          enddo
19629       vectube(1)=xtemp
19630       vectube(2)=ytemp
19631       vectube(1)=vectube(1)-tubecenter(1)
19632       vectube(2)=vectube(2)-tubecenter(2)
19633
19634 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19635 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19636
19637 !C as the tube is infinity we do not calculate the Z-vector use of Z
19638 !C as chosen axis
19639       vectube(3)=0.0d0
19640 !C now calculte the distance
19641        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19642 !C now normalize vector
19643       vectube(1)=vectube(1)/tub_r
19644       vectube(2)=vectube(2)/tub_r
19645 !C calculte rdiffrence between r and r0
19646       rdiff=tub_r-tubeR0
19647 !C and its 6 power
19648       rdiff6=rdiff**6.0d0
19649 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19650        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19651 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19652 !C       print *,rdiff,rdiff6,pep_aa_tube
19653 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19654 !C now we calculate gradient
19655        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19656             6.0d0*pep_bb_tube)/rdiff6/rdiff
19657 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19658 !C     &rdiff,fac
19659 !C now direction of gg_tube vector
19660         do j=1,3
19661         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19662         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19663         enddo
19664         enddo
19665 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19666 !C        print *,gg_tube(1,0),"TU"
19667
19668
19669        do i=itube_start,itube_end
19670 !C Lets not jump over memory as we use many times iti
19671          iti=itype(i,1)
19672 !C lets ommit dummy atoms for now
19673          if ((iti.eq.ntyp1)  &
19674 !C in UNRES uncomment the line below as GLY has no side-chain...
19675 !C      .or.(iti.eq.10)
19676         ) cycle
19677       xmin=boxxsize
19678       ymin=boxysize
19679         do j=-1,1
19680          vectube(1)=mod((c(1,i+nres)),boxxsize)
19681          vectube(1)=vectube(1)+boxxsize*j
19682          vectube(2)=mod((c(2,i+nres)),boxysize)
19683          vectube(2)=vectube(2)+boxysize*j
19684
19685          xminact=abs(vectube(1)-tubecenter(1))
19686          yminact=abs(vectube(2)-tubecenter(2))
19687            if (xmin.gt.xminact) then
19688             xmin=xminact
19689             xtemp=vectube(1)
19690            endif
19691            if (ymin.gt.yminact) then
19692              ymin=yminact
19693              ytemp=vectube(2)
19694             endif
19695          enddo
19696       vectube(1)=xtemp
19697       vectube(2)=ytemp
19698 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19699 !C     &     tubecenter(2)
19700       vectube(1)=vectube(1)-tubecenter(1)
19701       vectube(2)=vectube(2)-tubecenter(2)
19702
19703 !C as the tube is infinity we do not calculate the Z-vector use of Z
19704 !C as chosen axis
19705       vectube(3)=0.0d0
19706 !C now calculte the distance
19707        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19708 !C now normalize vector
19709       vectube(1)=vectube(1)/tub_r
19710       vectube(2)=vectube(2)/tub_r
19711
19712 !C calculte rdiffrence between r and r0
19713       rdiff=tub_r-tubeR0
19714 !C and its 6 power
19715       rdiff6=rdiff**6.0d0
19716 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19717        sc_aa_tube=sc_aa_tube_par(iti)
19718        sc_bb_tube=sc_bb_tube_par(iti)
19719        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19720        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19721              6.0d0*sc_bb_tube/rdiff6/rdiff
19722 !C now direction of gg_tube vector
19723          do j=1,3
19724           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19725           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19726          enddo
19727         enddo
19728         do i=itube_start,itube_end
19729           Etube=Etube+enetube(i)+enetube(i+nres)
19730         enddo
19731 !C        print *,"ETUBE", etube
19732         return
19733         end subroutine calctube
19734 !C TO DO 1) add to total energy
19735 !C       2) add to gradient summation
19736 !C       3) add reading parameters (AND of course oppening of PARAM file)
19737 !C       4) add reading the center of tube
19738 !C       5) add COMMONs
19739 !C       6) add to zerograd
19740 !C       7) allocate matrices
19741
19742
19743 !C-----------------------------------------------------------------------
19744 !C-----------------------------------------------------------
19745 !C This subroutine is to mimic the histone like structure but as well can be
19746 !C utilizet to nanostructures (infinit) small modification has to be used to
19747 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19748 !C gradient has to be modified at the ends
19749 !C The energy function is Kihara potential
19750 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19751 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19752 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19753 !C simple Kihara potential
19754       subroutine calctube2(Etube)
19755             real(kind=8),dimension(3) :: vectube
19756       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19757        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19758        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19759       integer:: i,j,iti
19760       Etube=0.0d0
19761       do i=itube_start,itube_end
19762         enetube(i)=0.0d0
19763         enetube(i+nres)=0.0d0
19764       enddo
19765 !C first we calculate the distance from tube center
19766 !C first sugare-phosphate group for NARES this would be peptide group
19767 !C for UNRES
19768        do i=itube_start,itube_end
19769 !C lets ommit dummy atoms for now
19770
19771        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19772 !C now calculate distance from center of tube and direction vectors
19773 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19774 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19775 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19776 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19777       xmin=boxxsize
19778       ymin=boxysize
19779         do j=-1,1
19780          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19781          vectube(1)=vectube(1)+boxxsize*j
19782          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19783          vectube(2)=vectube(2)+boxysize*j
19784
19785          xminact=abs(vectube(1)-tubecenter(1))
19786          yminact=abs(vectube(2)-tubecenter(2))
19787            if (xmin.gt.xminact) then
19788             xmin=xminact
19789             xtemp=vectube(1)
19790            endif
19791            if (ymin.gt.yminact) then
19792              ymin=yminact
19793              ytemp=vectube(2)
19794             endif
19795          enddo
19796       vectube(1)=xtemp
19797       vectube(2)=ytemp
19798       vectube(1)=vectube(1)-tubecenter(1)
19799       vectube(2)=vectube(2)-tubecenter(2)
19800
19801 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19802 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19803
19804 !C as the tube is infinity we do not calculate the Z-vector use of Z
19805 !C as chosen axis
19806       vectube(3)=0.0d0
19807 !C now calculte the distance
19808        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19809 !C now normalize vector
19810       vectube(1)=vectube(1)/tub_r
19811       vectube(2)=vectube(2)/tub_r
19812 !C calculte rdiffrence between r and r0
19813       rdiff=tub_r-tubeR0
19814 !C and its 6 power
19815       rdiff6=rdiff**6.0d0
19816 !C THIS FRAGMENT MAKES TUBE FINITE
19817         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19818         if (positi.le.0) positi=positi+boxzsize
19819 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19820 !c for each residue check if it is in lipid or lipid water border area
19821 !C       respos=mod(c(3,i+nres),boxzsize)
19822 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19823        if ((positi.gt.bordtubebot)  &
19824         .and.(positi.lt.bordtubetop)) then
19825 !C the energy transfer exist
19826         if (positi.lt.buftubebot) then
19827          fracinbuf=1.0d0-  &
19828            ((positi-bordtubebot)/tubebufthick)
19829 !C lipbufthick is thickenes of lipid buffore
19830          sstube=sscalelip(fracinbuf)
19831          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19832 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19833          enetube(i)=enetube(i)+sstube*tubetranenepep
19834 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19835 !C     &+ssgradtube*tubetranene(itype(i,1))
19836 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19837 !C     &+ssgradtube*tubetranene(itype(i,1))
19838 !C         print *,"doing sccale for lower part"
19839         elseif (positi.gt.buftubetop) then
19840          fracinbuf=1.0d0-  &
19841         ((bordtubetop-positi)/tubebufthick)
19842          sstube=sscalelip(fracinbuf)
19843          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19844          enetube(i)=enetube(i)+sstube*tubetranenepep
19845 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19846 !C     &+ssgradtube*tubetranene(itype(i,1))
19847 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19848 !C     &+ssgradtube*tubetranene(itype(i,1))
19849 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19850         else
19851          sstube=1.0d0
19852          ssgradtube=0.0d0
19853          enetube(i)=enetube(i)+sstube*tubetranenepep
19854 !C         print *,"I am in true lipid"
19855         endif
19856         else
19857 !C          sstube=0.0d0
19858 !C          ssgradtube=0.0d0
19859         cycle
19860         endif ! if in lipid or buffor
19861
19862 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19863        enetube(i)=enetube(i)+sstube* &
19864         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19865 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19866 !C       print *,rdiff,rdiff6,pep_aa_tube
19867 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19868 !C now we calculate gradient
19869        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19870              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19871 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19872 !C     &rdiff,fac
19873
19874 !C now direction of gg_tube vector
19875        do j=1,3
19876         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19877         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19878         enddo
19879          gg_tube(3,i)=gg_tube(3,i)  &
19880        +ssgradtube*enetube(i)/sstube/2.0d0
19881          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19882        +ssgradtube*enetube(i)/sstube/2.0d0
19883
19884         enddo
19885 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19886 !C        print *,gg_tube(1,0),"TU"
19887         do i=itube_start,itube_end
19888 !C Lets not jump over memory as we use many times iti
19889          iti=itype(i,1)
19890 !C lets ommit dummy atoms for now
19891          if ((iti.eq.ntyp1) &
19892 !!C in UNRES uncomment the line below as GLY has no side-chain...
19893            .or.(iti.eq.10) &
19894           ) cycle
19895           vectube(1)=c(1,i+nres)
19896           vectube(1)=mod(vectube(1),boxxsize)
19897           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19898           vectube(2)=c(2,i+nres)
19899           vectube(2)=mod(vectube(2),boxysize)
19900           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19901
19902       vectube(1)=vectube(1)-tubecenter(1)
19903       vectube(2)=vectube(2)-tubecenter(2)
19904 !C THIS FRAGMENT MAKES TUBE FINITE
19905         positi=(mod(c(3,i+nres),boxzsize))
19906         if (positi.le.0) positi=positi+boxzsize
19907 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19908 !c for each residue check if it is in lipid or lipid water border area
19909 !C       respos=mod(c(3,i+nres),boxzsize)
19910 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19911
19912        if ((positi.gt.bordtubebot)  &
19913         .and.(positi.lt.bordtubetop)) then
19914 !C the energy transfer exist
19915         if (positi.lt.buftubebot) then
19916          fracinbuf=1.0d0- &
19917             ((positi-bordtubebot)/tubebufthick)
19918 !C lipbufthick is thickenes of lipid buffore
19919          sstube=sscalelip(fracinbuf)
19920          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19921 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19922          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19923 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19924 !C     &+ssgradtube*tubetranene(itype(i,1))
19925 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19926 !C     &+ssgradtube*tubetranene(itype(i,1))
19927 !C         print *,"doing sccale for lower part"
19928         elseif (positi.gt.buftubetop) then
19929          fracinbuf=1.0d0- &
19930         ((bordtubetop-positi)/tubebufthick)
19931
19932          sstube=sscalelip(fracinbuf)
19933          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19934          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19935 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19936 !C     &+ssgradtube*tubetranene(itype(i,1))
19937 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19938 !C     &+ssgradtube*tubetranene(itype(i,1))
19939 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19940         else
19941          sstube=1.0d0
19942          ssgradtube=0.0d0
19943          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19944 !C         print *,"I am in true lipid"
19945         endif
19946         else
19947 !C          sstube=0.0d0
19948 !C          ssgradtube=0.0d0
19949         cycle
19950         endif ! if in lipid or buffor
19951 !CEND OF FINITE FRAGMENT
19952 !C as the tube is infinity we do not calculate the Z-vector use of Z
19953 !C as chosen axis
19954       vectube(3)=0.0d0
19955 !C now calculte the distance
19956        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19957 !C now normalize vector
19958       vectube(1)=vectube(1)/tub_r
19959       vectube(2)=vectube(2)/tub_r
19960 !C calculte rdiffrence between r and r0
19961       rdiff=tub_r-tubeR0
19962 !C and its 6 power
19963       rdiff6=rdiff**6.0d0
19964 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19965        sc_aa_tube=sc_aa_tube_par(iti)
19966        sc_bb_tube=sc_bb_tube_par(iti)
19967        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19968                        *sstube+enetube(i+nres)
19969 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19970 !C now we calculate gradient
19971        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19972             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19973 !C now direction of gg_tube vector
19974          do j=1,3
19975           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19976           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19977          enddo
19978          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19979        +ssgradtube*enetube(i+nres)/sstube
19980          gg_tube(3,i-1)= gg_tube(3,i-1) &
19981        +ssgradtube*enetube(i+nres)/sstube
19982
19983         enddo
19984         do i=itube_start,itube_end
19985           Etube=Etube+enetube(i)+enetube(i+nres)
19986         enddo
19987 !C        print *,"ETUBE", etube
19988         return
19989         end subroutine calctube2
19990 !=====================================================================================================================================
19991       subroutine calcnano(Etube)
19992       real(kind=8),dimension(3) :: vectube
19993
19994       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19995        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19996        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19997        integer:: i,j,iti,r
19998
19999       Etube=0.0d0
20000 !      print *,itube_start,itube_end,"poczatek"
20001       do i=itube_start,itube_end
20002         enetube(i)=0.0d0
20003         enetube(i+nres)=0.0d0
20004       enddo
20005 !C first we calculate the distance from tube center
20006 !C first sugare-phosphate group for NARES this would be peptide group
20007 !C for UNRES
20008        do i=itube_start,itube_end
20009 !C lets ommit dummy atoms for now
20010        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20011 !C now calculate distance from center of tube and direction vectors
20012       xmin=boxxsize
20013       ymin=boxysize
20014       zmin=boxzsize
20015
20016         do j=-1,1
20017          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20018          vectube(1)=vectube(1)+boxxsize*j
20019          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20020          vectube(2)=vectube(2)+boxysize*j
20021          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20022          vectube(3)=vectube(3)+boxzsize*j
20023
20024
20025          xminact=dabs(vectube(1)-tubecenter(1))
20026          yminact=dabs(vectube(2)-tubecenter(2))
20027          zminact=dabs(vectube(3)-tubecenter(3))
20028
20029            if (xmin.gt.xminact) then
20030             xmin=xminact
20031             xtemp=vectube(1)
20032            endif
20033            if (ymin.gt.yminact) then
20034              ymin=yminact
20035              ytemp=vectube(2)
20036             endif
20037            if (zmin.gt.zminact) then
20038              zmin=zminact
20039              ztemp=vectube(3)
20040             endif
20041          enddo
20042       vectube(1)=xtemp
20043       vectube(2)=ytemp
20044       vectube(3)=ztemp
20045
20046       vectube(1)=vectube(1)-tubecenter(1)
20047       vectube(2)=vectube(2)-tubecenter(2)
20048       vectube(3)=vectube(3)-tubecenter(3)
20049
20050 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20051 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20052 !C as the tube is infinity we do not calculate the Z-vector use of Z
20053 !C as chosen axis
20054 !C      vectube(3)=0.0d0
20055 !C now calculte the distance
20056        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20057 !C now normalize vector
20058       vectube(1)=vectube(1)/tub_r
20059       vectube(2)=vectube(2)/tub_r
20060       vectube(3)=vectube(3)/tub_r
20061 !C calculte rdiffrence between r and r0
20062       rdiff=tub_r-tubeR0
20063 !C and its 6 power
20064       rdiff6=rdiff**6.0d0
20065 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20066        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20067 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20068 !C       print *,rdiff,rdiff6,pep_aa_tube
20069 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20070 !C now we calculate gradient
20071        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20072             6.0d0*pep_bb_tube)/rdiff6/rdiff
20073 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20074 !C     &rdiff,fac
20075          if (acavtubpep.eq.0.0d0) then
20076 !C go to 667
20077          enecavtube(i)=0.0
20078          faccav=0.0
20079          else
20080          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20081          enecavtube(i)=  &
20082         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20083         /denominator
20084          enecavtube(i)=0.0
20085          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20086         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20087         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20088         /denominator**2.0d0
20089 !C         faccav=0.0
20090 !C         fac=fac+faccav
20091 !C 667     continue
20092          endif
20093           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20094         do j=1,3
20095         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20096         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20097         enddo
20098         enddo
20099
20100        do i=itube_start,itube_end
20101         enecavtube(i)=0.0d0
20102 !C Lets not jump over memory as we use many times iti
20103          iti=itype(i,1)
20104 !C lets ommit dummy atoms for now
20105          if ((iti.eq.ntyp1) &
20106 !C in UNRES uncomment the line below as GLY has no side-chain...
20107 !C      .or.(iti.eq.10)
20108          ) cycle
20109       xmin=boxxsize
20110       ymin=boxysize
20111       zmin=boxzsize
20112         do j=-1,1
20113          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20114          vectube(1)=vectube(1)+boxxsize*j
20115          vectube(2)=dmod((c(2,i+nres)),boxysize)
20116          vectube(2)=vectube(2)+boxysize*j
20117          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20118          vectube(3)=vectube(3)+boxzsize*j
20119
20120
20121          xminact=dabs(vectube(1)-tubecenter(1))
20122          yminact=dabs(vectube(2)-tubecenter(2))
20123          zminact=dabs(vectube(3)-tubecenter(3))
20124
20125            if (xmin.gt.xminact) then
20126             xmin=xminact
20127             xtemp=vectube(1)
20128            endif
20129            if (ymin.gt.yminact) then
20130              ymin=yminact
20131              ytemp=vectube(2)
20132             endif
20133            if (zmin.gt.zminact) then
20134              zmin=zminact
20135              ztemp=vectube(3)
20136             endif
20137          enddo
20138       vectube(1)=xtemp
20139       vectube(2)=ytemp
20140       vectube(3)=ztemp
20141
20142 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20143 !C     &     tubecenter(2)
20144       vectube(1)=vectube(1)-tubecenter(1)
20145       vectube(2)=vectube(2)-tubecenter(2)
20146       vectube(3)=vectube(3)-tubecenter(3)
20147 !C now calculte the distance
20148        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20149 !C now normalize vector
20150       vectube(1)=vectube(1)/tub_r
20151       vectube(2)=vectube(2)/tub_r
20152       vectube(3)=vectube(3)/tub_r
20153
20154 !C calculte rdiffrence between r and r0
20155       rdiff=tub_r-tubeR0
20156 !C and its 6 power
20157       rdiff6=rdiff**6.0d0
20158        sc_aa_tube=sc_aa_tube_par(iti)
20159        sc_bb_tube=sc_bb_tube_par(iti)
20160        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20161 !C       enetube(i+nres)=0.0d0
20162 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20163 !C now we calculate gradient
20164        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20165             6.0d0*sc_bb_tube/rdiff6/rdiff
20166 !C       fac=0.0
20167 !C now direction of gg_tube vector
20168 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20169          if (acavtub(iti).eq.0.0d0) then
20170 !C go to 667
20171          enecavtube(i+nres)=0.0d0
20172          faccav=0.0d0
20173          else
20174          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20175          enecavtube(i+nres)=   &
20176         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20177         /denominator
20178 !C         enecavtube(i)=0.0
20179          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20180         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20181         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20182         /denominator**2.0d0
20183 !C         faccav=0.0
20184          fac=fac+faccav
20185 !C 667     continue
20186          endif
20187 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20188 !C     &   enecavtube(i),faccav
20189 !C         print *,"licz=",
20190 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20191 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20192          do j=1,3
20193           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20194           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20195          enddo
20196           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20197         enddo
20198
20199
20200
20201         do i=itube_start,itube_end
20202           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20203          +enecavtube(i+nres)
20204         enddo
20205 !        do i=1,20
20206 !         print *,"begin", i,"a"
20207 !         do r=1,10000
20208 !          rdiff=r/100.0d0
20209 !          rdiff6=rdiff**6.0d0
20210 !          sc_aa_tube=sc_aa_tube_par(i)
20211 !          sc_bb_tube=sc_bb_tube_par(i)
20212 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20213 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20214 !          enecavtube(i)=   &
20215 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20216 !         /denominator
20217
20218 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20219 !         enddo
20220 !         print *,"end",i,"a"
20221 !        enddo
20222 !C        print *,"ETUBE", etube
20223         return
20224         end subroutine calcnano
20225
20226 !===============================================
20227 !--------------------------------------------------------------------------------
20228 !C first for shielding is setting of function of side-chains
20229
20230        subroutine set_shield_fac2
20231        real(kind=8) :: div77_81=0.974996043d0, &
20232         div4_81=0.2222222222d0
20233        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20234          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20235          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20236          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20237 !C the vector between center of side_chain and peptide group
20238        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20239          pept_group,costhet_grad,cosphi_grad_long, &
20240          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20241          sh_frac_dist_grad,pep_side
20242         integer i,j,k
20243 !C      write(2,*) "ivec",ivec_start,ivec_end
20244       do i=1,nres
20245         fac_shield(i)=0.0d0
20246         ishield_list(i)=0
20247         do j=1,3
20248         grad_shield(j,i)=0.0d0
20249         enddo
20250       enddo
20251       do i=ivec_start,ivec_end
20252 !C      do i=1,nres-1
20253 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20254 !      ishield_list(i)=0
20255       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20256 !Cif there two consequtive dummy atoms there is no peptide group between them
20257 !C the line below has to be changed for FGPROC>1
20258       VolumeTotal=0.0
20259       do k=1,nres
20260        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20261        dist_pep_side=0.0
20262        dist_side_calf=0.0
20263        do j=1,3
20264 !C first lets set vector conecting the ithe side-chain with kth side-chain
20265       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20266 !C      pep_side(j)=2.0d0
20267 !C and vector conecting the side-chain with its proper calfa
20268       side_calf(j)=c(j,k+nres)-c(j,k)
20269 !C      side_calf(j)=2.0d0
20270       pept_group(j)=c(j,i)-c(j,i+1)
20271 !C lets have their lenght
20272       dist_pep_side=pep_side(j)**2+dist_pep_side
20273       dist_side_calf=dist_side_calf+side_calf(j)**2
20274       dist_pept_group=dist_pept_group+pept_group(j)**2
20275       enddo
20276        dist_pep_side=sqrt(dist_pep_side)
20277        dist_pept_group=sqrt(dist_pept_group)
20278        dist_side_calf=sqrt(dist_side_calf)
20279       do j=1,3
20280         pep_side_norm(j)=pep_side(j)/dist_pep_side
20281         side_calf_norm(j)=dist_side_calf
20282       enddo
20283 !C now sscale fraction
20284        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20285 !       print *,buff_shield,"buff",sh_frac_dist
20286 !C now sscale
20287         if (sh_frac_dist.le.0.0) cycle
20288 !C        print *,ishield_list(i),i
20289 !C If we reach here it means that this side chain reaches the shielding sphere
20290 !C Lets add him to the list for gradient
20291         ishield_list(i)=ishield_list(i)+1
20292 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20293 !C this list is essential otherwise problem would be O3
20294         shield_list(ishield_list(i),i)=k
20295 !C Lets have the sscale value
20296         if (sh_frac_dist.gt.1.0) then
20297          scale_fac_dist=1.0d0
20298          do j=1,3
20299          sh_frac_dist_grad(j)=0.0d0
20300          enddo
20301         else
20302          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20303                         *(2.0d0*sh_frac_dist-3.0d0)
20304          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20305                        /dist_pep_side/buff_shield*0.5d0
20306          do j=1,3
20307          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20308 !C         sh_frac_dist_grad(j)=0.0d0
20309 !C         scale_fac_dist=1.0d0
20310 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20311 !C     &                    sh_frac_dist_grad(j)
20312          enddo
20313         endif
20314 !C this is what is now we have the distance scaling now volume...
20315       short=short_r_sidechain(itype(k,1))
20316       long=long_r_sidechain(itype(k,1))
20317       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20318       sinthet=short/dist_pep_side*costhet
20319 !      print *,"SORT",short,long,sinthet,costhet
20320 !C now costhet_grad
20321 !C       costhet=0.6d0
20322 !C       sinthet=0.8
20323        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20324 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20325 !C     &             -short/dist_pep_side**2/costhet)
20326 !C       costhet_fac=0.0d0
20327        do j=1,3
20328          costhet_grad(j)=costhet_fac*pep_side(j)
20329        enddo
20330 !C remember for the final gradient multiply costhet_grad(j)
20331 !C for side_chain by factor -2 !
20332 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20333 !C pep_side0pept_group is vector multiplication
20334       pep_side0pept_group=0.0d0
20335       do j=1,3
20336       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20337       enddo
20338       cosalfa=(pep_side0pept_group/ &
20339       (dist_pep_side*dist_side_calf))
20340       fac_alfa_sin=1.0d0-cosalfa**2
20341       fac_alfa_sin=dsqrt(fac_alfa_sin)
20342       rkprim=fac_alfa_sin*(long-short)+short
20343 !C      rkprim=short
20344
20345 !C now costhet_grad
20346        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20347 !C       cosphi=0.6
20348        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20349        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20350            dist_pep_side**2)
20351 !C       sinphi=0.8
20352        do j=1,3
20353          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20354       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20355       *(long-short)/fac_alfa_sin*cosalfa/ &
20356       ((dist_pep_side*dist_side_calf))* &
20357       ((side_calf(j))-cosalfa* &
20358       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20359 !C       cosphi_grad_long(j)=0.0d0
20360         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20361       *(long-short)/fac_alfa_sin*cosalfa &
20362       /((dist_pep_side*dist_side_calf))* &
20363       (pep_side(j)- &
20364       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20365 !C       cosphi_grad_loc(j)=0.0d0
20366        enddo
20367 !C      print *,sinphi,sinthet
20368       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20369                          /VSolvSphere_div
20370 !C     &                    *wshield
20371 !C now the gradient...
20372       do j=1,3
20373       grad_shield(j,i)=grad_shield(j,i) &
20374 !C gradient po skalowaniu
20375                      +(sh_frac_dist_grad(j)*VofOverlap &
20376 !C  gradient po costhet
20377             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20378         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20379             sinphi/sinthet*costhet*costhet_grad(j) &
20380            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20381         )*wshield
20382 !C grad_shield_side is Cbeta sidechain gradient
20383       grad_shield_side(j,ishield_list(i),i)=&
20384              (sh_frac_dist_grad(j)*-2.0d0&
20385              *VofOverlap&
20386             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20387        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20388             sinphi/sinthet*costhet*costhet_grad(j)&
20389            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20390             )*wshield
20391 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20392 !            sinphi/sinthet,&
20393 !           +sinthet/sinphi,"HERE"
20394        grad_shield_loc(j,ishield_list(i),i)=   &
20395             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20396       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20397             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20398              ))&
20399              *wshield
20400 !         print *,grad_shield_loc(j,ishield_list(i),i)
20401       enddo
20402       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20403       enddo
20404       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20405
20406 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20407       enddo
20408       return
20409       end subroutine set_shield_fac2
20410 !----------------------------------------------------------------------------
20411 ! SOUBROUTINE FOR AFM
20412        subroutine AFMvel(Eafmforce)
20413        use MD_data, only:totTafm
20414       real(kind=8),dimension(3) :: diffafm
20415       real(kind=8) :: afmdist,Eafmforce
20416        integer :: i
20417 !C Only for check grad COMMENT if not used for checkgrad
20418 !C      totT=3.0d0
20419 !C--------------------------------------------------------
20420 !C      print *,"wchodze"
20421       afmdist=0.0d0
20422       Eafmforce=0.0d0
20423       do i=1,3
20424       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20425       afmdist=afmdist+diffafm(i)**2
20426       enddo
20427       afmdist=dsqrt(afmdist)
20428 !      totTafm=3.0
20429       Eafmforce=0.5d0*forceAFMconst &
20430       *(distafminit+totTafm*velAFMconst-afmdist)**2
20431 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20432       do i=1,3
20433       gradafm(i,afmend-1)=-forceAFMconst* &
20434        (distafminit+totTafm*velAFMconst-afmdist) &
20435        *diffafm(i)/afmdist
20436       gradafm(i,afmbeg-1)=forceAFMconst* &
20437       (distafminit+totTafm*velAFMconst-afmdist) &
20438       *diffafm(i)/afmdist
20439       enddo
20440 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20441       return
20442       end subroutine AFMvel
20443 !---------------------------------------------------------
20444        subroutine AFMforce(Eafmforce)
20445
20446       real(kind=8),dimension(3) :: diffafm
20447 !      real(kind=8) ::afmdist
20448       real(kind=8) :: afmdist,Eafmforce
20449       integer :: i
20450       afmdist=0.0d0
20451       Eafmforce=0.0d0
20452       do i=1,3
20453       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20454       afmdist=afmdist+diffafm(i)**2
20455       enddo
20456       afmdist=dsqrt(afmdist)
20457 !      print *,afmdist,distafminit
20458       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20459       do i=1,3
20460       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20461       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20462       enddo
20463 !C      print *,'AFM',Eafmforce
20464       return
20465       end subroutine AFMforce
20466
20467 !-----------------------------------------------------------------------------
20468 #ifdef WHAM
20469       subroutine read_ssHist
20470 !      implicit none
20471 !      Includes
20472 !      include 'DIMENSIONS'
20473 !      include "DIMENSIONS.FREE"
20474 !      include 'COMMON.FREE'
20475 !     Local variables
20476       integer :: i,j
20477       character(len=80) :: controlcard
20478
20479       do i=1,dyn_nssHist
20480         call card_concat(controlcard,.true.)
20481         read(controlcard,*) &
20482              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20483       enddo
20484
20485       return
20486       end subroutine read_ssHist
20487 #endif
20488 !-----------------------------------------------------------------------------
20489       integer function indmat(i,j)
20490 !el
20491 ! get the position of the jth ijth fragment of the chain coordinate system
20492 ! in the fromto array.
20493         integer :: i,j
20494
20495         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20496       return
20497       end function indmat
20498 !-----------------------------------------------------------------------------
20499       real(kind=8) function sigm(x)
20500 !el
20501        real(kind=8) :: x
20502         sigm=0.25d0*x
20503       return
20504       end function sigm
20505 !-----------------------------------------------------------------------------
20506 !-----------------------------------------------------------------------------
20507       subroutine alloc_ener_arrays
20508 !EL Allocation of arrays used by module energy
20509       use MD_data, only: mset
20510 !el local variables
20511       integer :: i,j
20512
20513       if(nres.lt.100) then
20514         maxconts=10*nres
20515       elseif(nres.lt.200) then
20516         maxconts=10*nres      ! Max. number of contacts per residue
20517       else
20518         maxconts=10*nres ! (maxconts=maxres/4)
20519       endif
20520       maxcont=12*nres      ! Max. number of SC contacts
20521       maxvar=6*nres      ! Max. number of variables
20522 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20523       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20524 !----------------------
20525 ! arrays in subroutine init_int_table
20526 !el#ifdef MPI
20527 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20528 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20529 !el#endif
20530       allocate(nint_gr(nres))
20531       allocate(nscp_gr(nres))
20532       allocate(ielstart(nres))
20533       allocate(ielend(nres))
20534 !(maxres)
20535       allocate(istart(nres,maxint_gr))
20536       allocate(iend(nres,maxint_gr))
20537 !(maxres,maxint_gr)
20538       allocate(iscpstart(nres,maxint_gr))
20539       allocate(iscpend(nres,maxint_gr))
20540 !(maxres,maxint_gr)
20541       allocate(ielstart_vdw(nres))
20542       allocate(ielend_vdw(nres))
20543 !(maxres)
20544       allocate(nint_gr_nucl(nres))
20545       allocate(nscp_gr_nucl(nres))
20546       allocate(ielstart_nucl(nres))
20547       allocate(ielend_nucl(nres))
20548 !(maxres)
20549       allocate(istart_nucl(nres,maxint_gr))
20550       allocate(iend_nucl(nres,maxint_gr))
20551 !(maxres,maxint_gr)
20552       allocate(iscpstart_nucl(nres,maxint_gr))
20553       allocate(iscpend_nucl(nres,maxint_gr))
20554 !(maxres,maxint_gr)
20555       allocate(ielstart_vdw_nucl(nres))
20556       allocate(ielend_vdw_nucl(nres))
20557
20558       allocate(lentyp(0:nfgtasks-1))
20559 !(0:maxprocs-1)
20560 !----------------------
20561 ! commom.contacts
20562 !      common /contacts/
20563       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20564       allocate(icont(2,maxcont))
20565 !(2,maxcont)
20566 !      common /contacts1/
20567       allocate(num_cont(0:nres+4))
20568 !(maxres)
20569       allocate(jcont(maxconts,nres))
20570 !(maxconts,maxres)
20571       allocate(facont(maxconts,nres))
20572 !(maxconts,maxres)
20573       allocate(gacont(3,maxconts,nres))
20574 !(3,maxconts,maxres)
20575 !      common /contacts_hb/
20576       allocate(gacontp_hb1(3,maxconts,nres))
20577       allocate(gacontp_hb2(3,maxconts,nres))
20578       allocate(gacontp_hb3(3,maxconts,nres))
20579       allocate(gacontm_hb1(3,maxconts,nres))
20580       allocate(gacontm_hb2(3,maxconts,nres))
20581       allocate(gacontm_hb3(3,maxconts,nres))
20582       allocate(gacont_hbr(3,maxconts,nres))
20583       allocate(grij_hb_cont(3,maxconts,nres))
20584 !(3,maxconts,maxres)
20585       allocate(facont_hb(maxconts,nres))
20586
20587       allocate(ees0p(maxconts,nres))
20588       allocate(ees0m(maxconts,nres))
20589       allocate(d_cont(maxconts,nres))
20590       allocate(ees0plist(maxconts,nres))
20591
20592 !(maxconts,maxres)
20593       allocate(num_cont_hb(nres))
20594 !(maxres)
20595       allocate(jcont_hb(maxconts,nres))
20596 !(maxconts,maxres)
20597 !      common /rotat/
20598       allocate(Ug(2,2,nres))
20599       allocate(Ugder(2,2,nres))
20600       allocate(Ug2(2,2,nres))
20601       allocate(Ug2der(2,2,nres))
20602 !(2,2,maxres)
20603       allocate(obrot(2,nres))
20604       allocate(obrot2(2,nres))
20605       allocate(obrot_der(2,nres))
20606       allocate(obrot2_der(2,nres))
20607 !(2,maxres)
20608 !      common /precomp1/
20609       allocate(mu(2,nres))
20610       allocate(muder(2,nres))
20611       allocate(Ub2(2,nres))
20612       Ub2(1,:)=0.0d0
20613       Ub2(2,:)=0.0d0
20614       allocate(Ub2der(2,nres))
20615       allocate(Ctobr(2,nres))
20616       allocate(Ctobrder(2,nres))
20617       allocate(Dtobr2(2,nres))
20618       allocate(Dtobr2der(2,nres))
20619 !(2,maxres)
20620       allocate(EUg(2,2,nres))
20621       allocate(EUgder(2,2,nres))
20622       allocate(CUg(2,2,nres))
20623       allocate(CUgder(2,2,nres))
20624       allocate(DUg(2,2,nres))
20625       allocate(Dugder(2,2,nres))
20626       allocate(DtUg2(2,2,nres))
20627       allocate(DtUg2der(2,2,nres))
20628 !(2,2,maxres)
20629 !      common /precomp2/
20630       allocate(Ug2Db1t(2,nres))
20631       allocate(Ug2Db1tder(2,nres))
20632       allocate(CUgb2(2,nres))
20633       allocate(CUgb2der(2,nres))
20634 !(2,maxres)
20635       allocate(EUgC(2,2,nres))
20636       allocate(EUgCder(2,2,nres))
20637       allocate(EUgD(2,2,nres))
20638       allocate(EUgDder(2,2,nres))
20639       allocate(DtUg2EUg(2,2,nres))
20640       allocate(Ug2DtEUg(2,2,nres))
20641 !(2,2,maxres)
20642       allocate(Ug2DtEUgder(2,2,2,nres))
20643       allocate(DtUg2EUgder(2,2,2,nres))
20644 !(2,2,2,maxres)
20645       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20646       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20647       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20648       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20649
20650       allocate(ctilde(2,2,nres))
20651       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20652       allocate(gtb1(2,nres))
20653       allocate(gtb2(2,nres))
20654       allocate(cc(2,2,nres))
20655       allocate(dd(2,2,nres))
20656       allocate(ee(2,2,nres))
20657       allocate(gtcc(2,2,nres))
20658       allocate(gtdd(2,2,nres))
20659       allocate(gtee(2,2,nres))
20660       allocate(gUb2(2,nres))
20661       allocate(gteUg(2,2,nres))
20662
20663 !      common /rotat_old/
20664       allocate(costab(nres))
20665       allocate(sintab(nres))
20666       allocate(costab2(nres))
20667       allocate(sintab2(nres))
20668 !(maxres)
20669 !      common /dipmat/
20670       allocate(a_chuj(2,2,maxconts,nres))
20671 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20672       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20673 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20674 !      common /contdistrib/
20675       allocate(ncont_sent(nres))
20676       allocate(ncont_recv(nres))
20677
20678       allocate(iat_sent(nres))
20679 !(maxres)
20680       allocate(iint_sent(4,nres,nres))
20681       allocate(iint_sent_local(4,nres,nres))
20682 !(4,maxres,maxres)
20683       allocate(iturn3_sent(4,0:nres+4))
20684       allocate(iturn4_sent(4,0:nres+4))
20685       allocate(iturn3_sent_local(4,nres))
20686       allocate(iturn4_sent_local(4,nres))
20687 !(4,maxres)
20688       allocate(itask_cont_from(0:nfgtasks-1))
20689       allocate(itask_cont_to(0:nfgtasks-1))
20690 !(0:max_fg_procs-1)
20691
20692
20693
20694 !----------------------
20695 ! commom.deriv;
20696 !      common /derivat/
20697       allocate(dcdv(6,maxdim))
20698       allocate(dxdv(6,maxdim))
20699 !(6,maxdim)
20700       allocate(dxds(6,nres))
20701 !(6,maxres)
20702       allocate(gradx(3,-1:nres,0:2))
20703       allocate(gradc(3,-1:nres,0:2))
20704 !(3,maxres,2)
20705       allocate(gvdwx(3,-1:nres))
20706       allocate(gvdwc(3,-1:nres))
20707       allocate(gelc(3,-1:nres))
20708       allocate(gelc_long(3,-1:nres))
20709       allocate(gvdwpp(3,-1:nres))
20710       allocate(gvdwc_scpp(3,-1:nres))
20711       allocate(gradx_scp(3,-1:nres))
20712       allocate(gvdwc_scp(3,-1:nres))
20713       allocate(ghpbx(3,-1:nres))
20714       allocate(ghpbc(3,-1:nres))
20715       allocate(gradcorr(3,-1:nres))
20716       allocate(gradcorr_long(3,-1:nres))
20717       allocate(gradcorr5_long(3,-1:nres))
20718       allocate(gradcorr6_long(3,-1:nres))
20719       allocate(gcorr6_turn_long(3,-1:nres))
20720       allocate(gradxorr(3,-1:nres))
20721       allocate(gradcorr5(3,-1:nres))
20722       allocate(gradcorr6(3,-1:nres))
20723       allocate(gliptran(3,-1:nres))
20724       allocate(gliptranc(3,-1:nres))
20725       allocate(gliptranx(3,-1:nres))
20726       allocate(gshieldx(3,-1:nres))
20727       allocate(gshieldc(3,-1:nres))
20728       allocate(gshieldc_loc(3,-1:nres))
20729       allocate(gshieldx_ec(3,-1:nres))
20730       allocate(gshieldc_ec(3,-1:nres))
20731       allocate(gshieldc_loc_ec(3,-1:nres))
20732       allocate(gshieldx_t3(3,-1:nres))
20733       allocate(gshieldc_t3(3,-1:nres))
20734       allocate(gshieldc_loc_t3(3,-1:nres))
20735       allocate(gshieldx_t4(3,-1:nres))
20736       allocate(gshieldc_t4(3,-1:nres))
20737       allocate(gshieldc_loc_t4(3,-1:nres))
20738       allocate(gshieldx_ll(3,-1:nres))
20739       allocate(gshieldc_ll(3,-1:nres))
20740       allocate(gshieldc_loc_ll(3,-1:nres))
20741       allocate(grad_shield(3,-1:nres))
20742       allocate(gg_tube_sc(3,-1:nres))
20743       allocate(gg_tube(3,-1:nres))
20744       allocate(gradafm(3,-1:nres))
20745       allocate(gradb_nucl(3,-1:nres))
20746       allocate(gradbx_nucl(3,-1:nres))
20747       allocate(gvdwpsb1(3,-1:nres))
20748       allocate(gelpp(3,-1:nres))
20749       allocate(gvdwpsb(3,-1:nres))
20750       allocate(gelsbc(3,-1:nres))
20751       allocate(gelsbx(3,-1:nres))
20752       allocate(gvdwsbx(3,-1:nres))
20753       allocate(gvdwsbc(3,-1:nres))
20754       allocate(gsbloc(3,-1:nres))
20755       allocate(gsblocx(3,-1:nres))
20756       allocate(gradcorr_nucl(3,-1:nres))
20757       allocate(gradxorr_nucl(3,-1:nres))
20758       allocate(gradcorr3_nucl(3,-1:nres))
20759       allocate(gradxorr3_nucl(3,-1:nres))
20760       allocate(gvdwpp_nucl(3,-1:nres))
20761       allocate(gradpepcat(3,-1:nres))
20762       allocate(gradpepcatx(3,-1:nres))
20763       allocate(gradcatcat(3,-1:nres))
20764 !(3,maxres)
20765       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20766       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20767 ! grad for shielding surroing
20768       allocate(gloc(0:maxvar,0:2))
20769       allocate(gloc_x(0:maxvar,2))
20770 !(maxvar,2)
20771       allocate(gel_loc(3,-1:nres))
20772       allocate(gel_loc_long(3,-1:nres))
20773       allocate(gcorr3_turn(3,-1:nres))
20774       allocate(gcorr4_turn(3,-1:nres))
20775       allocate(gcorr6_turn(3,-1:nres))
20776       allocate(gradb(3,-1:nres))
20777       allocate(gradbx(3,-1:nres))
20778 !(3,maxres)
20779       allocate(gel_loc_loc(maxvar))
20780       allocate(gel_loc_turn3(maxvar))
20781       allocate(gel_loc_turn4(maxvar))
20782       allocate(gel_loc_turn6(maxvar))
20783       allocate(gcorr_loc(maxvar))
20784       allocate(g_corr5_loc(maxvar))
20785       allocate(g_corr6_loc(maxvar))
20786 !(maxvar)
20787       allocate(gsccorc(3,-1:nres))
20788       allocate(gsccorx(3,-1:nres))
20789 !(3,maxres)
20790       allocate(gsccor_loc(-1:nres))
20791 !(maxres)
20792       allocate(gvdwx_scbase(3,-1:nres))
20793       allocate(gvdwc_scbase(3,-1:nres))
20794       allocate(gvdwx_pepbase(3,-1:nres))
20795       allocate(gvdwc_pepbase(3,-1:nres))
20796       allocate(gvdwx_scpho(3,-1:nres))
20797       allocate(gvdwc_scpho(3,-1:nres))
20798       allocate(gvdwc_peppho(3,-1:nres))
20799
20800       allocate(dtheta(3,2,-1:nres))
20801 !(3,2,maxres)
20802       allocate(gscloc(3,-1:nres))
20803       allocate(gsclocx(3,-1:nres))
20804 !(3,maxres)
20805       allocate(dphi(3,3,-1:nres))
20806       allocate(dalpha(3,3,-1:nres))
20807       allocate(domega(3,3,-1:nres))
20808 !(3,3,maxres)
20809 !      common /deriv_scloc/
20810       allocate(dXX_C1tab(3,nres))
20811       allocate(dYY_C1tab(3,nres))
20812       allocate(dZZ_C1tab(3,nres))
20813       allocate(dXX_Ctab(3,nres))
20814       allocate(dYY_Ctab(3,nres))
20815       allocate(dZZ_Ctab(3,nres))
20816       allocate(dXX_XYZtab(3,nres))
20817       allocate(dYY_XYZtab(3,nres))
20818       allocate(dZZ_XYZtab(3,nres))
20819 !(3,maxres)
20820 !      common /mpgrad/
20821       allocate(jgrad_start(nres))
20822       allocate(jgrad_end(nres))
20823 !(maxres)
20824 !----------------------
20825
20826 !      common /indices/
20827       allocate(ibond_displ(0:nfgtasks-1))
20828       allocate(ibond_count(0:nfgtasks-1))
20829       allocate(ithet_displ(0:nfgtasks-1))
20830       allocate(ithet_count(0:nfgtasks-1))
20831       allocate(iphi_displ(0:nfgtasks-1))
20832       allocate(iphi_count(0:nfgtasks-1))
20833       allocate(iphi1_displ(0:nfgtasks-1))
20834       allocate(iphi1_count(0:nfgtasks-1))
20835       allocate(ivec_displ(0:nfgtasks-1))
20836       allocate(ivec_count(0:nfgtasks-1))
20837       allocate(iset_displ(0:nfgtasks-1))
20838       allocate(iset_count(0:nfgtasks-1))
20839       allocate(iint_count(0:nfgtasks-1))
20840       allocate(iint_displ(0:nfgtasks-1))
20841 !(0:max_fg_procs-1)
20842 !----------------------
20843 ! common.MD
20844 !      common /mdgrad/
20845       allocate(gcart(3,-1:nres))
20846       allocate(gxcart(3,-1:nres))
20847 !(3,0:MAXRES)
20848       allocate(gradcag(3,-1:nres))
20849       allocate(gradxag(3,-1:nres))
20850 !(3,MAXRES)
20851 !      common /back_constr/
20852 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20853       allocate(dutheta(nres))
20854       allocate(dugamma(nres))
20855 !(maxres)
20856       allocate(duscdiff(3,nres))
20857       allocate(duscdiffx(3,nres))
20858 !(3,maxres)
20859 !el i io:read_fragments
20860 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20861 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20862 !      common /qmeas/
20863 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20864 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20865       allocate(mset(0:nprocs))  !(maxprocs/20)
20866       mset(:)=0
20867 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20868 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20869       allocate(dUdconst(3,0:nres))
20870       allocate(dUdxconst(3,0:nres))
20871       allocate(dqwol(3,0:nres))
20872       allocate(dxqwol(3,0:nres))
20873 !(3,0:MAXRES)
20874 !----------------------
20875 ! common.sbridge
20876 !      common /sbridge/ in io_common: read_bridge
20877 !el    allocate((:),allocatable :: iss      !(maxss)
20878 !      common /links/  in io_common: read_bridge
20879 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20880 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20881 !      common /dyn_ssbond/
20882 ! and side-chain vectors in theta or phi.
20883       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20884 !(maxres,maxres)
20885 !      do i=1,nres
20886 !        do j=i+1,nres
20887       dyn_ssbond_ij(:,:)=1.0d300
20888 !        enddo
20889 !      enddo
20890
20891 !      if (nss.gt.0) then
20892         allocate(idssb(maxdim),jdssb(maxdim))
20893 !        allocate(newihpb(nss),newjhpb(nss))
20894 !(maxdim)
20895 !      endif
20896       allocate(ishield_list(-1:nres))
20897       allocate(shield_list(maxcontsshi,-1:nres))
20898       allocate(dyn_ss_mask(nres))
20899       allocate(fac_shield(-1:nres))
20900       allocate(enetube(nres*2))
20901       allocate(enecavtube(nres*2))
20902
20903 !(maxres)
20904       dyn_ss_mask(:)=.false.
20905 !----------------------
20906 ! common.sccor
20907 ! Parameters of the SCCOR term
20908 !      common/sccor/
20909 !el in io_conf: parmread
20910 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20911 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20912 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20913 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20914 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20915 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20916 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20917 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20918 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20919 !----------------
20920       allocate(gloc_sc(3,0:2*nres,0:10))
20921 !(3,0:maxres2,10)maxres2=2*maxres
20922       allocate(dcostau(3,3,3,2*nres))
20923       allocate(dsintau(3,3,3,2*nres))
20924       allocate(dtauangle(3,3,3,2*nres))
20925       allocate(dcosomicron(3,3,3,2*nres))
20926       allocate(domicron(3,3,3,2*nres))
20927 !(3,3,3,maxres2)maxres2=2*maxres
20928 !----------------------
20929 ! common.var
20930 !      common /restr/
20931       allocate(varall(maxvar))
20932 !(maxvar)(maxvar=6*maxres)
20933       allocate(mask_theta(nres))
20934       allocate(mask_phi(nres))
20935       allocate(mask_side(nres))
20936 !(maxres)
20937 !----------------------
20938 ! common.vectors
20939 !      common /vectors/
20940       allocate(uy(3,nres))
20941       allocate(uz(3,nres))
20942 !(3,maxres)
20943       allocate(uygrad(3,3,2,nres))
20944       allocate(uzgrad(3,3,2,nres))
20945 !(3,3,2,maxres)
20946
20947       return
20948       end subroutine alloc_ener_arrays
20949 !-----------------------------------------------------------------
20950       subroutine ebond_nucl(estr_nucl)
20951 !c
20952 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20953 !c
20954
20955       real(kind=8),dimension(3) :: u,ud
20956       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20957       real(kind=8) :: estr_nucl,diff
20958       integer :: iti,i,j,k,nbi
20959       estr_nucl=0.0d0
20960 !C      print *,"I enter ebond"
20961       if (energy_dec) &
20962       write (iout,*) "ibondp_start,ibondp_end",&
20963        ibondp_nucl_start,ibondp_nucl_end
20964       do i=ibondp_nucl_start,ibondp_nucl_end
20965         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20966          itype(i,2).eq.ntyp1_molec(2)) cycle
20967 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20968 !          do j=1,3
20969 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20970 !     &      *dc(j,i-1)/vbld(i)
20971 !          enddo
20972 !          if (energy_dec) write(iout,*)
20973 !     &       "estr1",i,vbld(i),distchainmax,
20974 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20975
20976           diff = vbld(i)-vbldp0_nucl
20977           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20978           vbldp0_nucl,diff,AKP_nucl*diff*diff
20979           estr_nucl=estr_nucl+diff*diff
20980 !          print *,estr_nucl
20981           do j=1,3
20982             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20983           enddo
20984 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20985       enddo
20986       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20987 !      print *,"partial sum", estr_nucl,AKP_nucl
20988
20989       if (energy_dec) &
20990       write (iout,*) "ibondp_start,ibondp_end",&
20991        ibond_nucl_start,ibond_nucl_end
20992
20993       do i=ibond_nucl_start,ibond_nucl_end
20994 !C        print *, "I am stuck",i
20995         iti=itype(i,2)
20996         if (iti.eq.ntyp1_molec(2)) cycle
20997           nbi=nbondterm_nucl(iti)
20998 !C        print *,iti,nbi
20999           if (nbi.eq.1) then
21000             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21001
21002             if (energy_dec) &
21003            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21004            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21005             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21006 !            print *,estr_nucl
21007             do j=1,3
21008               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21009             enddo
21010           else
21011             do j=1,nbi
21012               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21013               ud(j)=aksc_nucl(j,iti)*diff
21014               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21015             enddo
21016             uprod=u(1)
21017             do j=2,nbi
21018               uprod=uprod*u(j)
21019             enddo
21020             usum=0.0d0
21021             usumsqder=0.0d0
21022             do j=1,nbi
21023               uprod1=1.0d0
21024               uprod2=1.0d0
21025               do k=1,nbi
21026                 if (k.ne.j) then
21027                   uprod1=uprod1*u(k)
21028                   uprod2=uprod2*u(k)*u(k)
21029                 endif
21030               enddo
21031               usum=usum+uprod1
21032               usumsqder=usumsqder+ud(j)*uprod2
21033             enddo
21034             estr_nucl=estr_nucl+uprod/usum
21035             do j=1,3
21036              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21037             enddo
21038         endif
21039       enddo
21040 !C      print *,"I am about to leave ebond"
21041       return
21042       end subroutine ebond_nucl
21043
21044 !-----------------------------------------------------------------------------
21045       subroutine ebend_nucl(etheta_nucl)
21046       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21047       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21048       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21049       logical :: lprn=.false., lprn1=.false.
21050 !el local variables
21051       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21052       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21053       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21054 ! local variables for constrains
21055       real(kind=8) :: difi,thetiii
21056        integer itheta
21057       etheta_nucl=0.0D0
21058 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21059       do i=ithet_nucl_start,ithet_nucl_end
21060         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21061         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21062         (itype(i,2).eq.ntyp1_molec(2))) cycle
21063         dethetai=0.0d0
21064         dephii=0.0d0
21065         dephii1=0.0d0
21066         theti2=0.5d0*theta(i)
21067         ityp2=ithetyp_nucl(itype(i-1,2))
21068         do k=1,nntheterm_nucl
21069           coskt(k)=dcos(k*theti2)
21070           sinkt(k)=dsin(k*theti2)
21071         enddo
21072         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21073 #ifdef OSF
21074           phii=phi(i)
21075           if (phii.ne.phii) phii=150.0
21076 #else
21077           phii=phi(i)
21078 #endif
21079           ityp1=ithetyp_nucl(itype(i-2,2))
21080           do k=1,nsingle_nucl
21081             cosph1(k)=dcos(k*phii)
21082             sinph1(k)=dsin(k*phii)
21083           enddo
21084         else
21085           phii=0.0d0
21086           ityp1=nthetyp_nucl+1
21087           do k=1,nsingle_nucl
21088             cosph1(k)=0.0d0
21089             sinph1(k)=0.0d0
21090           enddo
21091         endif
21092
21093         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21094 #ifdef OSF
21095           phii1=phi(i+1)
21096           if (phii1.ne.phii1) phii1=150.0
21097           phii1=pinorm(phii1)
21098 #else
21099           phii1=phi(i+1)
21100 #endif
21101           ityp3=ithetyp_nucl(itype(i,2))
21102           do k=1,nsingle_nucl
21103             cosph2(k)=dcos(k*phii1)
21104             sinph2(k)=dsin(k*phii1)
21105           enddo
21106         else
21107           phii1=0.0d0
21108           ityp3=nthetyp_nucl+1
21109           do k=1,nsingle_nucl
21110             cosph2(k)=0.0d0
21111             sinph2(k)=0.0d0
21112           enddo
21113         endif
21114         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21115         do k=1,ndouble_nucl
21116           do l=1,k-1
21117             ccl=cosph1(l)*cosph2(k-l)
21118             ssl=sinph1(l)*sinph2(k-l)
21119             scl=sinph1(l)*cosph2(k-l)
21120             csl=cosph1(l)*sinph2(k-l)
21121             cosph1ph2(l,k)=ccl-ssl
21122             cosph1ph2(k,l)=ccl+ssl
21123             sinph1ph2(l,k)=scl+csl
21124             sinph1ph2(k,l)=scl-csl
21125           enddo
21126         enddo
21127         if (lprn) then
21128         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21129          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21130         write (iout,*) "coskt and sinkt",nntheterm_nucl
21131         do k=1,nntheterm_nucl
21132           write (iout,*) k,coskt(k),sinkt(k)
21133         enddo
21134         endif
21135         do k=1,ntheterm_nucl
21136           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21137           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21138            *coskt(k)
21139           if (lprn)&
21140          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21141           " ethetai",ethetai
21142         enddo
21143         if (lprn) then
21144         write (iout,*) "cosph and sinph"
21145         do k=1,nsingle_nucl
21146           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21147         enddo
21148         write (iout,*) "cosph1ph2 and sinph2ph2"
21149         do k=2,ndouble_nucl
21150           do l=1,k-1
21151             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21152               sinph1ph2(l,k),sinph1ph2(k,l)
21153           enddo
21154         enddo
21155         write(iout,*) "ethetai",ethetai
21156         endif
21157         do m=1,ntheterm2_nucl
21158           do k=1,nsingle_nucl
21159             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21160               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21161               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21162               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21163             ethetai=ethetai+sinkt(m)*aux
21164             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21165             dephii=dephii+k*sinkt(m)*(&
21166                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21167                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21168             dephii1=dephii1+k*sinkt(m)*(&
21169                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21170                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21171             if (lprn) &
21172            write (iout,*) "m",m," k",k," bbthet",&
21173               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21174               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21175               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21176               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21177           enddo
21178         enddo
21179         if (lprn) &
21180         write(iout,*) "ethetai",ethetai
21181         do m=1,ntheterm3_nucl
21182           do k=2,ndouble_nucl
21183             do l=1,k-1
21184               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21185                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21186                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21187                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21188               ethetai=ethetai+sinkt(m)*aux
21189               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21190               dephii=dephii+l*sinkt(m)*(&
21191                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21192                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21193                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21194                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21195               dephii1=dephii1+(k-l)*sinkt(m)*( &
21196                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21197                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21198                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21199                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21200               if (lprn) then
21201               write (iout,*) "m",m," k",k," l",l," ffthet", &
21202                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21203                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21204                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21205                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21206               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21207                  cosph1ph2(k,l)*sinkt(m),&
21208                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21209               endif
21210             enddo
21211           enddo
21212         enddo
21213 10      continue
21214         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21215         i,theta(i)*rad2deg,phii*rad2deg, &
21216         phii1*rad2deg,ethetai
21217         etheta_nucl=etheta_nucl+ethetai
21218 !        print *,i,"partial sum",etheta_nucl
21219         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21220         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21221         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21222       enddo
21223       return
21224       end subroutine ebend_nucl
21225 !----------------------------------------------------
21226       subroutine etor_nucl(etors_nucl)
21227 !      implicit real*8 (a-h,o-z)
21228 !      include 'DIMENSIONS'
21229 !      include 'COMMON.VAR'
21230 !      include 'COMMON.GEO'
21231 !      include 'COMMON.LOCAL'
21232 !      include 'COMMON.TORSION'
21233 !      include 'COMMON.INTERACT'
21234 !      include 'COMMON.DERIV'
21235 !      include 'COMMON.CHAIN'
21236 !      include 'COMMON.NAMES'
21237 !      include 'COMMON.IOUNITS'
21238 !      include 'COMMON.FFIELD'
21239 !      include 'COMMON.TORCNSTR'
21240 !      include 'COMMON.CONTROL'
21241       real(kind=8) :: etors_nucl,edihcnstr
21242       logical :: lprn
21243 !el local variables
21244       integer :: i,j,iblock,itori,itori1
21245       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21246                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21247 ! Set lprn=.true. for debugging
21248       lprn=.false.
21249 !     lprn=.true.
21250       etors_nucl=0.0D0
21251 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21252       do i=iphi_nucl_start,iphi_nucl_end
21253         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21254              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21255              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21256         etors_ii=0.0D0
21257         itori=itortyp_nucl(itype(i-2,2))
21258         itori1=itortyp_nucl(itype(i-1,2))
21259         phii=phi(i)
21260 !         print *,i,itori,itori1
21261         gloci=0.0D0
21262 !C Regular cosine and sine terms
21263         do j=1,nterm_nucl(itori,itori1)
21264           v1ij=v1_nucl(j,itori,itori1)
21265           v2ij=v2_nucl(j,itori,itori1)
21266           cosphi=dcos(j*phii)
21267           sinphi=dsin(j*phii)
21268           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21269           if (energy_dec) etors_ii=etors_ii+&
21270                      v1ij*cosphi+v2ij*sinphi
21271           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21272         enddo
21273 !C Lorentz terms
21274 !C                         v1
21275 !C  E = SUM ----------------------------------- - v1
21276 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21277 !C
21278         cosphi=dcos(0.5d0*phii)
21279         sinphi=dsin(0.5d0*phii)
21280         do j=1,nlor_nucl(itori,itori1)
21281           vl1ij=vlor1_nucl(j,itori,itori1)
21282           vl2ij=vlor2_nucl(j,itori,itori1)
21283           vl3ij=vlor3_nucl(j,itori,itori1)
21284           pom=vl2ij*cosphi+vl3ij*sinphi
21285           pom1=1.0d0/(pom*pom+1.0d0)
21286           etors_nucl=etors_nucl+vl1ij*pom1
21287           if (energy_dec) etors_ii=etors_ii+ &
21288                      vl1ij*pom1
21289           pom=-pom*pom1*pom1
21290           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21291         enddo
21292 !C Subtract the constant term
21293         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21294           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21295               'etor',i,etors_ii-v0_nucl(itori,itori1)
21296         if (lprn) &
21297        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21298        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21299        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21300         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21301 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21302       enddo
21303       return
21304       end subroutine etor_nucl
21305 !------------------------------------------------------------
21306       subroutine epp_nucl_sub(evdw1,ees)
21307 !C
21308 !C This subroutine calculates the average interaction energy and its gradient
21309 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21310 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21311 !C The potential depends both on the distance of peptide-group centers and on
21312 !C the orientation of the CA-CA virtual bonds.
21313 !C
21314       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21315       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21316       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21317                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21318                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21319       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21320                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21321       integer xshift,yshift,zshift
21322       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21323       real(kind=8) :: ees,eesij
21324 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21325       real(kind=8) scal_el /0.5d0/
21326       t_eelecij=0.0d0
21327       ees=0.0D0
21328       evdw1=0.0D0
21329       ind=0
21330 !c
21331 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21332 !c
21333 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21334       do i=iatel_s_nucl,iatel_e_nucl
21335         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21336         dxi=dc(1,i)
21337         dyi=dc(2,i)
21338         dzi=dc(3,i)
21339         dx_normi=dc_norm(1,i)
21340         dy_normi=dc_norm(2,i)
21341         dz_normi=dc_norm(3,i)
21342         xmedi=c(1,i)+0.5d0*dxi
21343         ymedi=c(2,i)+0.5d0*dyi
21344         zmedi=c(3,i)+0.5d0*dzi
21345           xmedi=dmod(xmedi,boxxsize)
21346           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21347           ymedi=dmod(ymedi,boxysize)
21348           if (ymedi.lt.0) ymedi=ymedi+boxysize
21349           zmedi=dmod(zmedi,boxzsize)
21350           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21351
21352         do j=ielstart_nucl(i),ielend_nucl(i)
21353           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21354           ind=ind+1
21355           dxj=dc(1,j)
21356           dyj=dc(2,j)
21357           dzj=dc(3,j)
21358 !          xj=c(1,j)+0.5D0*dxj-xmedi
21359 !          yj=c(2,j)+0.5D0*dyj-ymedi
21360 !          zj=c(3,j)+0.5D0*dzj-zmedi
21361           xj=c(1,j)+0.5D0*dxj
21362           yj=c(2,j)+0.5D0*dyj
21363           zj=c(3,j)+0.5D0*dzj
21364           xj=mod(xj,boxxsize)
21365           if (xj.lt.0) xj=xj+boxxsize
21366           yj=mod(yj,boxysize)
21367           if (yj.lt.0) yj=yj+boxysize
21368           zj=mod(zj,boxzsize)
21369           if (zj.lt.0) zj=zj+boxzsize
21370       isubchap=0
21371       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21372       xj_safe=xj
21373       yj_safe=yj
21374       zj_safe=zj
21375       do xshift=-1,1
21376       do yshift=-1,1
21377       do zshift=-1,1
21378           xj=xj_safe+xshift*boxxsize
21379           yj=yj_safe+yshift*boxysize
21380           zj=zj_safe+zshift*boxzsize
21381           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21382           if(dist_temp.lt.dist_init) then
21383             dist_init=dist_temp
21384             xj_temp=xj
21385             yj_temp=yj
21386             zj_temp=zj
21387             isubchap=1
21388           endif
21389        enddo
21390        enddo
21391        enddo
21392        if (isubchap.eq.1) then
21393 !C          print *,i,j
21394           xj=xj_temp-xmedi
21395           yj=yj_temp-ymedi
21396           zj=zj_temp-zmedi
21397        else
21398           xj=xj_safe-xmedi
21399           yj=yj_safe-ymedi
21400           zj=zj_safe-zmedi
21401        endif
21402
21403           rij=xj*xj+yj*yj+zj*zj
21404 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21405           fac=(r0pp**2/rij)**3
21406           ev1=epspp*fac*fac
21407           ev2=epspp*fac
21408           evdw1ij=ev1-2*ev2
21409           fac=(-ev1-evdw1ij)/rij
21410 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21411           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21412           evdw1=evdw1+evdw1ij
21413 !C
21414 !C Calculate contributions to the Cartesian gradient.
21415 !C
21416           ggg(1)=fac*xj
21417           ggg(2)=fac*yj
21418           ggg(3)=fac*zj
21419           do k=1,3
21420             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21421             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21422           enddo
21423 !c phoshate-phosphate electrostatic interactions
21424           rij=dsqrt(rij)
21425           fac=1.0d0/rij
21426           eesij=dexp(-BEES*rij)*fac
21427 !          write (2,*)"fac",fac," eesijpp",eesij
21428           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21429           ees=ees+eesij
21430 !c          fac=-eesij*fac
21431           fac=-(fac+BEES)*eesij*fac
21432           ggg(1)=fac*xj
21433           ggg(2)=fac*yj
21434           ggg(3)=fac*zj
21435 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21436 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21437 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21438           do k=1,3
21439             gelpp(k,i)=gelpp(k,i)-ggg(k)
21440             gelpp(k,j)=gelpp(k,j)+ggg(k)
21441           enddo
21442         enddo ! j
21443       enddo   ! i
21444 !c      ees=332.0d0*ees
21445       ees=AEES*ees
21446       do i=nnt,nct
21447 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21448         do k=1,3
21449           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21450 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21451           gelpp(k,i)=AEES*gelpp(k,i)
21452         enddo
21453 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21454       enddo
21455 !c      write (2,*) "total EES",ees
21456       return
21457       end subroutine epp_nucl_sub
21458 !---------------------------------------------------------------------
21459       subroutine epsb(evdwpsb,eelpsb)
21460 !      use comm_locel
21461 !C
21462 !C This subroutine calculates the excluded-volume interaction energy between
21463 !C peptide-group centers and side chains and its gradient in virtual-bond and
21464 !C side-chain vectors.
21465 !C
21466       real(kind=8),dimension(3):: ggg
21467       integer :: i,iint,j,k,iteli,itypj,subchap
21468       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21469                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21470       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21471                     dist_temp, dist_init
21472       integer xshift,yshift,zshift
21473
21474 !cd    print '(a)','Enter ESCP'
21475 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21476       eelpsb=0.0d0
21477       evdwpsb=0.0d0
21478 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21479       do i=iatscp_s_nucl,iatscp_e_nucl
21480         if (itype(i,2).eq.ntyp1_molec(2) &
21481          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21482         xi=0.5D0*(c(1,i)+c(1,i+1))
21483         yi=0.5D0*(c(2,i)+c(2,i+1))
21484         zi=0.5D0*(c(3,i)+c(3,i+1))
21485           xi=mod(xi,boxxsize)
21486           if (xi.lt.0) xi=xi+boxxsize
21487           yi=mod(yi,boxysize)
21488           if (yi.lt.0) yi=yi+boxysize
21489           zi=mod(zi,boxzsize)
21490           if (zi.lt.0) zi=zi+boxzsize
21491
21492         do iint=1,nscp_gr_nucl(i)
21493
21494         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21495           itypj=itype(j,2)
21496           if (itypj.eq.ntyp1_molec(2)) cycle
21497 !C Uncomment following three lines for SC-p interactions
21498 !c         xj=c(1,nres+j)-xi
21499 !c         yj=c(2,nres+j)-yi
21500 !c         zj=c(3,nres+j)-zi
21501 !C Uncomment following three lines for Ca-p interactions
21502 !          xj=c(1,j)-xi
21503 !          yj=c(2,j)-yi
21504 !          zj=c(3,j)-zi
21505           xj=c(1,j)
21506           yj=c(2,j)
21507           zj=c(3,j)
21508           xj=mod(xj,boxxsize)
21509           if (xj.lt.0) xj=xj+boxxsize
21510           yj=mod(yj,boxysize)
21511           if (yj.lt.0) yj=yj+boxysize
21512           zj=mod(zj,boxzsize)
21513           if (zj.lt.0) zj=zj+boxzsize
21514       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21515       xj_safe=xj
21516       yj_safe=yj
21517       zj_safe=zj
21518       subchap=0
21519       do xshift=-1,1
21520       do yshift=-1,1
21521       do zshift=-1,1
21522           xj=xj_safe+xshift*boxxsize
21523           yj=yj_safe+yshift*boxysize
21524           zj=zj_safe+zshift*boxzsize
21525           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21526           if(dist_temp.lt.dist_init) then
21527             dist_init=dist_temp
21528             xj_temp=xj
21529             yj_temp=yj
21530             zj_temp=zj
21531             subchap=1
21532           endif
21533        enddo
21534        enddo
21535        enddo
21536        if (subchap.eq.1) then
21537           xj=xj_temp-xi
21538           yj=yj_temp-yi
21539           zj=zj_temp-zi
21540        else
21541           xj=xj_safe-xi
21542           yj=yj_safe-yi
21543           zj=zj_safe-zi
21544        endif
21545
21546           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21547           fac=rrij**expon2
21548           e1=fac*fac*aad_nucl(itypj)
21549           e2=fac*bad_nucl(itypj)
21550           if (iabs(j-i) .le. 2) then
21551             e1=scal14*e1
21552             e2=scal14*e2
21553           endif
21554           evdwij=e1+e2
21555           evdwpsb=evdwpsb+evdwij
21556           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21557              'evdw2',i,j,evdwij,"tu4"
21558 !C
21559 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21560 !C
21561           fac=-(evdwij+e1)*rrij
21562           ggg(1)=xj*fac
21563           ggg(2)=yj*fac
21564           ggg(3)=zj*fac
21565           do k=1,3
21566             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21567             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21568           enddo
21569         enddo
21570
21571         enddo ! iint
21572       enddo ! i
21573       do i=1,nct
21574         do j=1,3
21575           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21576           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21577         enddo
21578       enddo
21579       return
21580       end subroutine epsb
21581
21582 !------------------------------------------------------
21583       subroutine esb_gb(evdwsb,eelsb)
21584       use comm_locel
21585       use calc_data_nucl
21586       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21587       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21588       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21589       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21590                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21591       integer :: ii
21592       logical lprn
21593       evdw=0.0D0
21594       eelsb=0.0d0
21595       ecorr=0.0d0
21596       evdwsb=0.0D0
21597       lprn=.false.
21598       ind=0
21599 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21600       do i=iatsc_s_nucl,iatsc_e_nucl
21601         num_conti=0
21602         num_conti2=0
21603         itypi=itype(i,2)
21604 !        PRINT *,"I=",i,itypi
21605         if (itypi.eq.ntyp1_molec(2)) cycle
21606         itypi1=itype(i+1,2)
21607         xi=c(1,nres+i)
21608         yi=c(2,nres+i)
21609         zi=c(3,nres+i)
21610           xi=dmod(xi,boxxsize)
21611           if (xi.lt.0) xi=xi+boxxsize
21612           yi=dmod(yi,boxysize)
21613           if (yi.lt.0) yi=yi+boxysize
21614           zi=dmod(zi,boxzsize)
21615           if (zi.lt.0) zi=zi+boxzsize
21616
21617         dxi=dc_norm(1,nres+i)
21618         dyi=dc_norm(2,nres+i)
21619         dzi=dc_norm(3,nres+i)
21620         dsci_inv=vbld_inv(i+nres)
21621 !C
21622 !C Calculate SC interaction energy.
21623 !C
21624         do iint=1,nint_gr_nucl(i)
21625 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21626           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21627             ind=ind+1
21628 !            print *,"JESTEM"
21629             itypj=itype(j,2)
21630             if (itypj.eq.ntyp1_molec(2)) cycle
21631             dscj_inv=vbld_inv(j+nres)
21632             sig0ij=sigma_nucl(itypi,itypj)
21633             chi1=chi_nucl(itypi,itypj)
21634             chi2=chi_nucl(itypj,itypi)
21635             chi12=chi1*chi2
21636             chip1=chip_nucl(itypi,itypj)
21637             chip2=chip_nucl(itypj,itypi)
21638             chip12=chip1*chip2
21639 !            xj=c(1,nres+j)-xi
21640 !            yj=c(2,nres+j)-yi
21641 !            zj=c(3,nres+j)-zi
21642            xj=c(1,nres+j)
21643            yj=c(2,nres+j)
21644            zj=c(3,nres+j)
21645           xj=dmod(xj,boxxsize)
21646           if (xj.lt.0) xj=xj+boxxsize
21647           yj=dmod(yj,boxysize)
21648           if (yj.lt.0) yj=yj+boxysize
21649           zj=dmod(zj,boxzsize)
21650           if (zj.lt.0) zj=zj+boxzsize
21651       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21652       xj_safe=xj
21653       yj_safe=yj
21654       zj_safe=zj
21655       subchap=0
21656       do xshift=-1,1
21657       do yshift=-1,1
21658       do zshift=-1,1
21659           xj=xj_safe+xshift*boxxsize
21660           yj=yj_safe+yshift*boxysize
21661           zj=zj_safe+zshift*boxzsize
21662           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21663           if(dist_temp.lt.dist_init) then
21664             dist_init=dist_temp
21665             xj_temp=xj
21666             yj_temp=yj
21667             zj_temp=zj
21668             subchap=1
21669           endif
21670        enddo
21671        enddo
21672        enddo
21673        if (subchap.eq.1) then
21674           xj=xj_temp-xi
21675           yj=yj_temp-yi
21676           zj=zj_temp-zi
21677        else
21678           xj=xj_safe-xi
21679           yj=yj_safe-yi
21680           zj=zj_safe-zi
21681        endif
21682
21683             dxj=dc_norm(1,nres+j)
21684             dyj=dc_norm(2,nres+j)
21685             dzj=dc_norm(3,nres+j)
21686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21687             rij=dsqrt(rrij)
21688 !C Calculate angle-dependent terms of energy and contributions to their
21689 !C derivatives.
21690             erij(1)=xj*rij
21691             erij(2)=yj*rij
21692             erij(3)=zj*rij
21693             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21694             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21695             om12=dxi*dxj+dyi*dyj+dzi*dzj
21696             call sc_angular_nucl
21697             sigsq=1.0D0/sigsq
21698             sig=sig0ij*dsqrt(sigsq)
21699             rij_shift=1.0D0/rij-sig+sig0ij
21700 !            print *,rij_shift,"rij_shift"
21701 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21702 !c     &       " rij_shift",rij_shift
21703             if (rij_shift.le.0.0D0) then
21704               evdw=1.0D20
21705               return
21706             endif
21707             sigder=-sig*sigsq
21708 !c---------------------------------------------------------------
21709             rij_shift=1.0D0/rij_shift
21710             fac=rij_shift**expon
21711             e1=fac*fac*aa_nucl(itypi,itypj)
21712             e2=fac*bb_nucl(itypi,itypj)
21713             evdwij=eps1*eps2rt*(e1+e2)
21714 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21715 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21716             eps2der=evdwij
21717             evdwij=evdwij*eps2rt
21718             evdwsb=evdwsb+evdwij
21719             if (lprn) then
21720             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21721             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21722             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21723              restyp(itypi,2),i,restyp(itypj,2),j, &
21724              epsi,sigm,chi1,chi2,chip1,chip2, &
21725              eps1,eps2rt**2,sig,sig0ij, &
21726              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21727             evdwij
21728             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21729             endif
21730
21731             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21732                              'evdw',i,j,evdwij,"tu3"
21733
21734
21735 !C Calculate gradient components.
21736             e1=e1*eps1*eps2rt**2
21737             fac=-expon*(e1+evdwij)*rij_shift
21738             sigder=fac*sigder
21739             fac=rij*fac
21740 !c            fac=0.0d0
21741 !C Calculate the radial part of the gradient
21742             gg(1)=xj*fac
21743             gg(2)=yj*fac
21744             gg(3)=zj*fac
21745 !C Calculate angular part of the gradient.
21746             call sc_grad_nucl
21747             call eelsbij(eelij,num_conti2)
21748             if (energy_dec .and. &
21749            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21750           write (istat,'(e14.5)') evdwij
21751             eelsb=eelsb+eelij
21752           enddo      ! j
21753         enddo        ! iint
21754         num_cont_hb(i)=num_conti2
21755       enddo          ! i
21756 !c      write (iout,*) "Number of loop steps in EGB:",ind
21757 !cccc      energy_dec=.false.
21758       return
21759       end subroutine esb_gb
21760 !-------------------------------------------------------------------------------
21761       subroutine eelsbij(eesij,num_conti2)
21762       use comm_locel
21763       use calc_data_nucl
21764       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21765       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21766       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21767                     dist_temp, dist_init,rlocshield,fracinbuf
21768       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21769
21770 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21771       real(kind=8) scal_el /0.5d0/
21772       integer :: iteli,itelj,kkk,kkll,m,isubchap
21773       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21774       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21775       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21776                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21777                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21778                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21779                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21780                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21781                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21782                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21783       ind=ind+1
21784       itypi=itype(i,2)
21785       itypj=itype(j,2)
21786 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21787       ael6i=ael6_nucl(itypi,itypj)
21788       ael3i=ael3_nucl(itypi,itypj)
21789       ael63i=ael63_nucl(itypi,itypj)
21790       ael32i=ael32_nucl(itypi,itypj)
21791 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21792 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21793       dxj=dc(1,j+nres)
21794       dyj=dc(2,j+nres)
21795       dzj=dc(3,j+nres)
21796       dx_normi=dc_norm(1,i+nres)
21797       dy_normi=dc_norm(2,i+nres)
21798       dz_normi=dc_norm(3,i+nres)
21799       dx_normj=dc_norm(1,j+nres)
21800       dy_normj=dc_norm(2,j+nres)
21801       dz_normj=dc_norm(3,j+nres)
21802 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21803 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21804 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21805       if (ipot_nucl.ne.2) then
21806         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21807         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21808         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21809       else
21810         cosa=om12
21811         cosb=om1
21812         cosg=om2
21813       endif
21814       r3ij=rij*rrij
21815       r6ij=r3ij*r3ij
21816       fac=cosa-3.0D0*cosb*cosg
21817       facfac=fac*fac
21818       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21819       fac3=ael6i*r6ij
21820       fac4=ael3i*r3ij
21821       fac5=ael63i*r6ij
21822       fac6=ael32i*r6ij
21823 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21824 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21825       el1=fac3*(4.0D0+facfac-fac1)
21826       el2=fac4*fac
21827       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21828       el4=fac6*facfac
21829       eesij=el1+el2+el3+el4
21830 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21831       ees0ij=4.0D0+facfac-fac1
21832
21833       if (energy_dec) then
21834           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21835           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21836            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21837            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21838            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21839           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21840       endif
21841
21842 !C
21843 !C Calculate contributions to the Cartesian gradient.
21844 !C
21845       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21846       fac1=fac
21847 !c      erij(1)=xj*rmij
21848 !c      erij(2)=yj*rmij
21849 !c      erij(3)=zj*rmij
21850 !*
21851 !* Radial derivatives. First process both termini of the fragment (i,j)
21852 !*
21853       ggg(1)=facel*xj
21854       ggg(2)=facel*yj
21855       ggg(3)=facel*zj
21856       do k=1,3
21857         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21858         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21859         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21860         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21861       enddo
21862 !*
21863 !* Angular part
21864 !*
21865       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21866       fac4=-3.0D0*fac4
21867       fac3=-6.0D0*fac3
21868       fac5= 6.0d0*fac5
21869       fac6=-6.0d0*fac6
21870       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21871        fac6*fac1*cosg
21872       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21873        fac6*fac1*cosb
21874       do k=1,3
21875         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21876         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21877       enddo
21878       do k=1,3
21879         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21880       enddo
21881       do k=1,3
21882         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21883              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21884              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21885         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21886              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21887              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21888         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21889         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21890       enddo
21891 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21892        IF ( j.gt.i+1 .and.&
21893           num_conti.le.maxcont) THEN
21894 !C
21895 !C Calculate the contact function. The ith column of the array JCONT will
21896 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21897 !C greater than I). The arrays FACONT and GACONT will contain the values of
21898 !C the contact function and its derivative.
21899         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21900 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21901         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21902 !c        write (2,*) "fcont",fcont
21903         if (fcont.gt.0.0D0) then
21904           num_conti=num_conti+1
21905           num_conti2=num_conti2+1
21906
21907           if (num_conti.gt.maxconts) then
21908             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21909                           ' will skip next contacts for this conf.',maxconts
21910           else
21911             jcont_hb(num_conti,i)=j
21912 !c            write (iout,*) "num_conti",num_conti,
21913 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21914 !C Calculate contact energies
21915             cosa4=4.0D0*cosa
21916             wij=cosa-3.0D0*cosb*cosg
21917             cosbg1=cosb+cosg
21918             cosbg2=cosb-cosg
21919             fac3=dsqrt(-ael6i)*r3ij
21920 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21921             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21922             if (ees0tmp.gt.0) then
21923               ees0pij=dsqrt(ees0tmp)
21924             else
21925               ees0pij=0
21926             endif
21927             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21928             if (ees0tmp.gt.0) then
21929               ees0mij=dsqrt(ees0tmp)
21930             else
21931               ees0mij=0
21932             endif
21933             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21934             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21935 !c            write (iout,*) "i",i," j",j,
21936 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21937             ees0pij1=fac3/ees0pij
21938             ees0mij1=fac3/ees0mij
21939             fac3p=-3.0D0*fac3*rrij
21940             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21941             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21942             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21943             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21944             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21945             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21946             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21947             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21948             ecosap=ecosa1+ecosa2
21949             ecosbp=ecosb1+ecosb2
21950             ecosgp=ecosg1+ecosg2
21951             ecosam=ecosa1-ecosa2
21952             ecosbm=ecosb1-ecosb2
21953             ecosgm=ecosg1-ecosg2
21954 !C End diagnostics
21955             facont_hb(num_conti,i)=fcont
21956             fprimcont=fprimcont/rij
21957             do k=1,3
21958               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21959               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21960             enddo
21961             gggp(1)=gggp(1)+ees0pijp*xj
21962             gggp(2)=gggp(2)+ees0pijp*yj
21963             gggp(3)=gggp(3)+ees0pijp*zj
21964             gggm(1)=gggm(1)+ees0mijp*xj
21965             gggm(2)=gggm(2)+ees0mijp*yj
21966             gggm(3)=gggm(3)+ees0mijp*zj
21967 !C Derivatives due to the contact function
21968             gacont_hbr(1,num_conti,i)=fprimcont*xj
21969             gacont_hbr(2,num_conti,i)=fprimcont*yj
21970             gacont_hbr(3,num_conti,i)=fprimcont*zj
21971             do k=1,3
21972 !c
21973 !c Gradient of the correlation terms
21974 !c
21975               gacontp_hb1(k,num_conti,i)= &
21976              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21977             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21978               gacontp_hb2(k,num_conti,i)= &
21979              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21980             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21981               gacontp_hb3(k,num_conti,i)=gggp(k)
21982               gacontm_hb1(k,num_conti,i)= &
21983              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21984             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21985               gacontm_hb2(k,num_conti,i)= &
21986              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21987             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21988               gacontm_hb3(k,num_conti,i)=gggm(k)
21989             enddo
21990           endif
21991         endif
21992       ENDIF
21993       return
21994       end subroutine eelsbij
21995 !------------------------------------------------------------------
21996       subroutine sc_grad_nucl
21997       use comm_locel
21998       use calc_data_nucl
21999       real(kind=8),dimension(3) :: dcosom1,dcosom2
22000       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22001       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22002       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22003       do k=1,3
22004         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22005         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22006       enddo
22007       do k=1,3
22008         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22009       enddo
22010       do k=1,3
22011         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22012                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22013                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22014         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22015                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22016                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22017       enddo
22018 !C
22019 !C Calculate the components of the gradient in DC and X
22020 !C
22021       do l=1,3
22022         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22023         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22024       enddo
22025       return
22026       end subroutine sc_grad_nucl
22027 !-----------------------------------------------------------------------
22028       subroutine esb(esbloc)
22029 !C Calculate the local energy of a side chain and its derivatives in the
22030 !C corresponding virtual-bond valence angles THETA and the spherical angles
22031 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22032 !C added by Urszula Kozlowska. 07/11/2007
22033 !C
22034       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22035       real(kind=8),dimension(9):: x
22036      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22037       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22038       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22039       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22040        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22041        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22042        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22043        integer::it,nlobit,i,j,k
22044 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22045       delta=0.02d0*pi
22046       esbloc=0.0D0
22047       do i=loc_start_nucl,loc_end_nucl
22048         if (itype(i,2).eq.ntyp1_molec(2)) cycle
22049         costtab(i+1) =dcos(theta(i+1))
22050         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22051         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22052         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22053         cosfac2=0.5d0/(1.0d0+costtab(i+1))
22054         cosfac=dsqrt(cosfac2)
22055         sinfac2=0.5d0/(1.0d0-costtab(i+1))
22056         sinfac=dsqrt(sinfac2)
22057         it=itype(i,2)
22058         if (it.eq.10) goto 1
22059
22060 !c
22061 !C  Compute the axes of tghe local cartesian coordinates system; store in
22062 !c   x_prime, y_prime and z_prime
22063 !c
22064         do j=1,3
22065           x_prime(j) = 0.00
22066           y_prime(j) = 0.00
22067           z_prime(j) = 0.00
22068         enddo
22069 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22070 !C     &   dc_norm(3,i+nres)
22071         do j = 1,3
22072           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22073           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22074         enddo
22075         do j = 1,3
22076           z_prime(j) = -uz(j,i-1)
22077 !           z_prime(j)=0.0
22078         enddo
22079
22080         xx=0.0d0
22081         yy=0.0d0
22082         zz=0.0d0
22083         do j = 1,3
22084           xx = xx + x_prime(j)*dc_norm(j,i+nres)
22085           yy = yy + y_prime(j)*dc_norm(j,i+nres)
22086           zz = zz + z_prime(j)*dc_norm(j,i+nres)
22087         enddo
22088
22089         xxtab(i)=xx
22090         yytab(i)=yy
22091         zztab(i)=zz
22092          it=itype(i,2)
22093         do j = 1,9
22094           x(j) = sc_parmin_nucl(j,it)
22095         enddo
22096 #ifdef CHECK_COORD
22097 !Cc diagnostics - remove later
22098         xx1 = dcos(alph(2))
22099         yy1 = dsin(alph(2))*dcos(omeg(2))
22100         zz1 = -dsin(alph(2))*dsin(omeg(2))
22101         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22102          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22103          xx1,yy1,zz1
22104 !C,"  --- ", xx_w,yy_w,zz_w
22105 !c end diagnostics
22106 #endif
22107         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22108         esbloc = esbloc + sumene
22109         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22110 !        print *,"enecomp",sumene,sumene2
22111 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22112 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22113 #ifdef DEBUG
22114         write (2,*) "x",(x(k),k=1,9)
22115 !C
22116 !C This section to check the numerical derivatives of the energy of ith side
22117 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22118 !C #define DEBUG in the code to turn it on.
22119 !C
22120         write (2,*) "sumene               =",sumene
22121         aincr=1.0d-7
22122         xxsave=xx
22123         xx=xx+aincr
22124         write (2,*) xx,yy,zz
22125         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22126         de_dxx_num=(sumenep-sumene)/aincr
22127         xx=xxsave
22128         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22129         yysave=yy
22130         yy=yy+aincr
22131         write (2,*) xx,yy,zz
22132         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22133         de_dyy_num=(sumenep-sumene)/aincr
22134         yy=yysave
22135         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22136         zzsave=zz
22137         zz=zz+aincr
22138         write (2,*) xx,yy,zz
22139         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22140         de_dzz_num=(sumenep-sumene)/aincr
22141         zz=zzsave
22142         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22143         costsave=cost2tab(i+1)
22144         sintsave=sint2tab(i+1)
22145         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22146         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22147         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22148         de_dt_num=(sumenep-sumene)/aincr
22149         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22150         cost2tab(i+1)=costsave
22151         sint2tab(i+1)=sintsave
22152 !C End of diagnostics section.
22153 #endif
22154 !C
22155 !C Compute the gradient of esc
22156 !C
22157         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22158         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22159         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22160         de_dtt=0.0d0
22161 #ifdef DEBUG
22162         write (2,*) "x",(x(k),k=1,9)
22163         write (2,*) "xx",xx," yy",yy," zz",zz
22164         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22165           " de_zz   ",de_zz," de_tt   ",de_tt
22166         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22167           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22168 #endif
22169 !C
22170        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22171        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22172        cosfac2xx=cosfac2*xx
22173        sinfac2yy=sinfac2*yy
22174        do k = 1,3
22175          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22176            vbld_inv(i+1)
22177          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22178            vbld_inv(i)
22179          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22180          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22181 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22182 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22183 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22184 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22185          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22186          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22187          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22188          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22189          dZZ_Ci1(k)=0.0d0
22190          dZZ_Ci(k)=0.0d0
22191          do j=1,3
22192            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22193            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22194          enddo
22195
22196          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22197          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22198          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22199 !c
22200          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22201          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22202        enddo
22203
22204        do k=1,3
22205          dXX_Ctab(k,i)=dXX_Ci(k)
22206          dXX_C1tab(k,i)=dXX_Ci1(k)
22207          dYY_Ctab(k,i)=dYY_Ci(k)
22208          dYY_C1tab(k,i)=dYY_Ci1(k)
22209          dZZ_Ctab(k,i)=dZZ_Ci(k)
22210          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22211          dXX_XYZtab(k,i)=dXX_XYZ(k)
22212          dYY_XYZtab(k,i)=dYY_XYZ(k)
22213          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22214        enddo
22215        do k = 1,3
22216 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22217 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22218 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22219 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22220 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22221 !c     &    dt_dci(k)
22222 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22223 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22224          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22225          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22226          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22227          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22228          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22229          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22230 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22231        enddo
22232 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22233 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22234
22235 !C to check gradient call subroutine check_grad
22236
22237     1 continue
22238       enddo
22239       return
22240       end subroutine esb
22241 !=-------------------------------------------------------
22242       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22243 !      implicit none
22244       real(kind=8),dimension(9):: x(9)
22245        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22246       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22247       integer i
22248 !c      write (2,*) "enesc"
22249 !c      write (2,*) "x",(x(i),i=1,9)
22250 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22251       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22252         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22253         + x(9)*yy*zz
22254       enesc_nucl=sumene
22255       return
22256       end function enesc_nucl
22257 !-----------------------------------------------------------------------------
22258       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22259 #ifdef MPI
22260       include 'mpif.h'
22261       integer,parameter :: max_cont=2000
22262       integer,parameter:: max_dim=2*(8*3+6)
22263       integer, parameter :: msglen1=max_cont*max_dim
22264       integer,parameter :: msglen2=2*msglen1
22265       integer source,CorrelType,CorrelID,Error
22266       real(kind=8) :: buffer(max_cont,max_dim)
22267       integer status(MPI_STATUS_SIZE)
22268       integer :: ierror,nbytes
22269 #endif
22270       real(kind=8),dimension(3):: gx(3),gx1(3)
22271       real(kind=8) :: time00
22272       logical lprn,ldone
22273       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22274       real(kind=8) ecorr,ecorr3
22275       integer :: n_corr,n_corr1,mm,msglen
22276 !C Set lprn=.true. for debugging
22277       lprn=.false.
22278       n_corr=0
22279       n_corr1=0
22280 #ifdef MPI
22281       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22282
22283       if (nfgtasks.le.1) goto 30
22284       if (lprn) then
22285         write (iout,'(a)') 'Contact function values:'
22286         do i=nnt,nct-1
22287           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22288          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22289          j=1,num_cont_hb(i))
22290         enddo
22291       endif
22292 !C Caution! Following code assumes that electrostatic interactions concerning
22293 !C a given atom are split among at most two processors!
22294       CorrelType=477
22295       CorrelID=fg_rank+1
22296       ldone=.false.
22297       do i=1,max_cont
22298         do j=1,max_dim
22299           buffer(i,j)=0.0D0
22300         enddo
22301       enddo
22302       mm=mod(fg_rank,2)
22303 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22304       if (mm) 20,20,10
22305    10 continue
22306 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22307       if (fg_rank.gt.0) then
22308 !C Send correlation contributions to the preceding processor
22309         msglen=msglen1
22310         nn=num_cont_hb(iatel_s_nucl)
22311         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22312 !c        write (*,*) 'The BUFFER array:'
22313 !c        do i=1,nn
22314 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22315 !c        enddo
22316         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22317           msglen=msglen2
22318           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22319 !C Clear the contacts of the atom passed to the neighboring processor
22320         nn=num_cont_hb(iatel_s_nucl+1)
22321 !c        do i=1,nn
22322 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22323 !c        enddo
22324             num_cont_hb(iatel_s_nucl)=0
22325         endif
22326 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22327 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22328 !cd   & ' msglen=',msglen
22329 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22330 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22331 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22332         time00=MPI_Wtime()
22333         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22334          CorrelType,FG_COMM,IERROR)
22335         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22336 !cd      write (iout,*) 'Processor ',fg_rank,
22337 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22338 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22339 !c        write (*,*) 'Processor ',fg_rank,
22340 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22341 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22342 !c        msglen=msglen1
22343       endif ! (fg_rank.gt.0)
22344       if (ldone) goto 30
22345       ldone=.true.
22346    20 continue
22347 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22348       if (fg_rank.lt.nfgtasks-1) then
22349 !C Receive correlation contributions from the next processor
22350         msglen=msglen1
22351         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22352 !cd      write (iout,*) 'Processor',fg_rank,
22353 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22354 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22355 !c        write (*,*) 'Processor',fg_rank,
22356 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22357 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22358         time00=MPI_Wtime()
22359         nbytes=-1
22360         do while (nbytes.le.0)
22361           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22362           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22363         enddo
22364 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22365         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22366          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22367         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22368 !c        write (*,*) 'Processor',fg_rank,
22369 !c     &' has received correlation contribution from processor',fg_rank+1,
22370 !c     & ' msglen=',msglen,' nbytes=',nbytes
22371 !c        write (*,*) 'The received BUFFER array:'
22372 !c        do i=1,max_cont
22373 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22374 !c        enddo
22375         if (msglen.eq.msglen1) then
22376           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22377         else if (msglen.eq.msglen2)  then
22378           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22379           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22380         else
22381           write (iout,*) &
22382       'ERROR!!!! message length changed while processing correlations.'
22383           write (*,*) &
22384       'ERROR!!!! message length changed while processing correlations.'
22385           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22386         endif ! msglen.eq.msglen1
22387       endif ! fg_rank.lt.nfgtasks-1
22388       if (ldone) goto 30
22389       ldone=.true.
22390       goto 10
22391    30 continue
22392 #endif
22393       if (lprn) then
22394         write (iout,'(a)') 'Contact function values:'
22395         do i=nnt_molec(2),nct_molec(2)-1
22396           write (iout,'(2i3,50(1x,i2,f5.2))') &
22397          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22398          j=1,num_cont_hb(i))
22399         enddo
22400       endif
22401       ecorr=0.0D0
22402       ecorr3=0.0d0
22403 !C Remove the loop below after debugging !!!
22404 !      do i=nnt_molec(2),nct_molec(2)
22405 !        do j=1,3
22406 !          gradcorr_nucl(j,i)=0.0D0
22407 !          gradxorr_nucl(j,i)=0.0D0
22408 !          gradcorr3_nucl(j,i)=0.0D0
22409 !          gradxorr3_nucl(j,i)=0.0D0
22410 !        enddo
22411 !      enddo
22412 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22413 !C Calculate the local-electrostatic correlation terms
22414       do i=iatsc_s_nucl,iatsc_e_nucl
22415         i1=i+1
22416         num_conti=num_cont_hb(i)
22417         num_conti1=num_cont_hb(i+1)
22418 !        print *,i,num_conti,num_conti1
22419         do jj=1,num_conti
22420           j=jcont_hb(jj,i)
22421           do kk=1,num_conti1
22422             j1=jcont_hb(kk,i1)
22423 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22424 !c     &         ' jj=',jj,' kk=',kk
22425             if (j1.eq.j+1 .or. j1.eq.j-1) then
22426 !C
22427 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22428 !C The system gains extra energy.
22429 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22430 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22431 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22432 !C
22433               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22434               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22435                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22436               n_corr=n_corr+1
22437             else if (j1.eq.j) then
22438 !C
22439 !C Contacts I-J and I-(J+1) occur simultaneously.
22440 !C The system loses extra energy.
22441 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22442 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22443 !C Need to implement full formulas 32 from Liwo et al., 1998.
22444 !C
22445 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22446 !c     &         ' jj=',jj,' kk=',kk
22447               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22448             endif
22449           enddo ! kk
22450           do kk=1,num_conti
22451             j1=jcont_hb(kk,i)
22452 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22453 !c     &         ' jj=',jj,' kk=',kk
22454             if (j1.eq.j+1) then
22455 !C Contacts I-J and (I+1)-J occur simultaneously.
22456 !C The system loses extra energy.
22457               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22458             endif ! j1==j+1
22459           enddo ! kk
22460         enddo ! jj
22461       enddo ! i
22462       return
22463       end subroutine multibody_hb_nucl
22464 !-----------------------------------------------------------
22465       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22466 !      implicit real*8 (a-h,o-z)
22467 !      include 'DIMENSIONS'
22468 !      include 'COMMON.IOUNITS'
22469 !      include 'COMMON.DERIV'
22470 !      include 'COMMON.INTERACT'
22471 !      include 'COMMON.CONTACTS'
22472       real(kind=8),dimension(3) :: gx,gx1
22473       logical :: lprn
22474 !el local variables
22475       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22476       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22477                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22478                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22479                    rlocshield
22480
22481       lprn=.false.
22482       eij=facont_hb(jj,i)
22483       ekl=facont_hb(kk,k)
22484       ees0pij=ees0p(jj,i)
22485       ees0pkl=ees0p(kk,k)
22486       ees0mij=ees0m(jj,i)
22487       ees0mkl=ees0m(kk,k)
22488       ekont=eij*ekl
22489       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22490 !      print *,"ehbcorr_nucl",ekont,ees
22491 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22492 !C Following 4 lines for diagnostics.
22493 !cd    ees0pkl=0.0D0
22494 !cd    ees0pij=1.0D0
22495 !cd    ees0mkl=0.0D0
22496 !cd    ees0mij=1.0D0
22497 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22498 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22499 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22500 !C Calculate the multi-body contribution to energy.
22501 !      ecorr_nucl=ecorr_nucl+ekont*ees
22502 !C Calculate multi-body contributions to the gradient.
22503       coeffpees0pij=coeffp*ees0pij
22504       coeffmees0mij=coeffm*ees0mij
22505       coeffpees0pkl=coeffp*ees0pkl
22506       coeffmees0mkl=coeffm*ees0mkl
22507       do ll=1,3
22508         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22509        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22510        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22511         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22512         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22513         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22514         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22515         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22516         coeffmees0mij*gacontm_hb1(ll,kk,k))
22517         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22518         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22519         coeffmees0mij*gacontm_hb2(ll,kk,k))
22520         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22521           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22522           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22523         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22524         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22525         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22526           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22527           coeffmees0mij*gacontm_hb3(ll,kk,k))
22528         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22529         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22530         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22531         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22532         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22533         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22534       enddo
22535       ehbcorr_nucl=ekont*ees
22536       return
22537       end function ehbcorr_nucl
22538 !-------------------------------------------------------------------------
22539
22540      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22541 !      implicit real*8 (a-h,o-z)
22542 !      include 'DIMENSIONS'
22543 !      include 'COMMON.IOUNITS'
22544 !      include 'COMMON.DERIV'
22545 !      include 'COMMON.INTERACT'
22546 !      include 'COMMON.CONTACTS'
22547       real(kind=8),dimension(3) :: gx,gx1
22548       logical :: lprn
22549 !el local variables
22550       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22551       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22552                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22553                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22554                    rlocshield
22555
22556       lprn=.false.
22557       eij=facont_hb(jj,i)
22558       ekl=facont_hb(kk,k)
22559       ees0pij=ees0p(jj,i)
22560       ees0pkl=ees0p(kk,k)
22561       ees0mij=ees0m(jj,i)
22562       ees0mkl=ees0m(kk,k)
22563       ekont=eij*ekl
22564       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22565 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22566 !C Following 4 lines for diagnostics.
22567 !cd    ees0pkl=0.0D0
22568 !cd    ees0pij=1.0D0
22569 !cd    ees0mkl=0.0D0
22570 !cd    ees0mij=1.0D0
22571 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22572 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22573 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22574 !C Calculate the multi-body contribution to energy.
22575 !      ecorr=ecorr+ekont*ees
22576 !C Calculate multi-body contributions to the gradient.
22577       coeffpees0pij=coeffp*ees0pij
22578       coeffmees0mij=coeffm*ees0mij
22579       coeffpees0pkl=coeffp*ees0pkl
22580       coeffmees0mkl=coeffm*ees0mkl
22581       do ll=1,3
22582         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22583        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22584        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22585         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22586         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22587         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22588         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22589         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22590         coeffmees0mij*gacontm_hb1(ll,kk,k))
22591         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22592         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22593         coeffmees0mij*gacontm_hb2(ll,kk,k))
22594         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22595           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22596           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22597         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22598         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22599         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22600           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22601           coeffmees0mij*gacontm_hb3(ll,kk,k))
22602         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22603         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22604         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22605         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22606         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22607         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22608       enddo
22609       ehbcorr3_nucl=ekont*ees
22610       return
22611       end function ehbcorr3_nucl
22612 #ifdef MPI
22613       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22614       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22615       real(kind=8):: buffer(dimen1,dimen2)
22616       num_kont=num_cont_hb(atom)
22617       do i=1,num_kont
22618         do k=1,8
22619           do j=1,3
22620             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22621           enddo ! j
22622         enddo ! k
22623         buffer(i,indx+25)=facont_hb(i,atom)
22624         buffer(i,indx+26)=ees0p(i,atom)
22625         buffer(i,indx+27)=ees0m(i,atom)
22626         buffer(i,indx+28)=d_cont(i,atom)
22627         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22628       enddo ! i
22629       buffer(1,indx+30)=dfloat(num_kont)
22630       return
22631       end subroutine pack_buffer
22632 !c------------------------------------------------------------------------------
22633       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22634       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22635       real(kind=8):: buffer(dimen1,dimen2)
22636 !      double precision zapas
22637 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22638 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22639 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22640 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22641       num_kont=buffer(1,indx+30)
22642       num_kont_old=num_cont_hb(atom)
22643       num_cont_hb(atom)=num_kont+num_kont_old
22644       do i=1,num_kont
22645         ii=i+num_kont_old
22646         do k=1,8
22647           do j=1,3
22648             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22649           enddo ! j
22650         enddo ! k
22651         facont_hb(ii,atom)=buffer(i,indx+25)
22652         ees0p(ii,atom)=buffer(i,indx+26)
22653         ees0m(ii,atom)=buffer(i,indx+27)
22654         d_cont(i,atom)=buffer(i,indx+28)
22655         jcont_hb(ii,atom)=buffer(i,indx+29)
22656       enddo ! i
22657       return
22658       end subroutine unpack_buffer
22659 !c------------------------------------------------------------------------------
22660 #endif
22661       subroutine ecatcat(ecationcation)
22662         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22663         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22664         r7,r4,ecationcation,k0,rcal
22665         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22666         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22667         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22668         gg,r
22669
22670         ecationcation=0.0d0
22671         if (nres_molec(5).eq.0) return
22672         rcat0=3.472
22673         epscalc=0.05
22674         r06 = rcat0**6
22675         r012 = r06**2
22676 !        k0 = 332.0*(2.0*2.0)/80.0
22677         itmp=0
22678
22679         do i=1,4
22680         itmp=itmp+nres_molec(i)
22681         enddo
22682 !        write(iout,*) "itmp",itmp
22683         do i=itmp+1,itmp+nres_molec(5)-1
22684
22685         xi=c(1,i)
22686         yi=c(2,i)
22687         zi=c(3,i)
22688           itypi=itype(i,5)
22689           xi=mod(xi,boxxsize)
22690           if (xi.lt.0) xi=xi+boxxsize
22691           yi=mod(yi,boxysize)
22692           if (yi.lt.0) yi=yi+boxysize
22693           zi=mod(zi,boxzsize)
22694           if (zi.lt.0) zi=zi+boxzsize
22695
22696           do j=i+1,itmp+nres_molec(5)
22697           itypj=itype(j,5)
22698           k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22699 !           print *,i,j,'catcat'
22700            xj=c(1,j)
22701            yj=c(2,j)
22702            zj=c(3,j)
22703           xj=dmod(xj,boxxsize)
22704           if (xj.lt.0) xj=xj+boxxsize
22705           yj=dmod(yj,boxysize)
22706           if (yj.lt.0) yj=yj+boxysize
22707           zj=dmod(zj,boxzsize)
22708           if (zj.lt.0) zj=zj+boxzsize
22709 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22710       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22711       xj_safe=xj
22712       yj_safe=yj
22713       zj_safe=zj
22714       subchap=0
22715       do xshift=-1,1
22716       do yshift=-1,1
22717       do zshift=-1,1
22718           xj=xj_safe+xshift*boxxsize
22719           yj=yj_safe+yshift*boxysize
22720           zj=zj_safe+zshift*boxzsize
22721           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22722           if(dist_temp.lt.dist_init) then
22723             dist_init=dist_temp
22724             xj_temp=xj
22725             yj_temp=yj
22726             zj_temp=zj
22727             subchap=1
22728           endif
22729        enddo
22730        enddo
22731        enddo
22732        if (subchap.eq.1) then
22733           xj=xj_temp-xi
22734           yj=yj_temp-yi
22735           zj=zj_temp-zi
22736        else
22737           xj=xj_safe-xi
22738           yj=yj_safe-yi
22739           zj=zj_safe-zi
22740        endif
22741        rcal =xj**2+yj**2+zj**2
22742         ract=sqrt(rcal)
22743 !        rcat0=3.472
22744 !        epscalc=0.05
22745 !        r06 = rcat0**6
22746 !        r012 = r06**2
22747 !        k0 = 332*(2*2)/80
22748         Evan1cat=epscalc*(r012/rcal**6)
22749         Evan2cat=epscalc*2*(r06/rcal**3)
22750         Eeleccat=k0/ract
22751         r7 = rcal**7
22752         r4 = rcal**4
22753         r(1)=xj
22754         r(2)=yj
22755         r(3)=zj
22756         do k=1,3
22757           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22758           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22759           dEeleccat(k)=-k0*r(k)/ract**3
22760         enddo
22761         do k=1,3
22762           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22763           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22764           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22765         enddo
22766
22767 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22768         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22769        enddo
22770        enddo
22771        return
22772        end subroutine ecatcat
22773 !---------------------------------------------------------------------------
22774 ! new for K+
22775       subroutine ecats_prot_amber(evdw)
22776 !      subroutine ecat_prot2(ecation_prot)
22777       use calc_data
22778       use comm_momo
22779
22780       logical :: lprn
22781 !el local variables
22782       integer :: iint,itypi1,subchap,isel,itmp
22783       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22784       real(kind=8) :: evdw
22785       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22786                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22787                     sslipi,sslipj,faclip,alpha_sco
22788       integer :: ii
22789       real(kind=8) :: fracinbuf
22790       real (kind=8) :: escpho
22791       real (kind=8),dimension(4):: ener
22792       real(kind=8) :: b1,b2,egb
22793       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22794        Lambf,&
22795        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22796        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22797        federmaus,&
22798        d1i,d1j
22799 !       real(kind=8),dimension(3,2)::erhead_tail
22800 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22801       real(kind=8) ::  facd4, adler, Fgb, facd3
22802       integer troll,jj,istate
22803       real (kind=8) :: dcosom1(3),dcosom2(3)
22804
22805       evdw=0.0D0
22806       if (nres_molec(5).eq.0) return
22807       eps_out=80.0d0
22808 !      sss_ele_cut=1.0d0
22809
22810         itmp=0
22811         do i=1,4
22812         itmp=itmp+nres_molec(i)
22813         enddo
22814         go to 17
22815 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22816         do i=ibond_start,ibond_end
22817
22818 !        print *,"I am in EVDW",i
22819         itypi=iabs(itype(i,1))
22820
22821 !        if (i.ne.47) cycle
22822         if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22823         itypi1=iabs(itype(i+1,1))
22824         xi=c(1,nres+i)
22825         yi=c(2,nres+i)
22826         zi=c(3,nres+i)
22827           xi=dmod(xi,boxxsize)
22828           if (xi.lt.0) xi=xi+boxxsize
22829           yi=dmod(yi,boxysize)
22830           if (yi.lt.0) yi=yi+boxysize
22831           zi=dmod(zi,boxzsize)
22832           if (zi.lt.0) zi=zi+boxzsize
22833         dxi=dc_norm(1,nres+i)
22834         dyi=dc_norm(2,nres+i)
22835         dzi=dc_norm(3,nres+i)
22836         dsci_inv=vbld_inv(i+nres)
22837          do j=itmp+1,itmp+nres_molec(5)
22838
22839 ! Calculate SC interaction energy.
22840             itypj=iabs(itype(j,5))
22841             if ((itypj.eq.ntyp1)) cycle
22842              CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22843
22844             dscj_inv=0.0
22845            xj=c(1,j)
22846            yj=c(2,j)
22847            zj=c(3,j)
22848            xj=dmod(xj,boxxsize)
22849            if (xj.lt.0) xj=xj+boxxsize
22850            yj=dmod(yj,boxysize)
22851            if (yj.lt.0) yj=yj+boxysize
22852            zj=dmod(zj,boxzsize)
22853            if (zj.lt.0) zj=zj+boxzsize
22854           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22855           xj_safe=xj
22856           yj_safe=yj
22857           zj_safe=zj
22858           subchap=0
22859
22860           do xshift=-1,1
22861           do yshift=-1,1
22862           do zshift=-1,1
22863           xj=xj_safe+xshift*boxxsize
22864           yj=yj_safe+yshift*boxysize
22865           zj=zj_safe+zshift*boxzsize
22866           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22867           if(dist_temp.lt.dist_init) then
22868             dist_init=dist_temp
22869             xj_temp=xj
22870             yj_temp=yj
22871             zj_temp=zj
22872             subchap=1
22873           endif
22874           enddo
22875           enddo
22876           enddo
22877           if (subchap.eq.1) then
22878           xj=xj_temp-xi
22879           yj=yj_temp-yi
22880           zj=zj_temp-zi
22881           else
22882           xj=xj_safe-xi
22883           yj=yj_safe-yi
22884           zj=zj_safe-zi
22885           endif
22886
22887 !          dxj = dc_norm( 1, nres+j )
22888 !          dyj = dc_norm( 2, nres+j )
22889 !          dzj = dc_norm( 3, nres+j )
22890
22891           itypi = itype(i,1)
22892           itypj = itype(j,5)
22893 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22894 ! sampling performed with amber package
22895 !          alf1   = 0.0d0
22896 !          alf2   = 0.0d0
22897 !          alf12  = 0.0d0
22898 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22899           chi1 = chicat(itypi,itypj)
22900           chis1 = chiscat(itypi,itypj)
22901           chip1 = chippcat(itypi,itypj)
22902 !          chi1=0.0d0
22903 !          chis1=0.0d0
22904 !          chip1=0.0d0
22905           chi2=0.0
22906           chip2=0.0
22907           chis2=0.0
22908 !          chis2 = chis(itypj,itypi)
22909           chis12 = chis1 * chis2
22910           sig1 = sigmap1cat(itypi,itypj)
22911 !          sig2 = sigmap2(itypi,itypj)
22912 ! alpha factors from Fcav/Gcav
22913           b1cav = alphasurcat(1,itypi,itypj)
22914           b2cav = alphasurcat(2,itypi,itypj)
22915           b3cav = alphasurcat(3,itypi,itypj)
22916           b4cav = alphasurcat(4,itypi,itypj)
22917
22918 ! used to determine whether we want to do quadrupole calculations
22919        eps_in = epsintabcat(itypi,itypj)
22920        if (eps_in.eq.0.0) eps_in=1.0
22921
22922        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22923 !       Rtail = 0.0d0
22924
22925        DO k = 1, 3
22926         ctail(k,1)=c(k,i+nres)
22927         ctail(k,2)=c(k,j)
22928        END DO
22929 !c! tail distances will be themselves usefull elswhere
22930 !c1 (in Gcav, for example)
22931        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22932        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22933        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22934        Rtail = dsqrt( &
22935           (Rtail_distance(1)*Rtail_distance(1)) &
22936         + (Rtail_distance(2)*Rtail_distance(2)) &
22937         + (Rtail_distance(3)*Rtail_distance(3)))
22938 ! tail location and distance calculations
22939 ! dhead1
22940        d1 = dheadcat(1, 1, itypi, itypj)
22941 !       d2 = dhead(2, 1, itypi, itypj)
22942        DO k = 1,3
22943 ! location of polar head is computed by taking hydrophobic centre
22944 ! and moving by a d1 * dc_norm vector
22945 ! see unres publications for very informative images
22946         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22947         chead(k,2) = c(k, j)
22948 ! distance
22949 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22950 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22951         Rhead_distance(k) = chead(k,2) - chead(k,1)
22952        END DO
22953 ! pitagoras (root of sum of squares)
22954        Rhead = dsqrt( &
22955           (Rhead_distance(1)*Rhead_distance(1)) &
22956         + (Rhead_distance(2)*Rhead_distance(2)) &
22957         + (Rhead_distance(3)*Rhead_distance(3)))
22958 !-------------------------------------------------------------------
22959 ! zero everything that should be zero'ed
22960        evdwij = 0.0d0
22961        ECL = 0.0d0
22962        Elj = 0.0d0
22963        Equad = 0.0d0
22964        Epol = 0.0d0
22965        Fcav=0.0d0
22966        eheadtail = 0.0d0
22967        dGCLdOM1 = 0.0d0
22968        dGCLdOM2 = 0.0d0
22969        dGCLdOM12 = 0.0d0
22970        dPOLdOM1 = 0.0d0
22971        dPOLdOM2 = 0.0d0
22972           Fcav = 0.0d0
22973           dFdR = 0.0d0
22974           dCAVdOM1  = 0.0d0
22975           dCAVdOM2  = 0.0d0
22976           dCAVdOM12 = 0.0d0
22977           dscj_inv = vbld_inv(j+nres)
22978 !          print *,i,j,dscj_inv,dsci_inv
22979 ! rij holds 1/(distance of Calpha atoms)
22980           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22981           rij  = dsqrt(rrij)
22982           CALL sc_angular
22983 ! this should be in elgrad_init but om's are calculated by sc_angular
22984 ! which in turn is used by older potentials
22985 ! om = omega, sqom = om^2
22986           sqom1  = om1 * om1
22987           sqom2  = om2 * om2
22988           sqom12 = om12 * om12
22989
22990 ! now we calculate EGB - Gey-Berne
22991 ! It will be summed up in evdwij and saved in evdw
22992           sigsq     = 1.0D0  / sigsq
22993           sig       = sig0ij * dsqrt(sigsq)
22994 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22995           rij_shift = Rtail - sig + sig0ij
22996           IF (rij_shift.le.0.0D0) THEN
22997            evdw = 1.0D20
22998            RETURN
22999           END IF
23000           sigder = -sig * sigsq
23001           rij_shift = 1.0D0 / rij_shift
23002           fac       = rij_shift**expon
23003           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23004 !          print *,"ADAM",aa_aq(itypi,itypj)
23005
23006 !          c1        = 0.0d0
23007           c2        = fac  * bb_aq_cat(itypi,itypj)
23008 !          c2        = 0.0d0
23009           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23010           eps2der   = eps3rt * evdwij
23011           eps3der   = eps2rt * evdwij
23012 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23013           evdwij    = eps2rt * eps3rt * evdwij
23014 !#ifdef TSCSC
23015 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23016 !           evdw_p = evdw_p + evdwij
23017 !          ELSE
23018 !           evdw_m = evdw_m + evdwij
23019 !          END IF
23020 !#else
23021           evdw = evdw  &
23022               + evdwij
23023 !#endif
23024           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23025           fac    = -expon * (c1 + evdwij) * rij_shift
23026           sigder = fac * sigder
23027 ! Calculate distance derivative
23028           gg(1) =  fac
23029           gg(2) =  fac
23030           gg(3) =  fac
23031
23032           fac = chis1 * sqom1 + chis2 * sqom2 &
23033           - 2.0d0 * chis12 * om1 * om2 * om12
23034           pom = 1.0d0 - chis1 * chis2 * sqom12
23035           Lambf = (1.0d0 - (fac / pom))
23036           Lambf = dsqrt(Lambf)
23037           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23038           Chif = Rtail * sparrow
23039           ChiLambf = Chif * Lambf
23040           eagle = dsqrt(ChiLambf)
23041           bat = ChiLambf ** 11.0d0
23042           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23043           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23044           botsq = bot * bot
23045           Fcav = top / bot
23046
23047        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23048        dbot = 12.0d0 * b4cav * bat * Lambf
23049        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23050
23051           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23052           dbot = 12.0d0 * b4cav * bat * Chif
23053           eagle = Lambf * pom
23054           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23055           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23056           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23057               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23058
23059           dFdL = ((dtop * bot - top * dbot) / botsq)
23060           dCAVdOM1  = dFdL * ( dFdOM1 )
23061           dCAVdOM2  = dFdL * ( dFdOM2 )
23062           dCAVdOM12 = dFdL * ( dFdOM12 )
23063
23064        DO k= 1, 3
23065         ertail(k) = Rtail_distance(k)/Rtail
23066        END DO
23067        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23068        erdxj = scalar( ertail(1), dC_norm(1,j) )
23069        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23070        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23071        DO k = 1, 3
23072         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23073         gradpepcatx(k,i) = gradpepcatx(k,i) &
23074                   - (( dFdR + gg(k) ) * pom)
23075         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23076 !        gvdwx(k,j) = gvdwx(k,j)   &
23077 !                  + (( dFdR + gg(k) ) * pom)
23078         gradpepcat(k,i) = gradpepcat(k,i)  &
23079                   - (( dFdR + gg(k) ) * ertail(k))
23080         gradpepcat(k,j) = gradpepcat(k,j) &
23081                   + (( dFdR + gg(k) ) * ertail(k))
23082         gg(k) = 0.0d0
23083        ENDDO
23084 !c! Compute head-head and head-tail energies for each state
23085           isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23086           IF (isel.eq.0) THEN
23087 !c! No charges - do nothing
23088            eheadtail = 0.0d0
23089
23090           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
23091 !c! Nonpolar-charge interactions
23092           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23093             Qi=Qi*2
23094             Qij=Qij*2
23095            endif
23096           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23097             Qj=Qj*2
23098             Qij=Qij*2
23099            endif
23100
23101            CALL enq_cat(epol)
23102            eheadtail = epol
23103 !           eheadtail = 0.0d0
23104
23105           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
23106 !c! Dipole-charge interactions
23107           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23108             Qi=Qi*2
23109             Qij=Qij*2
23110            endif
23111           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23112             Qj=Qj*2
23113             Qij=Qij*2
23114            endif
23115            CALL edq_cat(ecl, elj, epol)
23116           eheadtail = ECL + elj + epol
23117 !           eheadtail = 0.0d0
23118
23119           ELSE IF ((isel.eq.2.and.   &
23120                iabs(Qi).eq.1).and.  &
23121                nstatecat(itypi,itypj).eq.1) THEN
23122
23123 !c! Same charge-charge interaction ( +/+ or -/- )
23124           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23125             Qi=Qi*2
23126             Qij=Qij*2
23127            endif
23128           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23129             Qj=Qj*2
23130             Qij=Qij*2
23131            endif
23132
23133            CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23134            eheadtail = ECL + Egb + Epol + Fisocav + Elj
23135 !           eheadtail = 0.0d0
23136
23137 !          ELSE IF ((isel.eq.2.and.  &
23138 !               iabs(Qi).eq.1).and. &
23139 !               nstate(itypi,itypj).ne.1) THEN
23140 !c! Different charge-charge interaction ( +/- or -/+ )
23141 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23142 !            Qi=Qi*2
23143 !            Qij=Qij*2
23144 !           endif
23145 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23146 !            Qj=Qj*2
23147 !            Qij=Qij*2
23148 !           endif
23149 !
23150 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23151        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23152         evdw = evdw  + Fcav + eheadtail
23153
23154        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23155         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23156         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23157         Equad,evdwij+Fcav+eheadtail,evdw
23158 !       evdw = evdw  + Fcav  + eheadtail
23159
23160 !        iF (nstate(itypi,itypj).eq.1) THEN
23161         CALL sc_grad_cat
23162 !       END IF
23163 !c!-------------------------------------------------------------------
23164 !c! NAPISY KONCOWE
23165          END DO   ! j
23166        END DO     ! i
23167 !c      write (iout,*) "Number of loop steps in EGB:",ind
23168 !c      energy_dec=.false.
23169 !              print *,"EVDW KURW",evdw,nres
23170 !!!        return
23171    17   continue
23172         do i=ibond_start,ibond_end
23173
23174 !        print *,"I am in EVDW",i
23175         itypi=10 ! the peptide group parameters are for glicine
23176
23177 !        if (i.ne.47) cycle
23178         if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
23179         itypi1=iabs(itype(i+1,1))
23180         xi=(c(1,i)+c(1,i+1))/2.0
23181         yi=(c(2,i)+c(2,i+1))/2.0
23182         zi=(c(3,i)+c(3,i+1))/2.0
23183           xi=dmod(xi,boxxsize)
23184           if (xi.lt.0) xi=xi+boxxsize
23185           yi=dmod(yi,boxysize)
23186           if (yi.lt.0) yi=yi+boxysize
23187           zi=dmod(zi,boxzsize)
23188           if (zi.lt.0) zi=zi+boxzsize
23189         dxi=dc_norm(1,i)
23190         dyi=dc_norm(2,i)
23191         dzi=dc_norm(3,i)
23192         dsci_inv=vbld_inv(i+1)/2.0
23193          do j=itmp+1,itmp+nres_molec(5)
23194
23195 ! Calculate SC interaction energy.
23196             itypj=iabs(itype(j,5))
23197             if ((itypj.eq.ntyp1)) cycle
23198              CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23199
23200             dscj_inv=0.0
23201            xj=c(1,j)
23202            yj=c(2,j)
23203            zj=c(3,j)
23204            xj=dmod(xj,boxxsize)
23205            if (xj.lt.0) xj=xj+boxxsize
23206            yj=dmod(yj,boxysize)
23207            if (yj.lt.0) yj=yj+boxysize
23208            zj=dmod(zj,boxzsize)
23209            if (zj.lt.0) zj=zj+boxzsize
23210           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23211           xj_safe=xj
23212           yj_safe=yj
23213           zj_safe=zj
23214           subchap=0
23215
23216           do xshift=-1,1
23217           do yshift=-1,1
23218           do zshift=-1,1
23219           xj=xj_safe+xshift*boxxsize
23220           yj=yj_safe+yshift*boxysize
23221           zj=zj_safe+zshift*boxzsize
23222           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23223           if(dist_temp.lt.dist_init) then
23224             dist_init=dist_temp
23225             xj_temp=xj
23226             yj_temp=yj
23227             zj_temp=zj
23228             subchap=1
23229           endif
23230           enddo
23231           enddo
23232           enddo
23233           if (subchap.eq.1) then
23234           xj=xj_temp-xi
23235           yj=yj_temp-yi
23236           zj=zj_temp-zi
23237           else
23238           xj=xj_safe-xi
23239           yj=yj_safe-yi
23240           zj=zj_safe-zi
23241           endif
23242
23243           dxj = 0.0d0! dc_norm( 1, nres+j )
23244           dyj = 0.0d0!dc_norm( 2, nres+j )
23245           dzj = 0.0d0! dc_norm( 3, nres+j )
23246
23247           itypi = 10
23248           itypj = itype(j,5)
23249 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23250 ! sampling performed with amber package
23251 !          alf1   = 0.0d0
23252 !          alf2   = 0.0d0
23253 !          alf12  = 0.0d0
23254 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23255           chi1 = chicat(itypi,itypj)
23256           chis1 = chiscat(itypi,itypj)
23257           chip1 = chippcat(itypi,itypj)
23258 !          chi1=0.0d0
23259 !          chis1=0.0d0
23260 !          chip1=0.0d0
23261           chi2=0.0
23262           chip2=0.0
23263           chis2=0.0
23264 !          chis2 = chis(itypj,itypi)
23265           chis12 = chis1 * chis2
23266           sig1 = sigmap1cat(itypi,itypj)
23267 !          sig2 = sigmap2(itypi,itypj)
23268 ! alpha factors from Fcav/Gcav
23269           b1cav = alphasurcat(1,itypi,itypj)
23270           b2cav = alphasurcat(2,itypi,itypj)
23271           b3cav = alphasurcat(3,itypi,itypj)
23272           b4cav = alphasurcat(4,itypi,itypj)
23273
23274 ! used to determine whether we want to do quadrupole calculations
23275        eps_in = epsintabcat(itypi,itypj)
23276        if (eps_in.eq.0.0) eps_in=1.0
23277
23278        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23279 !       Rtail = 0.0d0
23280
23281        DO k = 1, 3
23282         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
23283         ctail(k,2)=c(k,j)
23284        END DO
23285 !c! tail distances will be themselves usefull elswhere
23286 !c1 (in Gcav, for example)
23287        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
23288        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
23289        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
23290        Rtail = dsqrt( &
23291           (Rtail_distance(1)*Rtail_distance(1)) &
23292         + (Rtail_distance(2)*Rtail_distance(2)) &
23293         + (Rtail_distance(3)*Rtail_distance(3)))
23294 ! tail location and distance calculations
23295 ! dhead1
23296        d1 = dheadcat(1, 1, itypi, itypj)
23297 !       d2 = dhead(2, 1, itypi, itypj)
23298        DO k = 1,3
23299 ! location of polar head is computed by taking hydrophobic centre
23300 ! and moving by a d1 * dc_norm vector
23301 ! see unres publications for very informative images
23302         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
23303         chead(k,2) = c(k, j)
23304 ! distance
23305 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23306 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23307         Rhead_distance(k) = chead(k,2) - chead(k,1)
23308        END DO
23309 ! pitagoras (root of sum of squares)
23310        Rhead = dsqrt( &
23311           (Rhead_distance(1)*Rhead_distance(1)) &
23312         + (Rhead_distance(2)*Rhead_distance(2)) &
23313         + (Rhead_distance(3)*Rhead_distance(3)))
23314 !-------------------------------------------------------------------
23315 ! zero everything that should be zero'ed
23316        evdwij = 0.0d0
23317        ECL = 0.0d0
23318        Elj = 0.0d0
23319        Equad = 0.0d0
23320        Epol = 0.0d0
23321        Fcav=0.0d0
23322        eheadtail = 0.0d0
23323        dGCLdOM1 = 0.0d0
23324        dGCLdOM2 = 0.0d0
23325        dGCLdOM12 = 0.0d0
23326        dPOLdOM1 = 0.0d0
23327        dPOLdOM2 = 0.0d0
23328           Fcav = 0.0d0
23329           dFdR = 0.0d0
23330           dCAVdOM1  = 0.0d0
23331           dCAVdOM2  = 0.0d0
23332           dCAVdOM12 = 0.0d0
23333           dscj_inv = vbld_inv(j+nres)
23334 !          print *,i,j,dscj_inv,dsci_inv
23335 ! rij holds 1/(distance of Calpha atoms)
23336           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23337           rij  = dsqrt(rrij)
23338           CALL sc_angular
23339 ! this should be in elgrad_init but om's are calculated by sc_angular
23340 ! which in turn is used by older potentials
23341 ! om = omega, sqom = om^2
23342           sqom1  = om1 * om1
23343           sqom2  = om2 * om2
23344           sqom12 = om12 * om12
23345
23346 ! now we calculate EGB - Gey-Berne
23347 ! It will be summed up in evdwij and saved in evdw
23348           sigsq     = 1.0D0  / sigsq
23349           sig       = sig0ij * dsqrt(sigsq)
23350 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23351           rij_shift = Rtail - sig + sig0ij
23352           IF (rij_shift.le.0.0D0) THEN
23353            evdw = 1.0D20
23354            RETURN
23355           END IF
23356           sigder = -sig * sigsq
23357           rij_shift = 1.0D0 / rij_shift
23358           fac       = rij_shift**expon
23359           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23360 !          print *,"ADAM",aa_aq(itypi,itypj)
23361
23362 !          c1        = 0.0d0
23363           c2        = fac  * bb_aq_cat(itypi,itypj)
23364 !          c2        = 0.0d0
23365           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23366           eps2der   = eps3rt * evdwij
23367           eps3der   = eps2rt * evdwij
23368 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23369           evdwij    = eps2rt * eps3rt * evdwij
23370 !#ifdef TSCSC
23371 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23372 !           evdw_p = evdw_p + evdwij
23373 !          ELSE
23374 !           evdw_m = evdw_m + evdwij
23375 !          END IF
23376 !#else
23377           evdw = evdw  &
23378               + evdwij
23379 !#endif
23380           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23381           fac    = -expon * (c1 + evdwij) * rij_shift
23382           sigder = fac * sigder
23383 ! Calculate distance derivative
23384           gg(1) =  fac
23385           gg(2) =  fac
23386           gg(3) =  fac
23387
23388           fac = chis1 * sqom1 + chis2 * sqom2 &
23389           - 2.0d0 * chis12 * om1 * om2 * om12
23390
23391           pom = 1.0d0 - chis1 * chis2 * sqom12
23392           print *,"TUT2",fac,chis1,sqom1,pom
23393           Lambf = (1.0d0 - (fac / pom))
23394           Lambf = dsqrt(Lambf)
23395           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23396           Chif = Rtail * sparrow
23397           ChiLambf = Chif * Lambf
23398           eagle = dsqrt(ChiLambf)
23399           bat = ChiLambf ** 11.0d0
23400           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23401           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23402           botsq = bot * bot
23403           Fcav = top / bot
23404
23405        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23406        dbot = 12.0d0 * b4cav * bat * Lambf
23407        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23408
23409           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23410           dbot = 12.0d0 * b4cav * bat * Chif
23411           eagle = Lambf * pom
23412           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23413           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23414           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23415               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23416
23417           dFdL = ((dtop * bot - top * dbot) / botsq)
23418           dCAVdOM1  = dFdL * ( dFdOM1 )
23419           dCAVdOM2  = dFdL * ( dFdOM2 )
23420           dCAVdOM12 = dFdL * ( dFdOM12 )
23421
23422        DO k= 1, 3
23423         ertail(k) = Rtail_distance(k)/Rtail
23424        END DO
23425        erdxi = scalar( ertail(1), dC_norm(1,i) )
23426        erdxj = scalar( ertail(1), dC_norm(1,j) )
23427        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23428        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23429        DO k = 1, 3
23430         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23431 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23432 !                  - (( dFdR + gg(k) ) * pom)
23433         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23434 !        gvdwx(k,j) = gvdwx(k,j)   &
23435 !                  + (( dFdR + gg(k) ) * pom)
23436         gradpepcat(k,i) = gradpepcat(k,i)  &
23437                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23438         gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23439                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23440
23441         gradpepcat(k,j) = gradpepcat(k,j) &
23442                   + (( dFdR + gg(k) ) * ertail(k))
23443         gg(k) = 0.0d0
23444        ENDDO
23445 !c! Compute head-head and head-tail energies for each state
23446           isel = 3
23447 !c! Dipole-charge interactions
23448           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23449             Qi=Qi*2
23450             Qij=Qij*2
23451            endif
23452           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23453             Qj=Qj*2
23454             Qij=Qij*2
23455            endif
23456            CALL edq_cat_pep(ecl, elj, epol)
23457            eheadtail = ECL + elj + epol
23458 !          print *,"i,",i,eheadtail
23459            eheadtail = 0.0d0
23460
23461         evdw = evdw  + Fcav + eheadtail
23462
23463        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23464         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23465         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23466         Equad,evdwij+Fcav+eheadtail,evdw
23467 !       evdw = evdw  + Fcav  + eheadtail
23468
23469 !        iF (nstate(itypi,itypj).eq.1) THEN
23470         CALL sc_grad_cat_pep
23471 !       END IF
23472 !c!-------------------------------------------------------------------
23473 !c! NAPISY KONCOWE
23474          END DO   ! j
23475        END DO     ! i
23476 !c      write (iout,*) "Number of loop steps in EGB:",ind
23477 !c      energy_dec=.false.
23478 !              print *,"EVDW KURW",evdw,nres
23479
23480
23481       return
23482       end subroutine ecats_prot_amber
23483
23484 !---------------------------------------------------------------------------
23485 ! old for Ca2+
23486        subroutine ecat_prot(ecation_prot)
23487 !      use calc_data
23488 !      use comm_momo
23489        integer i,j,k,subchap,itmp,inum
23490         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23491         r7,r4,ecationcation
23492         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23493         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23494         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23495         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23496         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23497         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23498         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23499         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23500         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23501         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23502         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23503         ndiv,ndivi
23504         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23505         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23506         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23507         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23508         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23509         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23510         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23511         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23512         dEvan1Cat
23513         real(kind=8),dimension(6) :: vcatprm
23514         ecation_prot=0.0d0
23515 ! first lets calculate interaction with peptide groups
23516         if (nres_molec(5).eq.0) return
23517         itmp=0
23518         do i=1,4
23519         itmp=itmp+nres_molec(i)
23520         enddo
23521 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23522         do i=ibond_start,ibond_end
23523 !         cycle
23524          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23525         xi=0.5d0*(c(1,i)+c(1,i+1))
23526         yi=0.5d0*(c(2,i)+c(2,i+1))
23527         zi=0.5d0*(c(3,i)+c(3,i+1))
23528           xi=mod(xi,boxxsize)
23529           if (xi.lt.0) xi=xi+boxxsize
23530           yi=mod(yi,boxysize)
23531           if (yi.lt.0) yi=yi+boxysize
23532           zi=mod(zi,boxzsize)
23533           if (zi.lt.0) zi=zi+boxzsize
23534
23535          do j=itmp+1,itmp+nres_molec(5)
23536 !           print *,"WTF",itmp,j,i
23537 ! all parameters were for Ca2+ to approximate single charge divide by two
23538          ndiv=1.0
23539          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23540          wconst=78*ndiv
23541         wdip =1.092777950857032D2
23542         wdip=wdip/wconst
23543         wmodquad=-2.174122713004870D4
23544         wmodquad=wmodquad/wconst
23545         wquad1 = 3.901232068562804D1
23546         wquad1=wquad1/wconst
23547         wquad2 = 3
23548         wquad2=wquad2/wconst
23549         wvan1 = 0.1
23550         wvan2 = 6
23551 !        itmp=0
23552
23553            xj=c(1,j)
23554            yj=c(2,j)
23555            zj=c(3,j)
23556           xj=dmod(xj,boxxsize)
23557           if (xj.lt.0) xj=xj+boxxsize
23558           yj=dmod(yj,boxysize)
23559           if (yj.lt.0) yj=yj+boxysize
23560           zj=dmod(zj,boxzsize)
23561           if (zj.lt.0) zj=zj+boxzsize
23562       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23563       xj_safe=xj
23564       yj_safe=yj
23565       zj_safe=zj
23566       subchap=0
23567       do xshift=-1,1
23568       do yshift=-1,1
23569       do zshift=-1,1
23570           xj=xj_safe+xshift*boxxsize
23571           yj=yj_safe+yshift*boxysize
23572           zj=zj_safe+zshift*boxzsize
23573           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23574           if(dist_temp.lt.dist_init) then
23575             dist_init=dist_temp
23576             xj_temp=xj
23577             yj_temp=yj
23578             zj_temp=zj
23579             subchap=1
23580           endif
23581        enddo
23582        enddo
23583        enddo
23584        if (subchap.eq.1) then
23585           xj=xj_temp-xi
23586           yj=yj_temp-yi
23587           zj=zj_temp-zi
23588        else
23589           xj=xj_safe-xi
23590           yj=yj_safe-yi
23591           zj=zj_safe-zi
23592        endif
23593 !       enddo
23594 !       enddo
23595        rcpm = sqrt(xj**2+yj**2+zj**2)
23596        drcp_norm(1)=xj/rcpm
23597        drcp_norm(2)=yj/rcpm
23598        drcp_norm(3)=zj/rcpm
23599        dcmag=0.0
23600        do k=1,3
23601        dcmag=dcmag+dc(k,i)**2
23602        enddo
23603        dcmag=dsqrt(dcmag)
23604        do k=1,3
23605          myd_norm(k)=dc(k,i)/dcmag
23606        enddo
23607         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23608         drcp_norm(3)*myd_norm(3)
23609         rsecp = rcpm**2
23610         Ir = 1.0d0/rcpm
23611         Irsecp = 1.0d0/rsecp
23612         Irthrp = Irsecp/rcpm
23613         Irfourp = Irthrp/rcpm
23614         Irfiftp = Irfourp/rcpm
23615         Irsistp=Irfiftp/rcpm
23616         Irseven=Irsistp/rcpm
23617         Irtwelv=Irsistp*Irsistp
23618         Irthir=Irtwelv/rcpm
23619         sin2thet = (1-costhet*costhet)
23620         sinthet=sqrt(sin2thet)
23621         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23622              *sin2thet
23623         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23624              2*wvan2**6*Irsistp)
23625         ecation_prot = ecation_prot+E1+E2
23626 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23627         dE1dr = -2*costhet*wdip*Irthrp-&
23628          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23629         dE2dr = 3*wquad1*wquad2*Irfourp-     &
23630           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23631         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23632         do k=1,3
23633           drdpep(k) = -drcp_norm(k)
23634           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23635           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23636           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23637           dEddci(k) = dEdcos*dcosddci(k)
23638         enddo
23639         do k=1,3
23640         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23641         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23642         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23643         enddo
23644        enddo ! j
23645        enddo ! i
23646 !------------------------------------------sidechains
23647 !        do i=1,nres_molec(1)
23648         do i=ibond_start,ibond_end
23649          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23650 !         cycle
23651 !        print *,i,ecation_prot
23652         xi=(c(1,i+nres))
23653         yi=(c(2,i+nres))
23654         zi=(c(3,i+nres))
23655           xi=mod(xi,boxxsize)
23656           if (xi.lt.0) xi=xi+boxxsize
23657           yi=mod(yi,boxysize)
23658           if (yi.lt.0) yi=yi+boxysize
23659           zi=mod(zi,boxzsize)
23660           if (zi.lt.0) zi=zi+boxzsize
23661           do k=1,3
23662             cm1(k)=dc(k,i+nres)
23663           enddo
23664            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23665          do j=itmp+1,itmp+nres_molec(5)
23666          ndiv=1.0
23667          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23668
23669            xj=c(1,j)
23670            yj=c(2,j)
23671            zj=c(3,j)
23672           xj=dmod(xj,boxxsize)
23673           if (xj.lt.0) xj=xj+boxxsize
23674           yj=dmod(yj,boxysize)
23675           if (yj.lt.0) yj=yj+boxysize
23676           zj=dmod(zj,boxzsize)
23677           if (zj.lt.0) zj=zj+boxzsize
23678       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23679       xj_safe=xj
23680       yj_safe=yj
23681       zj_safe=zj
23682       subchap=0
23683       do xshift=-1,1
23684       do yshift=-1,1
23685       do zshift=-1,1
23686           xj=xj_safe+xshift*boxxsize
23687           yj=yj_safe+yshift*boxysize
23688           zj=zj_safe+zshift*boxzsize
23689           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23690           if(dist_temp.lt.dist_init) then
23691             dist_init=dist_temp
23692             xj_temp=xj
23693             yj_temp=yj
23694             zj_temp=zj
23695             subchap=1
23696           endif
23697        enddo
23698        enddo
23699        enddo
23700        if (subchap.eq.1) then
23701           xj=xj_temp-xi
23702           yj=yj_temp-yi
23703           zj=zj_temp-zi
23704        else
23705           xj=xj_safe-xi
23706           yj=yj_safe-yi
23707           zj=zj_safe-zi
23708        endif
23709 !       enddo
23710 !       enddo
23711 ! 15- Glu 16-Asp
23712          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23713          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23714          (itype(i,1).eq.25))) then
23715             if(itype(i,1).eq.16) then
23716             inum=1
23717             else
23718             inum=2
23719             endif
23720             do k=1,6
23721             vcatprm(k)=catprm(k,inum)
23722             enddo
23723             dASGL=catprm(7,inum)
23724 !             do k=1,3
23725 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23726                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23727                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23728                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23729
23730 !                valpha(k)=c(k,i)
23731 !                vcat(k)=c(k,j)
23732                 if (subchap.eq.1) then
23733                  vcat(1)=xj_temp
23734                  vcat(2)=yj_temp
23735                  vcat(3)=zj_temp
23736                  else
23737                 vcat(1)=xj_safe
23738                 vcat(2)=yj_safe
23739                 vcat(3)=zj_safe
23740                  endif
23741                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23742                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23743                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23744
23745 !              enddo
23746         do k=1,3
23747           dx(k) = vcat(k)-vcm(k)
23748         enddo
23749         do k=1,3
23750           v1(k)=(vcm(k)-valpha(k))
23751           v2(k)=(vcat(k)-valpha(k))
23752         enddo
23753         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23754         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23755         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23756
23757 !  The weights of the energy function calculated from
23758 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23759           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23760             ndivi=0.5
23761           else
23762             ndivi=1.0
23763           endif
23764          ndiv=1.0
23765          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23766
23767         wh2o=78*ndivi*ndiv
23768         wc = vcatprm(1)
23769         wc=wc/wh2o
23770         wdip =vcatprm(2)
23771         wdip=wdip/wh2o
23772         wquad1 =vcatprm(3)
23773         wquad1=wquad1/wh2o
23774         wquad2 = vcatprm(4)
23775         wquad2=wquad2/wh2o
23776         wquad2p = 1.0d0-wquad2
23777         wvan1 = vcatprm(5)
23778         wvan2 =vcatprm(6)
23779         opt = dx(1)**2+dx(2)**2
23780         rsecp = opt+dx(3)**2
23781         rs = sqrt(rsecp)
23782         rthrp = rsecp*rs
23783         rfourp = rthrp*rs
23784         rsixp = rfourp*rsecp
23785         reight=rsixp*rsecp
23786         Ir = 1.0d0/rs
23787         Irsecp = 1.0d0/rsecp
23788         Irthrp = Irsecp/rs
23789         Irfourp = Irthrp/rs
23790         Irsixp = 1.0d0/rsixp
23791         Ireight=1.0d0/reight
23792         Irtw=Irsixp*Irsixp
23793         Irthir=Irtw/rs
23794         Irfourt=Irthir/rs
23795         opt1 = (4*rs*dx(3)*wdip)
23796         opt2 = 6*rsecp*wquad1*opt
23797         opt3 = wquad1*wquad2p*Irsixp
23798         opt4 = (wvan1*wvan2**12)
23799         opt5 = opt4*12*Irfourt
23800         opt6 = 2*wvan1*wvan2**6
23801         opt7 = 6*opt6*Ireight
23802         opt8 = wdip/v1m
23803         opt10 = wdip/v2m
23804         opt11 = (rsecp*v2m)**2
23805         opt12 = (rsecp*v1m)**2
23806         opt14 = (v1m*v2m*rsecp)**2
23807         opt15 = -wquad1/v2m**2
23808         opt16 = (rthrp*(v1m*v2m)**2)**2
23809         opt17 = (v1m**2*rthrp)**2
23810         opt18 = -wquad1/rthrp
23811         opt19 = (v1m**2*v2m**2)**2
23812         Ec = wc*Ir
23813         do k=1,3
23814           dEcCat(k) = -(dx(k)*wc)*Irthrp
23815           dEcCm(k)=(dx(k)*wc)*Irthrp
23816           dEcCalp(k)=0.0d0
23817         enddo
23818         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23819         do k=1,3
23820           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23821                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23822           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23823                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23824           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23825                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23826                       *v1dpv2)/opt14
23827         enddo
23828         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23829         do k=1,3
23830           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23831                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23832                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23833           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23834                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23835                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23836           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23837                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23838                         v1dpv2**2)/opt19
23839         enddo
23840         Equad2=wquad1*wquad2p*Irthrp
23841         do k=1,3
23842           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23843           dEquad2Cm(k)=3*dx(k)*rs*opt3
23844           dEquad2Calp(k)=0.0d0
23845         enddo
23846         Evan1=opt4*Irtw
23847         do k=1,3
23848           dEvan1Cat(k)=-dx(k)*opt5
23849           dEvan1Cm(k)=dx(k)*opt5
23850           dEvan1Calp(k)=0.0d0
23851         enddo
23852         Evan2=-opt6*Irsixp
23853         do k=1,3
23854           dEvan2Cat(k)=dx(k)*opt7
23855           dEvan2Cm(k)=-dx(k)*opt7
23856           dEvan2Calp(k)=0.0d0
23857         enddo
23858         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23859 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23860
23861         do k=1,3
23862           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23863                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23864 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23865           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23866                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23867           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23868                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23869         enddo
23870             dscmag = 0.0d0
23871             do k=1,3
23872               dscvec(k) = dc(k,i+nres)
23873               dscmag = dscmag+dscvec(k)*dscvec(k)
23874             enddo
23875             dscmag3 = dscmag
23876             dscmag = sqrt(dscmag)
23877             dscmag3 = dscmag3*dscmag
23878             constA = 1.0d0+dASGL/dscmag
23879             constB = 0.0d0
23880             do k=1,3
23881               constB = constB+dscvec(k)*dEtotalCm(k)
23882             enddo
23883             constB = constB*dASGL/dscmag3
23884             do k=1,3
23885               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23886               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23887                constA*dEtotalCm(k)-constB*dscvec(k)
23888 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23889               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23890               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23891              enddo
23892         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23893            if(itype(i,1).eq.14) then
23894             inum=3
23895             else
23896             inum=4
23897             endif
23898             do k=1,6
23899             vcatprm(k)=catprm(k,inum)
23900             enddo
23901             dASGL=catprm(7,inum)
23902 !             do k=1,3
23903 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23904 !                valpha(k)=c(k,i)
23905 !                vcat(k)=c(k,j)
23906 !              enddo
23907                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23908                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23909                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23910                 if (subchap.eq.1) then
23911                  vcat(1)=xj_temp
23912                  vcat(2)=yj_temp
23913                  vcat(3)=zj_temp
23914                  else
23915                 vcat(1)=xj_safe
23916                 vcat(2)=yj_safe
23917                 vcat(3)=zj_safe
23918                 endif
23919                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23920                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23921                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23922
23923
23924         do k=1,3
23925           dx(k) = vcat(k)-vcm(k)
23926         enddo
23927         do k=1,3
23928           v1(k)=(vcm(k)-valpha(k))
23929           v2(k)=(vcat(k)-valpha(k))
23930         enddo
23931         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23932         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23933         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23934 !  The weights of the energy function calculated from
23935 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23936          ndiv=1.0
23937          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23938
23939         wh2o=78*ndiv
23940         wdip =vcatprm(2)
23941         wdip=wdip/wh2o
23942         wquad1 =vcatprm(3)
23943         wquad1=wquad1/wh2o
23944         wquad2 = vcatprm(4)
23945         wquad2=wquad2/wh2o
23946         wquad2p = 1-wquad2
23947         wvan1 = vcatprm(5)
23948         wvan2 =vcatprm(6)
23949         opt = dx(1)**2+dx(2)**2
23950         rsecp = opt+dx(3)**2
23951         rs = sqrt(rsecp)
23952         rthrp = rsecp*rs
23953         rfourp = rthrp*rs
23954         rsixp = rfourp*rsecp
23955         reight=rsixp*rsecp
23956         Ir = 1.0d0/rs
23957         Irsecp = 1/rsecp
23958         Irthrp = Irsecp/rs
23959         Irfourp = Irthrp/rs
23960         Irsixp = 1/rsixp
23961         Ireight=1/reight
23962         Irtw=Irsixp*Irsixp
23963         Irthir=Irtw/rs
23964         Irfourt=Irthir/rs
23965         opt1 = (4*rs*dx(3)*wdip)
23966         opt2 = 6*rsecp*wquad1*opt
23967         opt3 = wquad1*wquad2p*Irsixp
23968         opt4 = (wvan1*wvan2**12)
23969         opt5 = opt4*12*Irfourt
23970         opt6 = 2*wvan1*wvan2**6
23971         opt7 = 6*opt6*Ireight
23972         opt8 = wdip/v1m
23973         opt10 = wdip/v2m
23974         opt11 = (rsecp*v2m)**2
23975         opt12 = (rsecp*v1m)**2
23976         opt14 = (v1m*v2m*rsecp)**2
23977         opt15 = -wquad1/v2m**2
23978         opt16 = (rthrp*(v1m*v2m)**2)**2
23979         opt17 = (v1m**2*rthrp)**2
23980         opt18 = -wquad1/rthrp
23981         opt19 = (v1m**2*v2m**2)**2
23982         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23983         do k=1,3
23984           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23985                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23986          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23987                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23988           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23989                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23990                       *v1dpv2)/opt14
23991         enddo
23992         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23993         do k=1,3
23994           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23995                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23996                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23997           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23998                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23999                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24000           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24001                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24002                         v1dpv2**2)/opt19
24003         enddo
24004         Equad2=wquad1*wquad2p*Irthrp
24005         do k=1,3
24006           dEquad2Cat(k)=-3*dx(k)*rs*opt3
24007           dEquad2Cm(k)=3*dx(k)*rs*opt3
24008           dEquad2Calp(k)=0.0d0
24009         enddo
24010         Evan1=opt4*Irtw
24011         do k=1,3
24012           dEvan1Cat(k)=-dx(k)*opt5
24013           dEvan1Cm(k)=dx(k)*opt5
24014           dEvan1Calp(k)=0.0d0
24015         enddo
24016         Evan2=-opt6*Irsixp
24017         do k=1,3
24018           dEvan2Cat(k)=dx(k)*opt7
24019           dEvan2Cm(k)=-dx(k)*opt7
24020           dEvan2Calp(k)=0.0d0
24021         enddo
24022          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24023         do k=1,3
24024           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24025                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24026           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24027                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24028           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24029                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24030         enddo
24031             dscmag = 0.0d0
24032             do k=1,3
24033               dscvec(k) = c(k,i+nres)-c(k,i)
24034 ! TU SPRAWDZ???
24035 !              dscvec(1) = xj
24036 !              dscvec(2) = yj
24037 !              dscvec(3) = zj
24038
24039               dscmag = dscmag+dscvec(k)*dscvec(k)
24040             enddo
24041             dscmag3 = dscmag
24042             dscmag = sqrt(dscmag)
24043             dscmag3 = dscmag3*dscmag
24044             constA = 1+dASGL/dscmag
24045             constB = 0.0d0
24046             do k=1,3
24047               constB = constB+dscvec(k)*dEtotalCm(k)
24048             enddo
24049             constB = constB*dASGL/dscmag3
24050             do k=1,3
24051               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24052               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24053                constA*dEtotalCm(k)-constB*dscvec(k)
24054               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24055               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24056              enddo
24057            else
24058             rcal = 0.0d0
24059             do k=1,3
24060 !              r(k) = c(k,j)-c(k,i+nres)
24061               r(1) = xj
24062               r(2) = yj
24063               r(3) = zj
24064               rcal = rcal+r(k)*r(k)
24065             enddo
24066             ract=sqrt(rcal)
24067             rocal=1.5
24068             epscalc=0.2
24069             r0p=0.5*(rocal+sig0(itype(i,1)))
24070             r06 = r0p**6
24071             r012 = r06*r06
24072             Evan1=epscalc*(r012/rcal**6)
24073             Evan2=epscalc*2*(r06/rcal**3)
24074             r4 = rcal**4
24075             r7 = rcal**7
24076             do k=1,3
24077               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24078               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24079             enddo
24080             do k=1,3
24081               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24082             enddo
24083                  ecation_prot = ecation_prot+ Evan1+Evan2
24084             do  k=1,3
24085                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24086                dEtotalCm(k)
24087               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24088               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24089              enddo
24090          endif ! 13-16 residues
24091        enddo !j
24092        enddo !i
24093        return
24094        end subroutine ecat_prot
24095
24096 !----------------------------------------------------------------------------
24097 !-----------------------------------------------------------------------------
24098 !-----------------------------------------------------------------------------
24099       subroutine eprot_sc_base(escbase)
24100       use calc_data
24101 !      implicit real*8 (a-h,o-z)
24102 !      include 'DIMENSIONS'
24103 !      include 'COMMON.GEO'
24104 !      include 'COMMON.VAR'
24105 !      include 'COMMON.LOCAL'
24106 !      include 'COMMON.CHAIN'
24107 !      include 'COMMON.DERIV'
24108 !      include 'COMMON.NAMES'
24109 !      include 'COMMON.INTERACT'
24110 !      include 'COMMON.IOUNITS'
24111 !      include 'COMMON.CALC'
24112 !      include 'COMMON.CONTROL'
24113 !      include 'COMMON.SBRIDGE'
24114       logical :: lprn
24115 !el local variables
24116       integer :: iint,itypi,itypi1,itypj,subchap
24117       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24118       real(kind=8) :: evdw,sig0ij
24119       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24120                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24121                     sslipi,sslipj,faclip
24122       integer :: ii
24123       real(kind=8) :: fracinbuf
24124        real (kind=8) :: escbase
24125        real (kind=8),dimension(4):: ener
24126        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24127        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24128         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24129         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24130         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24131         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24132         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24133         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24134        real(kind=8),dimension(3,2)::chead,erhead_tail
24135        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24136        integer troll
24137        eps_out=80.0d0
24138        escbase=0.0d0
24139 !       do i=1,nres_molec(1)
24140         do i=ibond_start,ibond_end
24141         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24142         itypi  = itype(i,1)
24143         dxi    = dc_norm(1,nres+i)
24144         dyi    = dc_norm(2,nres+i)
24145         dzi    = dc_norm(3,nres+i)
24146         dsci_inv = vbld_inv(i+nres)
24147         xi=c(1,nres+i)
24148         yi=c(2,nres+i)
24149         zi=c(3,nres+i)
24150         xi=mod(xi,boxxsize)
24151          if (xi.lt.0) xi=xi+boxxsize
24152         yi=mod(yi,boxysize)
24153          if (yi.lt.0) yi=yi+boxysize
24154         zi=mod(zi,boxzsize)
24155          if (zi.lt.0) zi=zi+boxzsize
24156          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24157            itypj= itype(j,2)
24158            if (itype(j,2).eq.ntyp1_molec(2))cycle
24159            xj=c(1,j+nres)
24160            yj=c(2,j+nres)
24161            zj=c(3,j+nres)
24162            xj=dmod(xj,boxxsize)
24163            if (xj.lt.0) xj=xj+boxxsize
24164            yj=dmod(yj,boxysize)
24165            if (yj.lt.0) yj=yj+boxysize
24166            zj=dmod(zj,boxzsize)
24167            if (zj.lt.0) zj=zj+boxzsize
24168           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24169           xj_safe=xj
24170           yj_safe=yj
24171           zj_safe=zj
24172           subchap=0
24173
24174           do xshift=-1,1
24175           do yshift=-1,1
24176           do zshift=-1,1
24177           xj=xj_safe+xshift*boxxsize
24178           yj=yj_safe+yshift*boxysize
24179           zj=zj_safe+zshift*boxzsize
24180           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24181           if(dist_temp.lt.dist_init) then
24182             dist_init=dist_temp
24183             xj_temp=xj
24184             yj_temp=yj
24185             zj_temp=zj
24186             subchap=1
24187           endif
24188           enddo
24189           enddo
24190           enddo
24191           if (subchap.eq.1) then
24192           xj=xj_temp-xi
24193           yj=yj_temp-yi
24194           zj=zj_temp-zi
24195           else
24196           xj=xj_safe-xi
24197           yj=yj_safe-yi
24198           zj=zj_safe-zi
24199           endif
24200           dxj = dc_norm( 1, nres+j )
24201           dyj = dc_norm( 2, nres+j )
24202           dzj = dc_norm( 3, nres+j )
24203 !          print *,i,j,itypi,itypj
24204           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
24205           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
24206 !          d1i=0.0d0
24207 !          d1j=0.0d0
24208 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24209 ! Gay-berne var's
24210           sig0ij = sigma_scbase( itypi,itypj )
24211           chi1   = chi_scbase( itypi, itypj,1 )
24212           chi2   = chi_scbase( itypi, itypj,2 )
24213 !          chi1=0.0d0
24214 !          chi2=0.0d0
24215           chi12  = chi1 * chi2
24216           chip1  = chipp_scbase( itypi, itypj,1 )
24217           chip2  = chipp_scbase( itypi, itypj,2 )
24218 !          chip1=0.0d0
24219 !          chip2=0.0d0
24220           chip12 = chip1 * chip2
24221 ! not used by momo potential, but needed by sc_angular which is shared
24222 ! by all energy_potential subroutines
24223           alf1   = 0.0d0
24224           alf2   = 0.0d0
24225           alf12  = 0.0d0
24226           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
24227 !       a12sq = a12sq * a12sq
24228 ! charge of amino acid itypi is...
24229           chis1 = chis_scbase(itypi,itypj,1)
24230           chis2 = chis_scbase(itypi,itypj,2)
24231           chis12 = chis1 * chis2
24232           sig1 = sigmap1_scbase(itypi,itypj)
24233           sig2 = sigmap2_scbase(itypi,itypj)
24234 !       write (*,*) "sig1 = ", sig1
24235 !       write (*,*) "sig2 = ", sig2
24236 ! alpha factors from Fcav/Gcav
24237           b1 = alphasur_scbase(1,itypi,itypj)
24238 !          b1=0.0d0
24239           b2 = alphasur_scbase(2,itypi,itypj)
24240           b3 = alphasur_scbase(3,itypi,itypj)
24241           b4 = alphasur_scbase(4,itypi,itypj)
24242 ! used to determine whether we want to do quadrupole calculations
24243 ! used by Fgb
24244        eps_in = epsintab_scbase(itypi,itypj)
24245        if (eps_in.eq.0.0) eps_in=1.0
24246        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24247 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24248 !-------------------------------------------------------------------
24249 ! tail location and distance calculations
24250        DO k = 1,3
24251 ! location of polar head is computed by taking hydrophobic centre
24252 ! and moving by a d1 * dc_norm vector
24253 ! see unres publications for very informative images
24254         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24255         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
24256 ! distance
24257 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24258 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24259         Rhead_distance(k) = chead(k,2) - chead(k,1)
24260        END DO
24261 ! pitagoras (root of sum of squares)
24262        Rhead = dsqrt( &
24263           (Rhead_distance(1)*Rhead_distance(1)) &
24264         + (Rhead_distance(2)*Rhead_distance(2)) &
24265         + (Rhead_distance(3)*Rhead_distance(3)))
24266 !-------------------------------------------------------------------
24267 ! zero everything that should be zero'ed
24268        evdwij = 0.0d0
24269        ECL = 0.0d0
24270        Elj = 0.0d0
24271        Equad = 0.0d0
24272        Epol = 0.0d0
24273        Fcav=0.0d0
24274        eheadtail = 0.0d0
24275        dGCLdOM1 = 0.0d0
24276        dGCLdOM2 = 0.0d0
24277        dGCLdOM12 = 0.0d0
24278        dPOLdOM1 = 0.0d0
24279        dPOLdOM2 = 0.0d0
24280           Fcav = 0.0d0
24281           dFdR = 0.0d0
24282           dCAVdOM1  = 0.0d0
24283           dCAVdOM2  = 0.0d0
24284           dCAVdOM12 = 0.0d0
24285           dscj_inv = vbld_inv(j+nres)
24286 !          print *,i,j,dscj_inv,dsci_inv
24287 ! rij holds 1/(distance of Calpha atoms)
24288           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24289           rij  = dsqrt(rrij)
24290 !----------------------------
24291           CALL sc_angular
24292 ! this should be in elgrad_init but om's are calculated by sc_angular
24293 ! which in turn is used by older potentials
24294 ! om = omega, sqom = om^2
24295           sqom1  = om1 * om1
24296           sqom2  = om2 * om2
24297           sqom12 = om12 * om12
24298
24299 ! now we calculate EGB - Gey-Berne
24300 ! It will be summed up in evdwij and saved in evdw
24301           sigsq     = 1.0D0  / sigsq
24302           sig       = sig0ij * dsqrt(sigsq)
24303 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24304           rij_shift = 1.0/rij - sig + sig0ij
24305           IF (rij_shift.le.0.0D0) THEN
24306            evdw = 1.0D20
24307            RETURN
24308           END IF
24309           sigder = -sig * sigsq
24310           rij_shift = 1.0D0 / rij_shift
24311           fac       = rij_shift**expon
24312           c1        = fac  * fac * aa_scbase(itypi,itypj)
24313 !          c1        = 0.0d0
24314           c2        = fac  * bb_scbase(itypi,itypj)
24315 !          c2        = 0.0d0
24316           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24317           eps2der   = eps3rt * evdwij
24318           eps3der   = eps2rt * evdwij
24319 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24320           evdwij    = eps2rt * eps3rt * evdwij
24321           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24322           fac    = -expon * (c1 + evdwij) * rij_shift
24323           sigder = fac * sigder
24324 !          fac    = rij * fac
24325 ! Calculate distance derivative
24326           gg(1) =  fac
24327           gg(2) =  fac
24328           gg(3) =  fac
24329 !          if (b2.gt.0.0) then
24330           fac = chis1 * sqom1 + chis2 * sqom2 &
24331           - 2.0d0 * chis12 * om1 * om2 * om12
24332 ! we will use pom later in Gcav, so dont mess with it!
24333           pom = 1.0d0 - chis1 * chis2 * sqom12
24334           Lambf = (1.0d0 - (fac / pom))
24335           Lambf = dsqrt(Lambf)
24336           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24337 !       write (*,*) "sparrow = ", sparrow
24338           Chif = 1.0d0/rij * sparrow
24339           ChiLambf = Chif * Lambf
24340           eagle = dsqrt(ChiLambf)
24341           bat = ChiLambf ** 11.0d0
24342           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24343           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24344           botsq = bot * bot
24345           Fcav = top / bot
24346 !          print *,i,j,Fcav
24347           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24348           dbot = 12.0d0 * b4 * bat * Lambf
24349           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24350 !       dFdR = 0.0d0
24351 !      write (*,*) "dFcav/dR = ", dFdR
24352           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24353           dbot = 12.0d0 * b4 * bat * Chif
24354           eagle = Lambf * pom
24355           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24356           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24357           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24358               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24359
24360           dFdL = ((dtop * bot - top * dbot) / botsq)
24361 !       dFdL = 0.0d0
24362           dCAVdOM1  = dFdL * ( dFdOM1 )
24363           dCAVdOM2  = dFdL * ( dFdOM2 )
24364           dCAVdOM12 = dFdL * ( dFdOM12 )
24365
24366           ertail(1) = xj*rij
24367           ertail(2) = yj*rij
24368           ertail(3) = zj*rij
24369 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24370 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24371 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24372 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24373 !           print *,"EOMY",eom1,eom2,eom12
24374 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24375 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24376 ! here dtail=0.0
24377 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24378 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24379        DO k = 1, 3
24380 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24381 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24382         pom = ertail(k)
24383 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24384         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24385                   - (( dFdR + gg(k) ) * pom)
24386 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24387 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24388 !     &             - ( dFdR * pom )
24389         pom = ertail(k)
24390 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24391         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24392                   + (( dFdR + gg(k) ) * pom)
24393 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24394 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24395 !c!     &             + ( dFdR * pom )
24396
24397         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24398                   - (( dFdR + gg(k) ) * ertail(k))
24399 !c!     &             - ( dFdR * ertail(k))
24400
24401         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24402                   + (( dFdR + gg(k) ) * ertail(k))
24403 !c!     &             + ( dFdR * ertail(k))
24404
24405         gg(k) = 0.0d0
24406 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24407 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24408       END DO
24409
24410 !          else
24411
24412 !          endif
24413 !Now dipole-dipole
24414          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24415        w1 = wdipdip_scbase(1,itypi,itypj)
24416        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24417        w3 = wdipdip_scbase(2,itypi,itypj)
24418 !c!-------------------------------------------------------------------
24419 !c! ECL
24420        fac = (om12 - 3.0d0 * om1 * om2)
24421        c1 = (w1 / (Rhead**3.0d0)) * fac
24422        c2 = (w2 / Rhead ** 6.0d0)  &
24423          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24424        c3= (w3/ Rhead ** 6.0d0)  &
24425          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24426        ECL = c1 - c2 + c3
24427 !c!       write (*,*) "w1 = ", w1
24428 !c!       write (*,*) "w2 = ", w2
24429 !c!       write (*,*) "om1 = ", om1
24430 !c!       write (*,*) "om2 = ", om2
24431 !c!       write (*,*) "om12 = ", om12
24432 !c!       write (*,*) "fac = ", fac
24433 !c!       write (*,*) "c1 = ", c1
24434 !c!       write (*,*) "c2 = ", c2
24435 !c!       write (*,*) "Ecl = ", Ecl
24436 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24437 !c!       write (*,*) "c2_2 = ",
24438 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24439 !c!-------------------------------------------------------------------
24440 !c! dervative of ECL is GCL...
24441 !c! dECL/dr
24442        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24443        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24444          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24445        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24446          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24447        dGCLdR = c1 - c2 + c3
24448 !c! dECL/dom1
24449        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24450        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24451          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24452        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24453        dGCLdOM1 = c1 - c2 + c3
24454 !c! dECL/dom2
24455        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24456        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24457          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24458        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24459        dGCLdOM2 = c1 - c2 + c3
24460 !c! dECL/dom12
24461        c1 = w1 / (Rhead ** 3.0d0)
24462        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24463        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24464        dGCLdOM12 = c1 - c2 + c3
24465        DO k= 1, 3
24466         erhead(k) = Rhead_distance(k)/Rhead
24467        END DO
24468        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24469        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24470        facd1 = d1i * vbld_inv(i+nres)
24471        facd2 = d1j * vbld_inv(j+nres)
24472        DO k = 1, 3
24473
24474         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24475         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24476                   - dGCLdR * pom
24477         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24478         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24479                   + dGCLdR * pom
24480
24481         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24482                   - dGCLdR * erhead(k)
24483         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24484                   + dGCLdR * erhead(k)
24485        END DO
24486        endif
24487 !now charge with dipole eg. ARG-dG
24488        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24489       alphapol1 = alphapol_scbase(itypi,itypj)
24490        w1        = wqdip_scbase(1,itypi,itypj)
24491        w2        = wqdip_scbase(2,itypi,itypj)
24492 !       w1=0.0d0
24493 !       w2=0.0d0
24494 !       pis       = sig0head_scbase(itypi,itypj)
24495 !       eps_head   = epshead_scbase(itypi,itypj)
24496 !c!-------------------------------------------------------------------
24497 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24498        R1 = 0.0d0
24499        DO k = 1, 3
24500 !c! Calculate head-to-tail distances tail is center of side-chain
24501         R1=R1+(c(k,j+nres)-chead(k,1))**2
24502        END DO
24503 !c! Pitagoras
24504        R1 = dsqrt(R1)
24505
24506 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24507 !c!     &        +dhead(1,1,itypi,itypj))**2))
24508 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24509 !c!     &        +dhead(2,1,itypi,itypj))**2))
24510
24511 !c!-------------------------------------------------------------------
24512 !c! ecl
24513        sparrow  = w1  *  om1
24514        hawk     = w2 *  (1.0d0 - sqom2)
24515        Ecl = sparrow / Rhead**2.0d0 &
24516            - hawk    / Rhead**4.0d0
24517 !c!-------------------------------------------------------------------
24518 !c! derivative of ecl is Gcl
24519 !c! dF/dr part
24520        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24521                 + 4.0d0 * hawk    / Rhead**5.0d0
24522 !c! dF/dom1
24523        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24524 !c! dF/dom2
24525        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24526 !c--------------------------------------------------------------------
24527 !c Polarization energy
24528 !c Epol
24529        MomoFac1 = (1.0d0 - chi1 * sqom2)
24530        RR1  = R1 * R1 / MomoFac1
24531        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24532        fgb1 = sqrt( RR1 + a12sq * ee1)
24533 !       eps_inout_fac=0.0d0
24534        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24535 ! derivative of Epol is Gpol...
24536        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24537                 / (fgb1 ** 5.0d0)
24538        dFGBdR1 = ( (R1 / MomoFac1) &
24539              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24540              / ( 2.0d0 * fgb1 )
24541        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24542                * (2.0d0 - 0.5d0 * ee1) ) &
24543                / (2.0d0 * fgb1)
24544        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24545 !       dPOLdR1 = 0.0d0
24546        dPOLdOM1 = 0.0d0
24547        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24548        DO k = 1, 3
24549         erhead(k) = Rhead_distance(k)/Rhead
24550         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24551        END DO
24552
24553        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24554        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24555        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24556 !       bat=0.0d0
24557        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24558        facd1 = d1i * vbld_inv(i+nres)
24559        facd2 = d1j * vbld_inv(j+nres)
24560 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24561
24562        DO k = 1, 3
24563         hawk = (erhead_tail(k,1) + &
24564         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24565 !        facd1=0.0d0
24566 !        facd2=0.0d0
24567         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24568         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24569                    - dGCLdR * pom &
24570                    - dPOLdR1 *  (erhead_tail(k,1))
24571 !     &             - dGLJdR * pom
24572
24573         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24574         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24575                    + dGCLdR * pom  &
24576                    + dPOLdR1 * (erhead_tail(k,1))
24577 !     &             + dGLJdR * pom
24578
24579
24580         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24581                   - dGCLdR * erhead(k) &
24582                   - dPOLdR1 * erhead_tail(k,1)
24583 !     &             - dGLJdR * erhead(k)
24584
24585         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24586                   + dGCLdR * erhead(k)  &
24587                   + dPOLdR1 * erhead_tail(k,1)
24588 !     &             + dGLJdR * erhead(k)
24589
24590        END DO
24591        endif
24592 !       print *,i,j,evdwij,epol,Fcav,ECL
24593        escbase=escbase+evdwij+epol+Fcav+ECL
24594        call sc_grad_scbase
24595          enddo
24596       enddo
24597
24598       return
24599       end subroutine eprot_sc_base
24600       SUBROUTINE sc_grad_scbase
24601       use calc_data
24602
24603        real (kind=8) :: dcosom1(3),dcosom2(3)
24604        eom1  =    &
24605               eps2der * eps2rt_om1   &
24606             - 2.0D0 * alf1 * eps3der &
24607             + sigder * sigsq_om1     &
24608             + dCAVdOM1               &
24609             + dGCLdOM1               &
24610             + dPOLdOM1
24611
24612        eom2  =  &
24613               eps2der * eps2rt_om2   &
24614             + 2.0D0 * alf2 * eps3der &
24615             + sigder * sigsq_om2     &
24616             + dCAVdOM2               &
24617             + dGCLdOM2               &
24618             + dPOLdOM2
24619
24620        eom12 =    &
24621               evdwij  * eps1_om12     &
24622             + eps2der * eps2rt_om12   &
24623             - 2.0D0 * alf12 * eps3der &
24624             + sigder *sigsq_om12      &
24625             + dCAVdOM12               &
24626             + dGCLdOM12
24627
24628 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24629 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24630 !               gg(1),gg(2),"rozne"
24631        DO k = 1, 3
24632         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24633         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24634         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24635         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24636                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24637                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24638         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24639                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24640                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24641         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24642         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24643        END DO
24644        RETURN
24645       END SUBROUTINE sc_grad_scbase
24646
24647
24648       subroutine epep_sc_base(epepbase)
24649       use calc_data
24650       logical :: lprn
24651 !el local variables
24652       integer :: iint,itypi,itypi1,itypj,subchap
24653       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24654       real(kind=8) :: evdw,sig0ij
24655       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24656                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24657                     sslipi,sslipj,faclip
24658       integer :: ii
24659       real(kind=8) :: fracinbuf
24660        real (kind=8) :: epepbase
24661        real (kind=8),dimension(4):: ener
24662        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24663        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24664         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24665         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24666         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24667         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24668         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24669         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24670        real(kind=8),dimension(3,2)::chead,erhead_tail
24671        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24672        integer troll
24673        eps_out=80.0d0
24674        epepbase=0.0d0
24675 !       do i=1,nres_molec(1)-1
24676         do i=ibond_start,ibond_end
24677         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24678 !C        itypi  = itype(i,1)
24679         dxi    = dc_norm(1,i)
24680         dyi    = dc_norm(2,i)
24681         dzi    = dc_norm(3,i)
24682 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24683         dsci_inv = vbld_inv(i+1)/2.0
24684         xi=(c(1,i)+c(1,i+1))/2.0
24685         yi=(c(2,i)+c(2,i+1))/2.0
24686         zi=(c(3,i)+c(3,i+1))/2.0
24687         xi=mod(xi,boxxsize)
24688          if (xi.lt.0) xi=xi+boxxsize
24689         yi=mod(yi,boxysize)
24690          if (yi.lt.0) yi=yi+boxysize
24691         zi=mod(zi,boxzsize)
24692          if (zi.lt.0) zi=zi+boxzsize
24693          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24694            itypj= itype(j,2)
24695            if (itype(j,2).eq.ntyp1_molec(2))cycle
24696            xj=c(1,j+nres)
24697            yj=c(2,j+nres)
24698            zj=c(3,j+nres)
24699            xj=dmod(xj,boxxsize)
24700            if (xj.lt.0) xj=xj+boxxsize
24701            yj=dmod(yj,boxysize)
24702            if (yj.lt.0) yj=yj+boxysize
24703            zj=dmod(zj,boxzsize)
24704            if (zj.lt.0) zj=zj+boxzsize
24705           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24706           xj_safe=xj
24707           yj_safe=yj
24708           zj_safe=zj
24709           subchap=0
24710
24711           do xshift=-1,1
24712           do yshift=-1,1
24713           do zshift=-1,1
24714           xj=xj_safe+xshift*boxxsize
24715           yj=yj_safe+yshift*boxysize
24716           zj=zj_safe+zshift*boxzsize
24717           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24718           if(dist_temp.lt.dist_init) then
24719             dist_init=dist_temp
24720             xj_temp=xj
24721             yj_temp=yj
24722             zj_temp=zj
24723             subchap=1
24724           endif
24725           enddo
24726           enddo
24727           enddo
24728           if (subchap.eq.1) then
24729           xj=xj_temp-xi
24730           yj=yj_temp-yi
24731           zj=zj_temp-zi
24732           else
24733           xj=xj_safe-xi
24734           yj=yj_safe-yi
24735           zj=zj_safe-zi
24736           endif
24737           dxj = dc_norm( 1, nres+j )
24738           dyj = dc_norm( 2, nres+j )
24739           dzj = dc_norm( 3, nres+j )
24740 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24741 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24742
24743 ! Gay-berne var's
24744           sig0ij = sigma_pepbase(itypj )
24745           chi1   = chi_pepbase(itypj,1 )
24746           chi2   = chi_pepbase(itypj,2 )
24747 !          chi1=0.0d0
24748 !          chi2=0.0d0
24749           chi12  = chi1 * chi2
24750           chip1  = chipp_pepbase(itypj,1 )
24751           chip2  = chipp_pepbase(itypj,2 )
24752 !          chip1=0.0d0
24753 !          chip2=0.0d0
24754           chip12 = chip1 * chip2
24755           chis1 = chis_pepbase(itypj,1)
24756           chis2 = chis_pepbase(itypj,2)
24757           chis12 = chis1 * chis2
24758           sig1 = sigmap1_pepbase(itypj)
24759           sig2 = sigmap2_pepbase(itypj)
24760 !       write (*,*) "sig1 = ", sig1
24761 !       write (*,*) "sig2 = ", sig2
24762        DO k = 1,3
24763 ! location of polar head is computed by taking hydrophobic centre
24764 ! and moving by a d1 * dc_norm vector
24765 ! see unres publications for very informative images
24766         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24767 ! + d1i * dc_norm(k, i+nres)
24768         chead(k,2) = c(k, j+nres)
24769 ! + d1j * dc_norm(k, j+nres)
24770 ! distance
24771 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24772 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24773         Rhead_distance(k) = chead(k,2) - chead(k,1)
24774 !        print *,gvdwc_pepbase(k,i)
24775
24776        END DO
24777        Rhead = dsqrt( &
24778           (Rhead_distance(1)*Rhead_distance(1)) &
24779         + (Rhead_distance(2)*Rhead_distance(2)) &
24780         + (Rhead_distance(3)*Rhead_distance(3)))
24781
24782 ! alpha factors from Fcav/Gcav
24783           b1 = alphasur_pepbase(1,itypj)
24784 !          b1=0.0d0
24785           b2 = alphasur_pepbase(2,itypj)
24786           b3 = alphasur_pepbase(3,itypj)
24787           b4 = alphasur_pepbase(4,itypj)
24788           alf1   = 0.0d0
24789           alf2   = 0.0d0
24790           alf12  = 0.0d0
24791           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24792 !          print *,i,j,rrij
24793           rij  = dsqrt(rrij)
24794 !----------------------------
24795        evdwij = 0.0d0
24796        ECL = 0.0d0
24797        Elj = 0.0d0
24798        Equad = 0.0d0
24799        Epol = 0.0d0
24800        Fcav=0.0d0
24801        eheadtail = 0.0d0
24802        dGCLdOM1 = 0.0d0
24803        dGCLdOM2 = 0.0d0
24804        dGCLdOM12 = 0.0d0
24805        dPOLdOM1 = 0.0d0
24806        dPOLdOM2 = 0.0d0
24807           Fcav = 0.0d0
24808           dFdR = 0.0d0
24809           dCAVdOM1  = 0.0d0
24810           dCAVdOM2  = 0.0d0
24811           dCAVdOM12 = 0.0d0
24812           dscj_inv = vbld_inv(j+nres)
24813           CALL sc_angular
24814 ! this should be in elgrad_init but om's are calculated by sc_angular
24815 ! which in turn is used by older potentials
24816 ! om = omega, sqom = om^2
24817           sqom1  = om1 * om1
24818           sqom2  = om2 * om2
24819           sqom12 = om12 * om12
24820
24821 ! now we calculate EGB - Gey-Berne
24822 ! It will be summed up in evdwij and saved in evdw
24823           sigsq     = 1.0D0  / sigsq
24824           sig       = sig0ij * dsqrt(sigsq)
24825           rij_shift = 1.0/rij - sig + sig0ij
24826           IF (rij_shift.le.0.0D0) THEN
24827            evdw = 1.0D20
24828            RETURN
24829           END IF
24830           sigder = -sig * sigsq
24831           rij_shift = 1.0D0 / rij_shift
24832           fac       = rij_shift**expon
24833           c1        = fac  * fac * aa_pepbase(itypj)
24834 !          c1        = 0.0d0
24835           c2        = fac  * bb_pepbase(itypj)
24836 !          c2        = 0.0d0
24837           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24838           eps2der   = eps3rt * evdwij
24839           eps3der   = eps2rt * evdwij
24840 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24841           evdwij    = eps2rt * eps3rt * evdwij
24842           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24843           fac    = -expon * (c1 + evdwij) * rij_shift
24844           sigder = fac * sigder
24845 !          fac    = rij * fac
24846 ! Calculate distance derivative
24847           gg(1) =  fac
24848           gg(2) =  fac
24849           gg(3) =  fac
24850           fac = chis1 * sqom1 + chis2 * sqom2 &
24851           - 2.0d0 * chis12 * om1 * om2 * om12
24852 ! we will use pom later in Gcav, so dont mess with it!
24853           pom = 1.0d0 - chis1 * chis2 * sqom12
24854           Lambf = (1.0d0 - (fac / pom))
24855           Lambf = dsqrt(Lambf)
24856           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24857 !       write (*,*) "sparrow = ", sparrow
24858           Chif = 1.0d0/rij * sparrow
24859           ChiLambf = Chif * Lambf
24860           eagle = dsqrt(ChiLambf)
24861           bat = ChiLambf ** 11.0d0
24862           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24863           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24864           botsq = bot * bot
24865           Fcav = top / bot
24866 !          print *,i,j,Fcav
24867           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24868           dbot = 12.0d0 * b4 * bat * Lambf
24869           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24870 !       dFdR = 0.0d0
24871 !      write (*,*) "dFcav/dR = ", dFdR
24872           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24873           dbot = 12.0d0 * b4 * bat * Chif
24874           eagle = Lambf * pom
24875           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24876           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24877           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24878               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24879
24880           dFdL = ((dtop * bot - top * dbot) / botsq)
24881 !       dFdL = 0.0d0
24882           dCAVdOM1  = dFdL * ( dFdOM1 )
24883           dCAVdOM2  = dFdL * ( dFdOM2 )
24884           dCAVdOM12 = dFdL * ( dFdOM12 )
24885
24886           ertail(1) = xj*rij
24887           ertail(2) = yj*rij
24888           ertail(3) = zj*rij
24889        DO k = 1, 3
24890 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24891 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24892         pom = ertail(k)
24893 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24894         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24895                   - (( dFdR + gg(k) ) * pom)/2.0
24896 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24897 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24898 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24899 !     &             - ( dFdR * pom )
24900         pom = ertail(k)
24901 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24902         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24903                   + (( dFdR + gg(k) ) * pom)
24904 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24905 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24906 !c!     &             + ( dFdR * pom )
24907
24908         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24909                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24910 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24911
24912 !c!     &             - ( dFdR * ertail(k))
24913
24914         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24915                   + (( dFdR + gg(k) ) * ertail(k))
24916 !c!     &             + ( dFdR * ertail(k))
24917
24918         gg(k) = 0.0d0
24919 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24920 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24921       END DO
24922
24923
24924        w1 = wdipdip_pepbase(1,itypj)
24925        w2 = -wdipdip_pepbase(3,itypj)/2.0
24926        w3 = wdipdip_pepbase(2,itypj)
24927 !       w1=0.0d0
24928 !       w2=0.0d0
24929 !c!-------------------------------------------------------------------
24930 !c! ECL
24931 !       w3=0.0d0
24932        fac = (om12 - 3.0d0 * om1 * om2)
24933        c1 = (w1 / (Rhead**3.0d0)) * fac
24934        c2 = (w2 / Rhead ** 6.0d0)  &
24935          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24936        c3= (w3/ Rhead ** 6.0d0)  &
24937          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24938
24939        ECL = c1 - c2 + c3
24940
24941        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24942        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24943          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24944        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24945          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24946
24947        dGCLdR = c1 - c2 + c3
24948 !c! dECL/dom1
24949        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24950        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24951          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24952        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24953        dGCLdOM1 = c1 - c2 + c3
24954 !c! dECL/dom2
24955        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24956        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24957          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24958        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24959
24960        dGCLdOM2 = c1 - c2 + c3
24961 !c! dECL/dom12
24962        c1 = w1 / (Rhead ** 3.0d0)
24963        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24964        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24965        dGCLdOM12 = c1 - c2 + c3
24966        DO k= 1, 3
24967         erhead(k) = Rhead_distance(k)/Rhead
24968        END DO
24969        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24970        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24971 !       facd1 = d1 * vbld_inv(i+nres)
24972 !       facd2 = d2 * vbld_inv(j+nres)
24973        DO k = 1, 3
24974
24975 !        pom = erhead(k)
24976 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24977 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24978 !                  - dGCLdR * pom
24979         pom = erhead(k)
24980 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24981         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24982                   + dGCLdR * pom
24983
24984         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24985                   - dGCLdR * erhead(k)/2.0d0
24986 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24987         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24988                   - dGCLdR * erhead(k)/2.0d0
24989 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24990         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24991                   + dGCLdR * erhead(k)
24992        END DO
24993 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24994        epepbase=epepbase+evdwij+Fcav+ECL
24995        call sc_grad_pepbase
24996        enddo
24997        enddo
24998       END SUBROUTINE epep_sc_base
24999       SUBROUTINE sc_grad_pepbase
25000       use calc_data
25001
25002        real (kind=8) :: dcosom1(3),dcosom2(3)
25003        eom1  =    &
25004               eps2der * eps2rt_om1   &
25005             - 2.0D0 * alf1 * eps3der &
25006             + sigder * sigsq_om1     &
25007             + dCAVdOM1               &
25008             + dGCLdOM1               &
25009             + dPOLdOM1
25010
25011        eom2  =  &
25012               eps2der * eps2rt_om2   &
25013             + 2.0D0 * alf2 * eps3der &
25014             + sigder * sigsq_om2     &
25015             + dCAVdOM2               &
25016             + dGCLdOM2               &
25017             + dPOLdOM2
25018
25019        eom12 =    &
25020               evdwij  * eps1_om12     &
25021             + eps2der * eps2rt_om12   &
25022             - 2.0D0 * alf12 * eps3der &
25023             + sigder *sigsq_om12      &
25024             + dCAVdOM12               &
25025             + dGCLdOM12
25026 !        om12=0.0
25027 !        eom12=0.0
25028 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25029 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25030 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25031 !                 *dsci_inv*2.0
25032 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25033 !               gg(1),gg(2),"rozne"
25034        DO k = 1, 3
25035         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25036         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25037         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25038         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25039                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25040                  *dsci_inv*2.0 &
25041                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25042         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25043                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25044                  *dsci_inv*2.0 &
25045                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25046 !         print *,eom12,eom2,om12,om2
25047 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25048 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25049         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25050                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25051                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25052         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25053        END DO
25054        RETURN
25055       END SUBROUTINE sc_grad_pepbase
25056       subroutine eprot_sc_phosphate(escpho)
25057       use calc_data
25058 !      implicit real*8 (a-h,o-z)
25059 !      include 'DIMENSIONS'
25060 !      include 'COMMON.GEO'
25061 !      include 'COMMON.VAR'
25062 !      include 'COMMON.LOCAL'
25063 !      include 'COMMON.CHAIN'
25064 !      include 'COMMON.DERIV'
25065 !      include 'COMMON.NAMES'
25066 !      include 'COMMON.INTERACT'
25067 !      include 'COMMON.IOUNITS'
25068 !      include 'COMMON.CALC'
25069 !      include 'COMMON.CONTROL'
25070 !      include 'COMMON.SBRIDGE'
25071       logical :: lprn
25072 !el local variables
25073       integer :: iint,itypi,itypi1,itypj,subchap
25074       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25075       real(kind=8) :: evdw,sig0ij
25076       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25077                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25078                     sslipi,sslipj,faclip,alpha_sco
25079       integer :: ii
25080       real(kind=8) :: fracinbuf
25081        real (kind=8) :: escpho
25082        real (kind=8),dimension(4):: ener
25083        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25084        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25085         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25086         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25087         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25088         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25089         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25090         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25091        real(kind=8),dimension(3,2)::chead,erhead_tail
25092        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25093        integer troll
25094        eps_out=80.0d0
25095        escpho=0.0d0
25096 !       do i=1,nres_molec(1)
25097         do i=ibond_start,ibond_end
25098         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25099         itypi  = itype(i,1)
25100         dxi    = dc_norm(1,nres+i)
25101         dyi    = dc_norm(2,nres+i)
25102         dzi    = dc_norm(3,nres+i)
25103         dsci_inv = vbld_inv(i+nres)
25104         xi=c(1,nres+i)
25105         yi=c(2,nres+i)
25106         zi=c(3,nres+i)
25107         xi=mod(xi,boxxsize)
25108          if (xi.lt.0) xi=xi+boxxsize
25109         yi=mod(yi,boxysize)
25110          if (yi.lt.0) yi=yi+boxysize
25111         zi=mod(zi,boxzsize)
25112          if (zi.lt.0) zi=zi+boxzsize
25113          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25114            itypj= itype(j,2)
25115            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25116             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25117            xj=(c(1,j)+c(1,j+1))/2.0
25118            yj=(c(2,j)+c(2,j+1))/2.0
25119            zj=(c(3,j)+c(3,j+1))/2.0
25120            xj=dmod(xj,boxxsize)
25121            if (xj.lt.0) xj=xj+boxxsize
25122            yj=dmod(yj,boxysize)
25123            if (yj.lt.0) yj=yj+boxysize
25124            zj=dmod(zj,boxzsize)
25125            if (zj.lt.0) zj=zj+boxzsize
25126           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25127           xj_safe=xj
25128           yj_safe=yj
25129           zj_safe=zj
25130           subchap=0
25131           do xshift=-1,1
25132           do yshift=-1,1
25133           do zshift=-1,1
25134           xj=xj_safe+xshift*boxxsize
25135           yj=yj_safe+yshift*boxysize
25136           zj=zj_safe+zshift*boxzsize
25137           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25138           if(dist_temp.lt.dist_init) then
25139             dist_init=dist_temp
25140             xj_temp=xj
25141             yj_temp=yj
25142             zj_temp=zj
25143             subchap=1
25144           endif
25145           enddo
25146           enddo
25147           enddo
25148           if (subchap.eq.1) then
25149           xj=xj_temp-xi
25150           yj=yj_temp-yi
25151           zj=zj_temp-zi
25152           else
25153           xj=xj_safe-xi
25154           yj=yj_safe-yi
25155           zj=zj_safe-zi
25156           endif
25157           dxj = dc_norm( 1,j )
25158           dyj = dc_norm( 2,j )
25159           dzj = dc_norm( 3,j )
25160           dscj_inv = vbld_inv(j+1)
25161
25162 ! Gay-berne var's
25163           sig0ij = sigma_scpho(itypi )
25164           chi1   = chi_scpho(itypi,1 )
25165           chi2   = chi_scpho(itypi,2 )
25166 !          chi1=0.0d0
25167 !          chi2=0.0d0
25168           chi12  = chi1 * chi2
25169           chip1  = chipp_scpho(itypi,1 )
25170           chip2  = chipp_scpho(itypi,2 )
25171 !          chip1=0.0d0
25172 !          chip2=0.0d0
25173           chip12 = chip1 * chip2
25174           chis1 = chis_scpho(itypi,1)
25175           chis2 = chis_scpho(itypi,2)
25176           chis12 = chis1 * chis2
25177           sig1 = sigmap1_scpho(itypi)
25178           sig2 = sigmap2_scpho(itypi)
25179 !       write (*,*) "sig1 = ", sig1
25180 !       write (*,*) "sig1 = ", sig1
25181 !       write (*,*) "sig2 = ", sig2
25182 ! alpha factors from Fcav/Gcav
25183           alf1   = 0.0d0
25184           alf2   = 0.0d0
25185           alf12  = 0.0d0
25186           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
25187
25188           b1 = alphasur_scpho(1,itypi)
25189 !          b1=0.0d0
25190           b2 = alphasur_scpho(2,itypi)
25191           b3 = alphasur_scpho(3,itypi)
25192           b4 = alphasur_scpho(4,itypi)
25193 ! used to determine whether we want to do quadrupole calculations
25194 ! used by Fgb
25195        eps_in = epsintab_scpho(itypi)
25196        if (eps_in.eq.0.0) eps_in=1.0
25197        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25198 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25199 !-------------------------------------------------------------------
25200 ! tail location and distance calculations
25201           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
25202           d1j = 0.0
25203        DO k = 1,3
25204 ! location of polar head is computed by taking hydrophobic centre
25205 ! and moving by a d1 * dc_norm vector
25206 ! see unres publications for very informative images
25207         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25208         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
25209 ! distance
25210 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25211 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25212         Rhead_distance(k) = chead(k,2) - chead(k,1)
25213        END DO
25214 ! pitagoras (root of sum of squares)
25215        Rhead = dsqrt( &
25216           (Rhead_distance(1)*Rhead_distance(1)) &
25217         + (Rhead_distance(2)*Rhead_distance(2)) &
25218         + (Rhead_distance(3)*Rhead_distance(3)))
25219        Rhead_sq=Rhead**2.0
25220 !-------------------------------------------------------------------
25221 ! zero everything that should be zero'ed
25222        evdwij = 0.0d0
25223        ECL = 0.0d0
25224        Elj = 0.0d0
25225        Equad = 0.0d0
25226        Epol = 0.0d0
25227        Fcav=0.0d0
25228        eheadtail = 0.0d0
25229        dGCLdR=0.0d0
25230        dGCLdOM1 = 0.0d0
25231        dGCLdOM2 = 0.0d0
25232        dGCLdOM12 = 0.0d0
25233        dPOLdOM1 = 0.0d0
25234        dPOLdOM2 = 0.0d0
25235           Fcav = 0.0d0
25236           dFdR = 0.0d0
25237           dCAVdOM1  = 0.0d0
25238           dCAVdOM2  = 0.0d0
25239           dCAVdOM12 = 0.0d0
25240           dscj_inv = vbld_inv(j+1)/2.0
25241 !dhead_scbasej(itypi,itypj)
25242 !          print *,i,j,dscj_inv,dsci_inv
25243 ! rij holds 1/(distance of Calpha atoms)
25244           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25245           rij  = dsqrt(rrij)
25246 !----------------------------
25247           CALL sc_angular
25248 ! this should be in elgrad_init but om's are calculated by sc_angular
25249 ! which in turn is used by older potentials
25250 ! om = omega, sqom = om^2
25251           sqom1  = om1 * om1
25252           sqom2  = om2 * om2
25253           sqom12 = om12 * om12
25254
25255 ! now we calculate EGB - Gey-Berne
25256 ! It will be summed up in evdwij and saved in evdw
25257           sigsq     = 1.0D0  / sigsq
25258           sig       = sig0ij * dsqrt(sigsq)
25259 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25260           rij_shift = 1.0/rij - sig + sig0ij
25261           IF (rij_shift.le.0.0D0) THEN
25262            evdw = 1.0D20
25263            RETURN
25264           END IF
25265           sigder = -sig * sigsq
25266           rij_shift = 1.0D0 / rij_shift
25267           fac       = rij_shift**expon
25268           c1        = fac  * fac * aa_scpho(itypi)
25269 !          c1        = 0.0d0
25270           c2        = fac  * bb_scpho(itypi)
25271 !          c2        = 0.0d0
25272           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25273           eps2der   = eps3rt * evdwij
25274           eps3der   = eps2rt * evdwij
25275 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25276           evdwij    = eps2rt * eps3rt * evdwij
25277           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25278           fac    = -expon * (c1 + evdwij) * rij_shift
25279           sigder = fac * sigder
25280 !          fac    = rij * fac
25281 ! Calculate distance derivative
25282           gg(1) =  fac
25283           gg(2) =  fac
25284           gg(3) =  fac
25285           fac = chis1 * sqom1 + chis2 * sqom2 &
25286           - 2.0d0 * chis12 * om1 * om2 * om12
25287 ! we will use pom later in Gcav, so dont mess with it!
25288           pom = 1.0d0 - chis1 * chis2 * sqom12
25289           Lambf = (1.0d0 - (fac / pom))
25290           Lambf = dsqrt(Lambf)
25291           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25292 !       write (*,*) "sparrow = ", sparrow
25293           Chif = 1.0d0/rij * sparrow
25294           ChiLambf = Chif * Lambf
25295           eagle = dsqrt(ChiLambf)
25296           bat = ChiLambf ** 11.0d0
25297           top = b1 * ( eagle + b2 * ChiLambf - b3 )
25298           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25299           botsq = bot * bot
25300           Fcav = top / bot
25301           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25302           dbot = 12.0d0 * b4 * bat * Lambf
25303           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25304 !       dFdR = 0.0d0
25305 !      write (*,*) "dFcav/dR = ", dFdR
25306           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25307           dbot = 12.0d0 * b4 * bat * Chif
25308           eagle = Lambf * pom
25309           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25310           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25311           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25312               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25313
25314           dFdL = ((dtop * bot - top * dbot) / botsq)
25315 !       dFdL = 0.0d0
25316           dCAVdOM1  = dFdL * ( dFdOM1 )
25317           dCAVdOM2  = dFdL * ( dFdOM2 )
25318           dCAVdOM12 = dFdL * ( dFdOM12 )
25319
25320           ertail(1) = xj*rij
25321           ertail(2) = yj*rij
25322           ertail(3) = zj*rij
25323        DO k = 1, 3
25324 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25325 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25326 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25327
25328         pom = ertail(k)
25329 !        print *,pom,gg(k),dFdR
25330 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25331         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25332                   - (( dFdR + gg(k) ) * pom)
25333 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25334 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25335 !     &             - ( dFdR * pom )
25336 !        pom = ertail(k)
25337 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25338 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25339 !                  + (( dFdR + gg(k) ) * pom)
25340 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25341 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25342 !c!     &             + ( dFdR * pom )
25343
25344         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25345                   - (( dFdR + gg(k) ) * ertail(k))
25346 !c!     &             - ( dFdR * ertail(k))
25347
25348         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25349                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25350
25351         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25352                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25353
25354 !c!     &             + ( dFdR * ertail(k))
25355
25356         gg(k) = 0.0d0
25357         ENDDO
25358 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25359 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25360 !      alphapol1 = alphapol_scpho(itypi)
25361        if (wqq_scpho(itypi).ne.0.0) then
25362        Qij=wqq_scpho(itypi)/eps_in
25363        alpha_sco=1.d0/alphi_scpho(itypi)
25364 !       Qij=0.0
25365        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25366 !c! derivative of Ecl is Gcl...
25367        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25368                 (Rhead*alpha_sco+1) ) / Rhead_sq
25369        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25370        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25371        w1        = wqdip_scpho(1,itypi)
25372        w2        = wqdip_scpho(2,itypi)
25373 !       w1=0.0d0
25374 !       w2=0.0d0
25375 !       pis       = sig0head_scbase(itypi,itypj)
25376 !       eps_head   = epshead_scbase(itypi,itypj)
25377 !c!-------------------------------------------------------------------
25378
25379 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25380 !c!     &        +dhead(1,1,itypi,itypj))**2))
25381 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25382 !c!     &        +dhead(2,1,itypi,itypj))**2))
25383
25384 !c!-------------------------------------------------------------------
25385 !c! ecl
25386        sparrow  = w1  *  om1
25387        hawk     = w2 *  (1.0d0 - sqom2)
25388        Ecl = sparrow / Rhead**2.0d0 &
25389            - hawk    / Rhead**4.0d0
25390 !c!-------------------------------------------------------------------
25391        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25392            1.0/rij,sparrow
25393
25394 !c! derivative of ecl is Gcl
25395 !c! dF/dr part
25396        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25397                 + 4.0d0 * hawk    / Rhead**5.0d0
25398 !c! dF/dom1
25399        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25400 !c! dF/dom2
25401        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25402        endif
25403
25404 !c--------------------------------------------------------------------
25405 !c Polarization energy
25406 !c Epol
25407        R1 = 0.0d0
25408        DO k = 1, 3
25409 !c! Calculate head-to-tail distances tail is center of side-chain
25410         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25411        END DO
25412 !c! Pitagoras
25413        R1 = dsqrt(R1)
25414
25415       alphapol1 = alphapol_scpho(itypi)
25416 !      alphapol1=0.0
25417        MomoFac1 = (1.0d0 - chi2 * sqom1)
25418        RR1  = R1 * R1 / MomoFac1
25419        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25420 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25421        fgb1 = sqrt( RR1 + a12sq * ee1)
25422 !       eps_inout_fac=0.0d0
25423        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25424 ! derivative of Epol is Gpol...
25425        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25426                 / (fgb1 ** 5.0d0)
25427        dFGBdR1 = ( (R1 / MomoFac1) &
25428              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25429              / ( 2.0d0 * fgb1 )
25430        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25431                * (2.0d0 - 0.5d0 * ee1) ) &
25432                / (2.0d0 * fgb1)
25433        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25434 !       dPOLdR1 = 0.0d0
25435 !       dPOLdOM1 = 0.0d0
25436        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25437                * (2.0d0 - 0.5d0 * ee1) ) &
25438                / (2.0d0 * fgb1)
25439
25440        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25441        dPOLdOM2 = 0.0
25442        DO k = 1, 3
25443         erhead(k) = Rhead_distance(k)/Rhead
25444         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25445        END DO
25446
25447        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25448        erdxj = scalar( erhead(1), dC_norm(1,j) )
25449        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25450 !       bat=0.0d0
25451        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25452        facd1 = d1i * vbld_inv(i+nres)
25453        facd2 = d1j * vbld_inv(j)
25454 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25455
25456        DO k = 1, 3
25457         hawk = (erhead_tail(k,1) + &
25458         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25459 !        facd1=0.0d0
25460 !        facd2=0.0d0
25461 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25462 !                pom,(erhead_tail(k,1))
25463
25464 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25465         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25466         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25467                    - dGCLdR * pom &
25468                    - dPOLdR1 *  (erhead_tail(k,1))
25469 !     &             - dGLJdR * pom
25470
25471         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25472 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25473 !                   + dGCLdR * pom  &
25474 !                   + dPOLdR1 * (erhead_tail(k,1))
25475 !     &             + dGLJdR * pom
25476
25477
25478         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25479                   - dGCLdR * erhead(k) &
25480                   - dPOLdR1 * erhead_tail(k,1)
25481 !     &             - dGLJdR * erhead(k)
25482
25483         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25484                   + (dGCLdR * erhead(k)  &
25485                   + dPOLdR1 * erhead_tail(k,1))/2.0
25486         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25487                   + (dGCLdR * erhead(k)  &
25488                   + dPOLdR1 * erhead_tail(k,1))/2.0
25489
25490 !     &             + dGLJdR * erhead(k)
25491 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25492
25493        END DO
25494 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25495        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25496         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25497        escpho=escpho+evdwij+epol+Fcav+ECL
25498        call sc_grad_scpho
25499          enddo
25500
25501       enddo
25502
25503       return
25504       end subroutine eprot_sc_phosphate
25505       SUBROUTINE sc_grad_scpho
25506       use calc_data
25507
25508        real (kind=8) :: dcosom1(3),dcosom2(3)
25509        eom1  =    &
25510               eps2der * eps2rt_om1   &
25511             - 2.0D0 * alf1 * eps3der &
25512             + sigder * sigsq_om1     &
25513             + dCAVdOM1               &
25514             + dGCLdOM1               &
25515             + dPOLdOM1
25516
25517        eom2  =  &
25518               eps2der * eps2rt_om2   &
25519             + 2.0D0 * alf2 * eps3der &
25520             + sigder * sigsq_om2     &
25521             + dCAVdOM2               &
25522             + dGCLdOM2               &
25523             + dPOLdOM2
25524
25525        eom12 =    &
25526               evdwij  * eps1_om12     &
25527             + eps2der * eps2rt_om12   &
25528             - 2.0D0 * alf12 * eps3der &
25529             + sigder *sigsq_om12      &
25530             + dCAVdOM12               &
25531             + dGCLdOM12
25532 !        om12=0.0
25533 !        eom12=0.0
25534 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25535 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25536 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25537 !                 *dsci_inv*2.0
25538 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25539 !               gg(1),gg(2),"rozne"
25540        DO k = 1, 3
25541         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25542         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25543         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25544         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25545                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25546                  *dscj_inv*2.0 &
25547                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25548         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25549                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25550                  *dscj_inv*2.0 &
25551                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25552         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25553                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25554                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25555
25556 !         print *,eom12,eom2,om12,om2
25557 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25558 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25559 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25560 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25561 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25562         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25563        END DO
25564        RETURN
25565       END SUBROUTINE sc_grad_scpho
25566       subroutine eprot_pep_phosphate(epeppho)
25567       use calc_data
25568 !      implicit real*8 (a-h,o-z)
25569 !      include 'DIMENSIONS'
25570 !      include 'COMMON.GEO'
25571 !      include 'COMMON.VAR'
25572 !      include 'COMMON.LOCAL'
25573 !      include 'COMMON.CHAIN'
25574 !      include 'COMMON.DERIV'
25575 !      include 'COMMON.NAMES'
25576 !      include 'COMMON.INTERACT'
25577 !      include 'COMMON.IOUNITS'
25578 !      include 'COMMON.CALC'
25579 !      include 'COMMON.CONTROL'
25580 !      include 'COMMON.SBRIDGE'
25581       logical :: lprn
25582 !el local variables
25583       integer :: iint,itypi,itypi1,itypj,subchap
25584       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25585       real(kind=8) :: evdw,sig0ij
25586       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25587                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25588                     sslipi,sslipj,faclip
25589       integer :: ii
25590       real(kind=8) :: fracinbuf
25591        real (kind=8) :: epeppho
25592        real (kind=8),dimension(4):: ener
25593        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25594        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25595         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25596         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25597         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25598         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25599         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25600         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25601        real(kind=8),dimension(3,2)::chead,erhead_tail
25602        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25603        integer troll
25604        real (kind=8) :: dcosom1(3),dcosom2(3)
25605        epeppho=0.0d0
25606 !       do i=1,nres_molec(1)
25607         do i=ibond_start,ibond_end
25608         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25609         itypi  = itype(i,1)
25610         dsci_inv = vbld_inv(i+1)/2.0
25611         dxi    = dc_norm(1,i)
25612         dyi    = dc_norm(2,i)
25613         dzi    = dc_norm(3,i)
25614         xi=(c(1,i)+c(1,i+1))/2.0
25615         yi=(c(2,i)+c(2,i+1))/2.0
25616         zi=(c(3,i)+c(3,i+1))/2.0
25617         xi=mod(xi,boxxsize)
25618          if (xi.lt.0) xi=xi+boxxsize
25619         yi=mod(yi,boxysize)
25620          if (yi.lt.0) yi=yi+boxysize
25621         zi=mod(zi,boxzsize)
25622          if (zi.lt.0) zi=zi+boxzsize
25623          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25624            itypj= itype(j,2)
25625            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25626             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25627            xj=(c(1,j)+c(1,j+1))/2.0
25628            yj=(c(2,j)+c(2,j+1))/2.0
25629            zj=(c(3,j)+c(3,j+1))/2.0
25630            xj=dmod(xj,boxxsize)
25631            if (xj.lt.0) xj=xj+boxxsize
25632            yj=dmod(yj,boxysize)
25633            if (yj.lt.0) yj=yj+boxysize
25634            zj=dmod(zj,boxzsize)
25635            if (zj.lt.0) zj=zj+boxzsize
25636           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25637           xj_safe=xj
25638           yj_safe=yj
25639           zj_safe=zj
25640           subchap=0
25641           do xshift=-1,1
25642           do yshift=-1,1
25643           do zshift=-1,1
25644           xj=xj_safe+xshift*boxxsize
25645           yj=yj_safe+yshift*boxysize
25646           zj=zj_safe+zshift*boxzsize
25647           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25648           if(dist_temp.lt.dist_init) then
25649             dist_init=dist_temp
25650             xj_temp=xj
25651             yj_temp=yj
25652             zj_temp=zj
25653             subchap=1
25654           endif
25655           enddo
25656           enddo
25657           enddo
25658           if (subchap.eq.1) then
25659           xj=xj_temp-xi
25660           yj=yj_temp-yi
25661           zj=zj_temp-zi
25662           else
25663           xj=xj_safe-xi
25664           yj=yj_safe-yi
25665           zj=zj_safe-zi
25666           endif
25667           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25668           rij  = dsqrt(rrij)
25669           dxj = dc_norm( 1,j )
25670           dyj = dc_norm( 2,j )
25671           dzj = dc_norm( 3,j )
25672           dscj_inv = vbld_inv(j+1)/2.0
25673 ! Gay-berne var's
25674           sig0ij = sigma_peppho
25675 !          chi1=0.0d0
25676 !          chi2=0.0d0
25677           chi12  = chi1 * chi2
25678 !          chip1=0.0d0
25679 !          chip2=0.0d0
25680           chip12 = chip1 * chip2
25681 !          chis1 = 0.0d0
25682 !          chis2 = 0.0d0
25683           chis12 = chis1 * chis2
25684           sig1 = sigmap1_peppho
25685           sig2 = sigmap2_peppho
25686 !       write (*,*) "sig1 = ", sig1
25687 !       write (*,*) "sig1 = ", sig1
25688 !       write (*,*) "sig2 = ", sig2
25689 ! alpha factors from Fcav/Gcav
25690           alf1   = 0.0d0
25691           alf2   = 0.0d0
25692           alf12  = 0.0d0
25693           b1 = alphasur_peppho(1)
25694 !          b1=0.0d0
25695           b2 = alphasur_peppho(2)
25696           b3 = alphasur_peppho(3)
25697           b4 = alphasur_peppho(4)
25698           CALL sc_angular
25699        sqom1=om1*om1
25700        evdwij = 0.0d0
25701        ECL = 0.0d0
25702        Elj = 0.0d0
25703        Equad = 0.0d0
25704        Epol = 0.0d0
25705        Fcav=0.0d0
25706        eheadtail = 0.0d0
25707        dGCLdR=0.0d0
25708        dGCLdOM1 = 0.0d0
25709        dGCLdOM2 = 0.0d0
25710        dGCLdOM12 = 0.0d0
25711        dPOLdOM1 = 0.0d0
25712        dPOLdOM2 = 0.0d0
25713           Fcav = 0.0d0
25714           dFdR = 0.0d0
25715           dCAVdOM1  = 0.0d0
25716           dCAVdOM2  = 0.0d0
25717           dCAVdOM12 = 0.0d0
25718           rij_shift = rij
25719           fac       = rij_shift**expon
25720           c1        = fac  * fac * aa_peppho
25721 !          c1        = 0.0d0
25722           c2        = fac  * bb_peppho
25723 !          c2        = 0.0d0
25724           evdwij    =  c1 + c2
25725 ! Now cavity....................
25726        eagle = dsqrt(1.0/rij_shift)
25727        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25728           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25729           botsq = bot * bot
25730           Fcav = top / bot
25731           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25732           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25733           dFdR = ((dtop * bot - top * dbot) / botsq)
25734        w1        = wqdip_peppho(1)
25735        w2        = wqdip_peppho(2)
25736 !       w1=0.0d0
25737 !       w2=0.0d0
25738 !       pis       = sig0head_scbase(itypi,itypj)
25739 !       eps_head   = epshead_scbase(itypi,itypj)
25740 !c!-------------------------------------------------------------------
25741
25742 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25743 !c!     &        +dhead(1,1,itypi,itypj))**2))
25744 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25745 !c!     &        +dhead(2,1,itypi,itypj))**2))
25746
25747 !c!-------------------------------------------------------------------
25748 !c! ecl
25749        sparrow  = w1  *  om1
25750        hawk     = w2 *  (1.0d0 - sqom1)
25751        Ecl = sparrow * rij_shift**2.0d0 &
25752            - hawk    * rij_shift**4.0d0
25753 !c!-------------------------------------------------------------------
25754 !c! derivative of ecl is Gcl
25755 !c! dF/dr part
25756 !       rij_shift=5.0
25757        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25758                 + 4.0d0 * hawk    * rij_shift**5.0d0
25759 !c! dF/dom1
25760        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25761 !c! dF/dom2
25762        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25763        eom1  =    dGCLdOM1+dGCLdOM2
25764        eom2  =    0.0
25765
25766           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25767 !          fac=0.0
25768           gg(1) =  fac*xj*rij
25769           gg(2) =  fac*yj*rij
25770           gg(3) =  fac*zj*rij
25771          do k=1,3
25772          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25773          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25774          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25775          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25776          gg(k)=0.0
25777          enddo
25778
25779       DO k = 1, 3
25780         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25781         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25782         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25783         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25784 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25785         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25786 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25787         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25788                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25789         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25790                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25791         enddo
25792        epeppho=epeppho+evdwij+Fcav+ECL
25793 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25794        enddo
25795        enddo
25796       end subroutine eprot_pep_phosphate
25797 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25798       subroutine emomo(evdw)
25799       use calc_data
25800       use comm_momo
25801 !      implicit real*8 (a-h,o-z)
25802 !      include 'DIMENSIONS'
25803 !      include 'COMMON.GEO'
25804 !      include 'COMMON.VAR'
25805 !      include 'COMMON.LOCAL'
25806 !      include 'COMMON.CHAIN'
25807 !      include 'COMMON.DERIV'
25808 !      include 'COMMON.NAMES'
25809 !      include 'COMMON.INTERACT'
25810 !      include 'COMMON.IOUNITS'
25811 !      include 'COMMON.CALC'
25812 !      include 'COMMON.CONTROL'
25813 !      include 'COMMON.SBRIDGE'
25814       logical :: lprn
25815 !el local variables
25816       integer :: iint,itypi1,subchap,isel
25817       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25818       real(kind=8) :: evdw
25819       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25820                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25821                     sslipi,sslipj,faclip,alpha_sco
25822       integer :: ii
25823       real(kind=8) :: fracinbuf
25824        real (kind=8) :: escpho
25825        real (kind=8),dimension(4):: ener
25826        real(kind=8) :: b1,b2,egb
25827        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25828         Lambf,&
25829         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25830         dFdOM2,dFdL,dFdOM12,&
25831         federmaus,&
25832         d1i,d1j
25833 !       real(kind=8),dimension(3,2)::erhead_tail
25834 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25835        real(kind=8) ::  facd4, adler, Fgb, facd3
25836        integer troll,jj,istate
25837        real (kind=8) :: dcosom1(3),dcosom2(3)
25838        eps_out=80.0d0
25839        sss_ele_cut=1.0d0
25840 !       print *,"EVDW KURW",evdw,nres
25841       do i=iatsc_s,iatsc_e
25842 !        print *,"I am in EVDW",i
25843         itypi=iabs(itype(i,1))
25844 !        if (i.ne.47) cycle
25845         if (itypi.eq.ntyp1) cycle
25846         itypi1=iabs(itype(i+1,1))
25847         xi=c(1,nres+i)
25848         yi=c(2,nres+i)
25849         zi=c(3,nres+i)
25850           xi=dmod(xi,boxxsize)
25851           if (xi.lt.0) xi=xi+boxxsize
25852           yi=dmod(yi,boxysize)
25853           if (yi.lt.0) yi=yi+boxysize
25854           zi=dmod(zi,boxzsize)
25855           if (zi.lt.0) zi=zi+boxzsize
25856
25857        if ((zi.gt.bordlipbot)  &
25858         .and.(zi.lt.bordliptop)) then
25859 !C the energy transfer exist
25860         if (zi.lt.buflipbot) then
25861 !C what fraction I am in
25862          fracinbuf=1.0d0-  &
25863               ((zi-bordlipbot)/lipbufthick)
25864 !C lipbufthick is thickenes of lipid buffore
25865          sslipi=sscalelip(fracinbuf)
25866          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25867         elseif (zi.gt.bufliptop) then
25868          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25869          sslipi=sscalelip(fracinbuf)
25870          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25871         else
25872          sslipi=1.0d0
25873          ssgradlipi=0.0
25874         endif
25875        else
25876          sslipi=0.0d0
25877          ssgradlipi=0.0
25878        endif
25879 !       print *, sslipi,ssgradlipi
25880         dxi=dc_norm(1,nres+i)
25881         dyi=dc_norm(2,nres+i)
25882         dzi=dc_norm(3,nres+i)
25883 !        dsci_inv=dsc_inv(itypi)
25884         dsci_inv=vbld_inv(i+nres)
25885 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25886 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25887 !
25888 ! Calculate SC interaction energy.
25889 !
25890         do iint=1,nint_gr(i)
25891           do j=istart(i,iint),iend(i,iint)
25892 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25893             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25894               call dyn_ssbond_ene(i,j,evdwij)
25895               evdw=evdw+evdwij
25896               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25897                               'evdw',i,j,evdwij,' ss'
25898 !              if (energy_dec) write (iout,*) &
25899 !                              'evdw',i,j,evdwij,' ss'
25900              do k=j+1,iend(i,iint)
25901 !C search over all next residues
25902               if (dyn_ss_mask(k)) then
25903 !C check if they are cysteins
25904 !C              write(iout,*) 'k=',k
25905
25906 !c              write(iout,*) "PRZED TRI", evdwij
25907 !               evdwij_przed_tri=evdwij
25908               call triple_ssbond_ene(i,j,k,evdwij)
25909 !c               if(evdwij_przed_tri.ne.evdwij) then
25910 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25911 !c               endif
25912
25913 !c              write(iout,*) "PO TRI", evdwij
25914 !C call the energy function that removes the artifical triple disulfide
25915 !C bond the soubroutine is located in ssMD.F
25916               evdw=evdw+evdwij
25917               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25918                             'evdw',i,j,evdwij,'tss'
25919               endif!dyn_ss_mask(k)
25920              enddo! k
25921             ELSE
25922 !el            ind=ind+1
25923             itypj=iabs(itype(j,1))
25924             if (itypj.eq.ntyp1) cycle
25925              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25926
25927 !             if (j.ne.78) cycle
25928 !            dscj_inv=dsc_inv(itypj)
25929             dscj_inv=vbld_inv(j+nres)
25930            xj=c(1,j+nres)
25931            yj=c(2,j+nres)
25932            zj=c(3,j+nres)
25933            xj=dmod(xj,boxxsize)
25934            if (xj.lt.0) xj=xj+boxxsize
25935            yj=dmod(yj,boxysize)
25936            if (yj.lt.0) yj=yj+boxysize
25937            zj=dmod(zj,boxzsize)
25938            if (zj.lt.0) zj=zj+boxzsize
25939           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25940           xj_safe=xj
25941           yj_safe=yj
25942           zj_safe=zj
25943           subchap=0
25944
25945           do xshift=-1,1
25946           do yshift=-1,1
25947           do zshift=-1,1
25948           xj=xj_safe+xshift*boxxsize
25949           yj=yj_safe+yshift*boxysize
25950           zj=zj_safe+zshift*boxzsize
25951           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25952           if(dist_temp.lt.dist_init) then
25953             dist_init=dist_temp
25954             xj_temp=xj
25955             yj_temp=yj
25956             zj_temp=zj
25957             subchap=1
25958           endif
25959           enddo
25960           enddo
25961           enddo
25962           if (subchap.eq.1) then
25963           xj=xj_temp-xi
25964           yj=yj_temp-yi
25965           zj=zj_temp-zi
25966           else
25967           xj=xj_safe-xi
25968           yj=yj_safe-yi
25969           zj=zj_safe-zi
25970           endif
25971           dxj = dc_norm( 1, nres+j )
25972           dyj = dc_norm( 2, nres+j )
25973           dzj = dc_norm( 3, nres+j )
25974 !          print *,i,j,itypi,itypj
25975 !          d1i=0.0d0
25976 !          d1j=0.0d0
25977 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25978 ! Gay-berne var's
25979 !1!          sig0ij = sigma_scsc( itypi,itypj )
25980 !          chi1=0.0d0
25981 !          chi2=0.0d0
25982 !          chip1=0.0d0
25983 !          chip2=0.0d0
25984 ! not used by momo potential, but needed by sc_angular which is shared
25985 ! by all energy_potential subroutines
25986           alf1   = 0.0d0
25987           alf2   = 0.0d0
25988           alf12  = 0.0d0
25989           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25990 !       a12sq = a12sq * a12sq
25991 ! charge of amino acid itypi is...
25992           chis1 = chis(itypi,itypj)
25993           chis2 = chis(itypj,itypi)
25994           chis12 = chis1 * chis2
25995           sig1 = sigmap1(itypi,itypj)
25996           sig2 = sigmap2(itypi,itypj)
25997 !       write (*,*) "sig1 = ", sig1
25998 !          chis1=0.0
25999 !          chis2=0.0
26000 !                    chis12 = chis1 * chis2
26001 !          sig1=0.0
26002 !          sig2=0.0
26003 !       write (*,*) "sig2 = ", sig2
26004 ! alpha factors from Fcav/Gcav
26005           b1cav = alphasur(1,itypi,itypj)
26006 !          b1cav=0.0d0
26007           b2cav = alphasur(2,itypi,itypj)
26008           b3cav = alphasur(3,itypi,itypj)
26009           b4cav = alphasur(4,itypi,itypj)
26010 ! used to determine whether we want to do quadrupole calculations
26011        eps_in = epsintab(itypi,itypj)
26012        if (eps_in.eq.0.0) eps_in=1.0
26013
26014        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26015        Rtail = 0.0d0
26016 !       dtail(1,itypi,itypj)=0.0
26017 !       dtail(2,itypi,itypj)=0.0
26018
26019        DO k = 1, 3
26020         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26021         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26022        END DO
26023 !c! tail distances will be themselves usefull elswhere
26024 !c1 (in Gcav, for example)
26025        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26026        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26027        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26028        Rtail = dsqrt( &
26029           (Rtail_distance(1)*Rtail_distance(1)) &
26030         + (Rtail_distance(2)*Rtail_distance(2)) &
26031         + (Rtail_distance(3)*Rtail_distance(3)))
26032
26033 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26034 !-------------------------------------------------------------------
26035 ! tail location and distance calculations
26036        d1 = dhead(1, 1, itypi, itypj)
26037        d2 = dhead(2, 1, itypi, itypj)
26038
26039        DO k = 1,3
26040 ! location of polar head is computed by taking hydrophobic centre
26041 ! and moving by a d1 * dc_norm vector
26042 ! see unres publications for very informative images
26043         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26044         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26045 ! distance
26046 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26047 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26048         Rhead_distance(k) = chead(k,2) - chead(k,1)
26049        END DO
26050 ! pitagoras (root of sum of squares)
26051        Rhead = dsqrt( &
26052           (Rhead_distance(1)*Rhead_distance(1)) &
26053         + (Rhead_distance(2)*Rhead_distance(2)) &
26054         + (Rhead_distance(3)*Rhead_distance(3)))
26055 !-------------------------------------------------------------------
26056 ! zero everything that should be zero'ed
26057        evdwij = 0.0d0
26058        ECL = 0.0d0
26059        Elj = 0.0d0
26060        Equad = 0.0d0
26061        Epol = 0.0d0
26062        Fcav=0.0d0
26063        eheadtail = 0.0d0
26064        dGCLdOM1 = 0.0d0
26065        dGCLdOM2 = 0.0d0
26066        dGCLdOM12 = 0.0d0
26067        dPOLdOM1 = 0.0d0
26068        dPOLdOM2 = 0.0d0
26069           Fcav = 0.0d0
26070           dFdR = 0.0d0
26071           dCAVdOM1  = 0.0d0
26072           dCAVdOM2  = 0.0d0
26073           dCAVdOM12 = 0.0d0
26074           dscj_inv = vbld_inv(j+nres)
26075 !          print *,i,j,dscj_inv,dsci_inv
26076 ! rij holds 1/(distance of Calpha atoms)
26077           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26078           rij  = dsqrt(rrij)
26079 !----------------------------
26080           CALL sc_angular
26081 ! this should be in elgrad_init but om's are calculated by sc_angular
26082 ! which in turn is used by older potentials
26083 ! om = omega, sqom = om^2
26084           sqom1  = om1 * om1
26085           sqom2  = om2 * om2
26086           sqom12 = om12 * om12
26087
26088 ! now we calculate EGB - Gey-Berne
26089 ! It will be summed up in evdwij and saved in evdw
26090           sigsq     = 1.0D0  / sigsq
26091           sig       = sig0ij * dsqrt(sigsq)
26092 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26093           rij_shift = Rtail - sig + sig0ij
26094           IF (rij_shift.le.0.0D0) THEN
26095            evdw = 1.0D20
26096            RETURN
26097           END IF
26098           sigder = -sig * sigsq
26099           rij_shift = 1.0D0 / rij_shift
26100           fac       = rij_shift**expon
26101           c1        = fac  * fac * aa_aq(itypi,itypj)
26102 !          print *,"ADAM",aa_aq(itypi,itypj)
26103
26104 !          c1        = 0.0d0
26105           c2        = fac  * bb_aq(itypi,itypj)
26106 !          c2        = 0.0d0
26107           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26108           eps2der   = eps3rt * evdwij
26109           eps3der   = eps2rt * evdwij
26110 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26111           evdwij    = eps2rt * eps3rt * evdwij
26112 !#ifdef TSCSC
26113 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26114 !           evdw_p = evdw_p + evdwij
26115 !          ELSE
26116 !           evdw_m = evdw_m + evdwij
26117 !          END IF
26118 !#else
26119           evdw = evdw  &
26120               + evdwij
26121 !#endif
26122
26123           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26124           fac    = -expon * (c1 + evdwij) * rij_shift
26125           sigder = fac * sigder
26126 !          fac    = rij * fac
26127 ! Calculate distance derivative
26128           gg(1) =  fac
26129           gg(2) =  fac
26130           gg(3) =  fac
26131 !          if (b2.gt.0.0) then
26132           fac = chis1 * sqom1 + chis2 * sqom2 &
26133           - 2.0d0 * chis12 * om1 * om2 * om12
26134 ! we will use pom later in Gcav, so dont mess with it!
26135           pom = 1.0d0 - chis1 * chis2 * sqom12
26136           Lambf = (1.0d0 - (fac / pom))
26137 !          print *,"fac,pom",fac,pom,Lambf
26138           Lambf = dsqrt(Lambf)
26139           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26140 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26141 !       write (*,*) "sparrow = ", sparrow
26142           Chif = Rtail * sparrow
26143 !           print *,"rij,sparrow",rij , sparrow
26144           ChiLambf = Chif * Lambf
26145           eagle = dsqrt(ChiLambf)
26146           bat = ChiLambf ** 11.0d0
26147           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26148           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26149           botsq = bot * bot
26150 !          print *,top,bot,"bot,top",ChiLambf,Chif
26151           Fcav = top / bot
26152
26153        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26154        dbot = 12.0d0 * b4cav * bat * Lambf
26155        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26156
26157           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26158           dbot = 12.0d0 * b4cav * bat * Chif
26159           eagle = Lambf * pom
26160           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26161           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26162           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26163               * (chis2 * om2 * om12 - om1) / (eagle * pom)
26164
26165           dFdL = ((dtop * bot - top * dbot) / botsq)
26166 !       dFdL = 0.0d0
26167           dCAVdOM1  = dFdL * ( dFdOM1 )
26168           dCAVdOM2  = dFdL * ( dFdOM2 )
26169           dCAVdOM12 = dFdL * ( dFdOM12 )
26170
26171        DO k= 1, 3
26172         ertail(k) = Rtail_distance(k)/Rtail
26173        END DO
26174        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26175        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26176        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26177        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26178        DO k = 1, 3
26179 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26180 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26181         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26182         gvdwx(k,i) = gvdwx(k,i) &
26183                   - (( dFdR + gg(k) ) * pom)
26184 !c!     &             - ( dFdR * pom )
26185         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26186         gvdwx(k,j) = gvdwx(k,j)   &
26187                   + (( dFdR + gg(k) ) * pom)
26188 !c!     &             + ( dFdR * pom )
26189
26190         gvdwc(k,i) = gvdwc(k,i)  &
26191                   - (( dFdR + gg(k) ) * ertail(k))
26192 !c!     &             - ( dFdR * ertail(k))
26193
26194         gvdwc(k,j) = gvdwc(k,j) &
26195                   + (( dFdR + gg(k) ) * ertail(k))
26196 !c!     &             + ( dFdR * ertail(k))
26197
26198         gg(k) = 0.0d0
26199 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26200 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26201       END DO
26202
26203
26204 !c! Compute head-head and head-tail energies for each state
26205
26206           isel = iabs(Qi) + iabs(Qj)
26207 ! double charge for Phophorylated! itype - 25,27,27
26208 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
26209 !            Qi=Qi*2
26210 !            Qij=Qij*2
26211 !           endif
26212 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
26213 !            Qj=Qj*2
26214 !            Qij=Qij*2
26215 !           endif
26216
26217 !          isel=0
26218           IF (isel.eq.0) THEN
26219 !c! No charges - do nothing
26220            eheadtail = 0.0d0
26221
26222           ELSE IF (isel.eq.4) THEN
26223 !c! Calculate dipole-dipole interactions
26224            CALL edd(ecl)
26225            eheadtail = ECL
26226 !           eheadtail = 0.0d0
26227
26228           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
26229 !c! Charge-nonpolar interactions
26230           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26231             Qi=Qi*2
26232             Qij=Qij*2
26233            endif
26234           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26235             Qj=Qj*2
26236             Qij=Qij*2
26237            endif
26238
26239            CALL eqn(epol)
26240            eheadtail = epol
26241 !           eheadtail = 0.0d0
26242
26243           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
26244 !c! Nonpolar-charge interactions
26245           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26246             Qi=Qi*2
26247             Qij=Qij*2
26248            endif
26249           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26250             Qj=Qj*2
26251             Qij=Qij*2
26252            endif
26253
26254            CALL enq(epol)
26255            eheadtail = epol
26256 !           eheadtail = 0.0d0
26257
26258           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
26259 !c! Charge-dipole interactions
26260           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26261             Qi=Qi*2
26262             Qij=Qij*2
26263            endif
26264           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26265             Qj=Qj*2
26266             Qij=Qij*2
26267            endif
26268
26269            CALL eqd(ecl, elj, epol)
26270            eheadtail = ECL + elj + epol
26271 !           eheadtail = 0.0d0
26272
26273           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
26274 !c! Dipole-charge interactions
26275           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26276             Qi=Qi*2
26277             Qij=Qij*2
26278            endif
26279           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26280             Qj=Qj*2
26281             Qij=Qij*2
26282            endif
26283            CALL edq(ecl, elj, epol)
26284           eheadtail = ECL + elj + epol
26285 !           eheadtail = 0.0d0
26286
26287           ELSE IF ((isel.eq.2.and.   &
26288                iabs(Qi).eq.1).and.  &
26289                nstate(itypi,itypj).eq.1) THEN
26290 !c! Same charge-charge interaction ( +/+ or -/- )
26291           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26292             Qi=Qi*2
26293             Qij=Qij*2
26294            endif
26295           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26296             Qj=Qj*2
26297             Qij=Qij*2
26298            endif
26299
26300            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
26301            eheadtail = ECL + Egb + Epol + Fisocav + Elj
26302 !           eheadtail = 0.0d0
26303
26304           ELSE IF ((isel.eq.2.and.  &
26305                iabs(Qi).eq.1).and. &
26306                nstate(itypi,itypj).ne.1) THEN
26307 !c! Different charge-charge interaction ( +/- or -/+ )
26308           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26309             Qi=Qi*2
26310             Qij=Qij*2
26311            endif
26312           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26313             Qj=Qj*2
26314             Qij=Qij*2
26315            endif
26316
26317            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26318           END IF
26319        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
26320       evdw = evdw  + Fcav + eheadtail
26321
26322        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
26323         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
26324         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
26325         Equad,evdwij+Fcav+eheadtail,evdw
26326 !       evdw = evdw  + Fcav  + eheadtail
26327
26328         iF (nstate(itypi,itypj).eq.1) THEN
26329         CALL sc_grad
26330        END IF
26331 !c!-------------------------------------------------------------------
26332 !c! NAPISY KONCOWE
26333          END DO   ! j
26334         END DO    ! iint
26335        END DO     ! i
26336 !c      write (iout,*) "Number of loop steps in EGB:",ind
26337 !c      energy_dec=.false.
26338 !              print *,"EVDW KURW",evdw,nres
26339
26340        RETURN
26341       END SUBROUTINE emomo
26342 !C------------------------------------------------------------------------------------
26343       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26344       use calc_data
26345       use comm_momo
26346        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26347          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26348 !       integer :: k
26349 !c! Epol and Gpol analytical parameters
26350        alphapol1 = alphapol(itypi,itypj)
26351        alphapol2 = alphapol(itypj,itypi)
26352 !c! Fisocav and Gisocav analytical parameters
26353        al1  = alphiso(1,itypi,itypj)
26354        al2  = alphiso(2,itypi,itypj)
26355        al3  = alphiso(3,itypi,itypj)
26356        al4  = alphiso(4,itypi,itypj)
26357        csig = (1.0d0  &
26358            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26359            + sigiso2(itypi,itypj)**2.0d0))
26360 !c!
26361        pis  = sig0head(itypi,itypj)
26362        eps_head = epshead(itypi,itypj)
26363        Rhead_sq = Rhead * Rhead
26364 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26365 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26366        R1 = 0.0d0
26367        R2 = 0.0d0
26368        DO k = 1, 3
26369 !c! Calculate head-to-tail distances needed by Epol
26370         R1=R1+(ctail(k,2)-chead(k,1))**2
26371         R2=R2+(chead(k,2)-ctail(k,1))**2
26372        END DO
26373 !c! Pitagoras
26374        R1 = dsqrt(R1)
26375        R2 = dsqrt(R2)
26376
26377 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26378 !c!     &        +dhead(1,1,itypi,itypj))**2))
26379 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26380 !c!     &        +dhead(2,1,itypi,itypj))**2))
26381
26382 !c!-------------------------------------------------------------------
26383 !c! Coulomb electrostatic interaction
26384        Ecl = (332.0d0 * Qij) / Rhead
26385 !c! derivative of Ecl is Gcl...
26386        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26387        dGCLdOM1 = 0.0d0
26388        dGCLdOM2 = 0.0d0
26389        dGCLdOM12 = 0.0d0
26390        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26391        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26392        debkap=debaykap(itypi,itypj)
26393        Egb = -(332.0d0 * Qij *&
26394         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26395 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26396 !c! Derivative of Egb is Ggb...
26397        dGGBdFGB = -(-332.0d0 * Qij * &
26398        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26399        -(332.0d0 * Qij *&
26400         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26401        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26402        dGGBdR = dGGBdFGB * dFGBdR
26403 !c!-------------------------------------------------------------------
26404 !c! Fisocav - isotropic cavity creation term
26405 !c! or "how much energy it costs to put charged head in water"
26406        pom = Rhead * csig
26407        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26408        bot = (1.0d0 + al4 * pom**12.0d0)
26409        botsq = bot * bot
26410        FisoCav = top / bot
26411 !      write (*,*) "Rhead = ",Rhead
26412 !      write (*,*) "csig = ",csig
26413 !      write (*,*) "pom = ",pom
26414 !      write (*,*) "al1 = ",al1
26415 !      write (*,*) "al2 = ",al2
26416 !      write (*,*) "al3 = ",al3
26417 !      write (*,*) "al4 = ",al4
26418 !        write (*,*) "top = ",top
26419 !        write (*,*) "bot = ",bot
26420 !c! Derivative of Fisocav is GCV...
26421        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26422        dbot = 12.0d0 * al4 * pom ** 11.0d0
26423        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26424 !c!-------------------------------------------------------------------
26425 !c! Epol
26426 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26427        MomoFac1 = (1.0d0 - chi1 * sqom2)
26428        MomoFac2 = (1.0d0 - chi2 * sqom1)
26429        RR1  = ( R1 * R1 ) / MomoFac1
26430        RR2  = ( R2 * R2 ) / MomoFac2
26431        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26432        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26433        fgb1 = sqrt( RR1 + a12sq * ee1 )
26434        fgb2 = sqrt( RR2 + a12sq * ee2 )
26435        epol = 332.0d0 * eps_inout_fac * ( &
26436       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26437 !c!       epol = 0.0d0
26438        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26439                / (fgb1 ** 5.0d0)
26440        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26441                / (fgb2 ** 5.0d0)
26442        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26443              / ( 2.0d0 * fgb1 )
26444        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26445              / ( 2.0d0 * fgb2 )
26446        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26447                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26448        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26449                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26450        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26451 !c!       dPOLdR1 = 0.0d0
26452        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26453 !c!       dPOLdR2 = 0.0d0
26454        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26455 !c!       dPOLdOM1 = 0.0d0
26456        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26457 !c!       dPOLdOM2 = 0.0d0
26458 !c!-------------------------------------------------------------------
26459 !c! Elj
26460 !c! Lennard-Jones 6-12 interaction between heads
26461        pom = (pis / Rhead)**6.0d0
26462        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26463 !c! derivative of Elj is Glj
26464        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26465              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26466 !c!-------------------------------------------------------------------
26467 !c! Return the results
26468 !c! These things do the dRdX derivatives, that is
26469 !c! allow us to change what we see from function that changes with
26470 !c! distance to function that changes with LOCATION (of the interaction
26471 !c! site)
26472        DO k = 1, 3
26473         erhead(k) = Rhead_distance(k)/Rhead
26474         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26475         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26476        END DO
26477
26478        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26479        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26480        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26481        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26482        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26483        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26484        facd1 = d1 * vbld_inv(i+nres)
26485        facd2 = d2 * vbld_inv(j+nres)
26486        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26487        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26488
26489 !c! Now we add appropriate partial derivatives (one in each dimension)
26490        DO k = 1, 3
26491         hawk   = (erhead_tail(k,1) + &
26492         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26493         condor = (erhead_tail(k,2) + &
26494         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26495
26496         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26497         gvdwx(k,i) = gvdwx(k,i) &
26498                   - dGCLdR * pom&
26499                   - dGGBdR * pom&
26500                   - dGCVdR * pom&
26501                   - dPOLdR1 * hawk&
26502                   - dPOLdR2 * (erhead_tail(k,2)&
26503       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26504                   - dGLJdR * pom
26505
26506         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26507         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26508                    + dGGBdR * pom+ dGCVdR * pom&
26509                   + dPOLdR1 * (erhead_tail(k,1)&
26510       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26511                   + dPOLdR2 * condor + dGLJdR * pom
26512
26513         gvdwc(k,i) = gvdwc(k,i)  &
26514                   - dGCLdR * erhead(k)&
26515                   - dGGBdR * erhead(k)&
26516                   - dGCVdR * erhead(k)&
26517                   - dPOLdR1 * erhead_tail(k,1)&
26518                   - dPOLdR2 * erhead_tail(k,2)&
26519                   - dGLJdR * erhead(k)
26520
26521         gvdwc(k,j) = gvdwc(k,j)         &
26522                   + dGCLdR * erhead(k) &
26523                   + dGGBdR * erhead(k) &
26524                   + dGCVdR * erhead(k) &
26525                   + dPOLdR1 * erhead_tail(k,1) &
26526                   + dPOLdR2 * erhead_tail(k,2)&
26527                   + dGLJdR * erhead(k)
26528
26529        END DO
26530        RETURN
26531       END SUBROUTINE eqq
26532
26533       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26534       use calc_data
26535       use comm_momo
26536        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26537          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26538 !       integer :: k
26539 !c! Epol and Gpol analytical parameters
26540        alphapol1 = alphapolcat(itypi,itypj)
26541        alphapol2 = alphapolcat(itypj,itypi)
26542 !c! Fisocav and Gisocav analytical parameters
26543        al1  = alphisocat(1,itypi,itypj)
26544        al2  = alphisocat(2,itypi,itypj)
26545        al3  = alphisocat(3,itypi,itypj)
26546        al4  = alphisocat(4,itypi,itypj)
26547        csig = (1.0d0  &
26548            / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26549            + sigiso2cat(itypi,itypj)**2.0d0))
26550 !c!
26551        pis  = sig0headcat(itypi,itypj)
26552        eps_head = epsheadcat(itypi,itypj)
26553        Rhead_sq = Rhead * Rhead
26554 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26555 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26556        R1 = 0.0d0
26557        R2 = 0.0d0
26558        DO k = 1, 3
26559 !c! Calculate head-to-tail distances needed by Epol
26560         R1=R1+(ctail(k,2)-chead(k,1))**2
26561         R2=R2+(chead(k,2)-ctail(k,1))**2
26562        END DO
26563 !c! Pitagoras
26564        R1 = dsqrt(R1)
26565        R2 = dsqrt(R2)
26566
26567 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26568 !c!     &        +dhead(1,1,itypi,itypj))**2))
26569 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26570 !c!     &        +dhead(2,1,itypi,itypj))**2))
26571
26572 !c!-------------------------------------------------------------------
26573 !c! Coulomb electrostatic interaction
26574        Ecl = (332.0d0 * Qij) / Rhead
26575 !c! derivative of Ecl is Gcl...
26576        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26577        dGCLdOM1 = 0.0d0
26578        dGCLdOM2 = 0.0d0
26579        dGCLdOM12 = 0.0d0
26580        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26581        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26582        debkap=debaykapcat(itypi,itypj)
26583        Egb = -(332.0d0 * Qij *&
26584         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26585 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26586 !c! Derivative of Egb is Ggb...
26587        dGGBdFGB = -(-332.0d0 * Qij * &
26588        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26589        -(332.0d0 * Qij *&
26590         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26591        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26592        dGGBdR = dGGBdFGB * dFGBdR
26593 !c!-------------------------------------------------------------------
26594 !c! Fisocav - isotropic cavity creation term
26595 !c! or "how much energy it costs to put charged head in water"
26596        pom = Rhead * csig
26597        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26598        bot = (1.0d0 + al4 * pom**12.0d0)
26599        botsq = bot * bot
26600        FisoCav = top / bot
26601 !      write (*,*) "Rhead = ",Rhead
26602 !      write (*,*) "csig = ",csig
26603 !      write (*,*) "pom = ",pom
26604 !      write (*,*) "al1 = ",al1
26605 !      write (*,*) "al2 = ",al2
26606 !      write (*,*) "al3 = ",al3
26607 !      write (*,*) "al4 = ",al4
26608 !        write (*,*) "top = ",top
26609 !        write (*,*) "bot = ",bot
26610 !c! Derivative of Fisocav is GCV...
26611        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26612        dbot = 12.0d0 * al4 * pom ** 11.0d0
26613        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26614 !c!-------------------------------------------------------------------
26615 !c! Epol
26616 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26617        MomoFac1 = (1.0d0 - chi1 * sqom2)
26618        MomoFac2 = (1.0d0 - chi2 * sqom1)
26619        RR1  = ( R1 * R1 ) / MomoFac1
26620        RR2  = ( R2 * R2 ) / MomoFac2
26621        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26622        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26623        fgb1 = sqrt( RR1 + a12sq * ee1 )
26624        fgb2 = sqrt( RR2 + a12sq * ee2 )
26625        epol = 332.0d0 * eps_inout_fac * ( &
26626       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26627 !c!       epol = 0.0d0
26628        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26629                / (fgb1 ** 5.0d0)
26630        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26631                / (fgb2 ** 5.0d0)
26632        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26633              / ( 2.0d0 * fgb1 )
26634        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26635              / ( 2.0d0 * fgb2 )
26636        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26637                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26638        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26639                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26640        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26641 !c!       dPOLdR1 = 0.0d0
26642        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26643 !c!       dPOLdR2 = 0.0d0
26644        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26645 !c!       dPOLdOM1 = 0.0d0
26646        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26647 !c!       dPOLdOM2 = 0.0d0
26648 !c!-------------------------------------------------------------------
26649 !c! Elj
26650 !c! Lennard-Jones 6-12 interaction between heads
26651        pom = (pis / Rhead)**6.0d0
26652        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26653 !c! derivative of Elj is Glj
26654        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26655              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26656 !c!-------------------------------------------------------------------
26657 !c! Return the results
26658 !c! These things do the dRdX derivatives, that is
26659 !c! allow us to change what we see from function that changes with
26660 !c! distance to function that changes with LOCATION (of the interaction
26661 !c! site)
26662        DO k = 1, 3
26663         erhead(k) = Rhead_distance(k)/Rhead
26664         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26665         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26666        END DO
26667
26668        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26669        erdxj = scalar( erhead(1), dC_norm(1,j) )
26670        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26671        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26672        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26673        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26674        facd1 = d1 * vbld_inv(i+nres)
26675        facd2 = d2 * vbld_inv(j)
26676        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26677        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26678
26679 !c! Now we add appropriate partial derivatives (one in each dimension)
26680        DO k = 1, 3
26681         hawk   = (erhead_tail(k,1) + &
26682         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26683         condor = (erhead_tail(k,2) + &
26684         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26685
26686         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26687         gradpepcatx(k,i) = gradpepcatx(k,i) &
26688                   - dGCLdR * pom&
26689                   - dGGBdR * pom&
26690                   - dGCVdR * pom&
26691                   - dPOLdR1 * hawk&
26692                   - dPOLdR2 * (erhead_tail(k,2)&
26693       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26694                   - dGLJdR * pom
26695
26696         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26697 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26698 !                   + dGGBdR * pom+ dGCVdR * pom&
26699 !                  + dPOLdR1 * (erhead_tail(k,1)&
26700 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26701 !                  + dPOLdR2 * condor + dGLJdR * pom
26702
26703         gradpepcat(k,i) = gradpepcat(k,i)  &
26704                   - dGCLdR * erhead(k)&
26705                   - dGGBdR * erhead(k)&
26706                   - dGCVdR * erhead(k)&
26707                   - dPOLdR1 * erhead_tail(k,1)&
26708                   - dPOLdR2 * erhead_tail(k,2)&
26709                   - dGLJdR * erhead(k)
26710
26711         gradpepcat(k,j) = gradpepcat(k,j)         &
26712                   + dGCLdR * erhead(k) &
26713                   + dGGBdR * erhead(k) &
26714                   + dGCVdR * erhead(k) &
26715                   + dPOLdR1 * erhead_tail(k,1) &
26716                   + dPOLdR2 * erhead_tail(k,2)&
26717                   + dGLJdR * erhead(k)
26718
26719        END DO
26720        RETURN
26721       END SUBROUTINE eqq_cat
26722 !c!-------------------------------------------------------------------
26723       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26724       use comm_momo
26725       use calc_data
26726
26727        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26728        double precision ener(4)
26729        double precision dcosom1(3),dcosom2(3)
26730 !c! used in Epol derivatives
26731        double precision facd3, facd4
26732        double precision federmaus, adler
26733        integer istate,ii,jj
26734        real (kind=8) :: Fgb
26735 !       print *,"CALLING EQUAD"
26736 !c! Epol and Gpol analytical parameters
26737        alphapol1 = alphapol(itypi,itypj)
26738        alphapol2 = alphapol(itypj,itypi)
26739 !c! Fisocav and Gisocav analytical parameters
26740        al1  = alphiso(1,itypi,itypj)
26741        al2  = alphiso(2,itypi,itypj)
26742        al3  = alphiso(3,itypi,itypj)
26743        al4  = alphiso(4,itypi,itypj)
26744        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26745             + sigiso2(itypi,itypj)**2.0d0))
26746 !c!
26747        w1   = wqdip(1,itypi,itypj)
26748        w2   = wqdip(2,itypi,itypj)
26749        pis  = sig0head(itypi,itypj)
26750        eps_head = epshead(itypi,itypj)
26751 !c! First things first:
26752 !c! We need to do sc_grad's job with GB and Fcav
26753        eom1  = eps2der * eps2rt_om1 &
26754              - 2.0D0 * alf1 * eps3der&
26755              + sigder * sigsq_om1&
26756              + dCAVdOM1
26757        eom2  = eps2der * eps2rt_om2 &
26758              + 2.0D0 * alf2 * eps3der&
26759              + sigder * sigsq_om2&
26760              + dCAVdOM2
26761        eom12 =  evdwij  * eps1_om12 &
26762              + eps2der * eps2rt_om12 &
26763              - 2.0D0 * alf12 * eps3der&
26764              + sigder *sigsq_om12&
26765              + dCAVdOM12
26766 !c! now some magical transformations to project gradient into
26767 !c! three cartesian vectors
26768        DO k = 1, 3
26769         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26770         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26771         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26772 !c! this acts on hydrophobic center of interaction
26773         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26774                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26775                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26776         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26777                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26778                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26779 !c! this acts on Calpha
26780         gvdwc(k,i)=gvdwc(k,i)-gg(k)
26781         gvdwc(k,j)=gvdwc(k,j)+gg(k)
26782        END DO
26783 !c! sc_grad is done, now we will compute
26784        eheadtail = 0.0d0
26785        eom1 = 0.0d0
26786        eom2 = 0.0d0
26787        eom12 = 0.0d0
26788        DO istate = 1, nstate(itypi,itypj)
26789 !c*************************************************************
26790         IF (istate.ne.1) THEN
26791          IF (istate.lt.3) THEN
26792           ii = 1
26793          ELSE
26794           ii = 2
26795          END IF
26796         jj = istate/ii
26797         d1 = dhead(1,ii,itypi,itypj)
26798         d2 = dhead(2,jj,itypi,itypj)
26799         DO k = 1,3
26800          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26801          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26802          Rhead_distance(k) = chead(k,2) - chead(k,1)
26803         END DO
26804 !c! pitagoras (root of sum of squares)
26805         Rhead = dsqrt( &
26806                (Rhead_distance(1)*Rhead_distance(1))  &
26807              + (Rhead_distance(2)*Rhead_distance(2))  &
26808              + (Rhead_distance(3)*Rhead_distance(3)))
26809         END IF
26810         Rhead_sq = Rhead * Rhead
26811
26812 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26813 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26814         R1 = 0.0d0
26815         R2 = 0.0d0
26816         DO k = 1, 3
26817 !c! Calculate head-to-tail distances
26818          R1=R1+(ctail(k,2)-chead(k,1))**2
26819          R2=R2+(chead(k,2)-ctail(k,1))**2
26820         END DO
26821 !c! Pitagoras
26822         R1 = dsqrt(R1)
26823         R2 = dsqrt(R2)
26824         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26825 !c!        Ecl = 0.0d0
26826 !c!        write (*,*) "Ecl = ", Ecl
26827 !c! derivative of Ecl is Gcl...
26828         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26829 !c!        dGCLdR = 0.0d0
26830         dGCLdOM1 = 0.0d0
26831         dGCLdOM2 = 0.0d0
26832         dGCLdOM12 = 0.0d0
26833 !c!-------------------------------------------------------------------
26834 !c! Generalised Born Solvent Polarization
26835         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26836         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26837         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26838 !c!        Egb = 0.0d0
26839 !c!      write (*,*) "a1*a2 = ", a12sq
26840 !c!      write (*,*) "Rhead = ", Rhead
26841 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26842 !c!      write (*,*) "ee = ", ee
26843 !c!      write (*,*) "Fgb = ", Fgb
26844 !c!      write (*,*) "fac = ", eps_inout_fac
26845 !c!      write (*,*) "Qij = ", Qij
26846 !c!      write (*,*) "Egb = ", Egb
26847 !c! Derivative of Egb is Ggb...
26848 !c! dFGBdR is used by Quad's later...
26849         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26850         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26851                / ( 2.0d0 * Fgb )
26852         dGGBdR = dGGBdFGB * dFGBdR
26853 !c!        dGGBdR = 0.0d0
26854 !c!-------------------------------------------------------------------
26855 !c! Fisocav - isotropic cavity creation term
26856         pom = Rhead * csig
26857         top = al1 * (dsqrt(pom) + al2 * pom - al3)
26858         bot = (1.0d0 + al4 * pom**12.0d0)
26859         botsq = bot * bot
26860         FisoCav = top / bot
26861         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26862         dbot = 12.0d0 * al4 * pom ** 11.0d0
26863         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26864 !c!        dGCVdR = 0.0d0
26865 !c!-------------------------------------------------------------------
26866 !c! Polarization energy
26867 !c! Epol
26868         MomoFac1 = (1.0d0 - chi1 * sqom2)
26869         MomoFac2 = (1.0d0 - chi2 * sqom1)
26870         RR1  = ( R1 * R1 ) / MomoFac1
26871         RR2  = ( R2 * R2 ) / MomoFac2
26872         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26873         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26874         fgb1 = sqrt( RR1 + a12sq * ee1 )
26875         fgb2 = sqrt( RR2 + a12sq * ee2 )
26876         epol = 332.0d0 * eps_inout_fac * (&
26877         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26878 !c!        epol = 0.0d0
26879 !c! derivative of Epol is Gpol...
26880         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26881                   / (fgb1 ** 5.0d0)
26882         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26883                   / (fgb2 ** 5.0d0)
26884         dFGBdR1 = ( (R1 / MomoFac1) &
26885                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
26886                 / ( 2.0d0 * fgb1 )
26887         dFGBdR2 = ( (R2 / MomoFac2) &
26888                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26889                 / ( 2.0d0 * fgb2 )
26890         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26891                  * ( 2.0d0 - 0.5d0 * ee1) ) &
26892                  / ( 2.0d0 * fgb1 )
26893         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26894                  * ( 2.0d0 - 0.5d0 * ee2) ) &
26895                  / ( 2.0d0 * fgb2 )
26896         dPOLdR1 = dPOLdFGB1 * dFGBdR1
26897 !c!        dPOLdR1 = 0.0d0
26898         dPOLdR2 = dPOLdFGB2 * dFGBdR2
26899 !c!        dPOLdR2 = 0.0d0
26900         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26901 !c!        dPOLdOM1 = 0.0d0
26902         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26903         pom = (pis / Rhead)**6.0d0
26904         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26905 !c!        Elj = 0.0d0
26906 !c! derivative of Elj is Glj
26907         dGLJdR = 4.0d0 * eps_head &
26908             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26909             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26910 !c!        dGLJdR = 0.0d0
26911 !c!-------------------------------------------------------------------
26912 !c! Equad
26913        IF (Wqd.ne.0.0d0) THEN
26914         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26915              - 37.5d0  * ( sqom1 + sqom2 ) &
26916              + 157.5d0 * ( sqom1 * sqom2 ) &
26917              - 45.0d0  * om1*om2*om12
26918         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26919         Equad = fac * Beta1
26920 !c!        Equad = 0.0d0
26921 !c! derivative of Equad...
26922         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26923 !c!        dQUADdR = 0.0d0
26924         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26925 !c!        dQUADdOM1 = 0.0d0
26926         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26927 !c!        dQUADdOM2 = 0.0d0
26928         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26929        ELSE
26930          Beta1 = 0.0d0
26931          Equad = 0.0d0
26932         END IF
26933 !c!-------------------------------------------------------------------
26934 !c! Return the results
26935 !c! Angular stuff
26936         eom1 = dPOLdOM1 + dQUADdOM1
26937         eom2 = dPOLdOM2 + dQUADdOM2
26938         eom12 = dQUADdOM12
26939 !c! now some magical transformations to project gradient into
26940 !c! three cartesian vectors
26941         DO k = 1, 3
26942          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26943          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26944          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26945         END DO
26946 !c! Radial stuff
26947         DO k = 1, 3
26948          erhead(k) = Rhead_distance(k)/Rhead
26949          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26950          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26951         END DO
26952         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26953         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26954         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26955         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26956         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26957         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26958         facd1 = d1 * vbld_inv(i+nres)
26959         facd2 = d2 * vbld_inv(j+nres)
26960         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26961         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26962         DO k = 1, 3
26963          hawk   = erhead_tail(k,1) + &
26964          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26965          condor = erhead_tail(k,2) + &
26966          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26967
26968          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26969 !c! this acts on hydrophobic center of interaction
26970          gheadtail(k,1,1) = gheadtail(k,1,1) &
26971                          - dGCLdR * pom &
26972                          - dGGBdR * pom &
26973                          - dGCVdR * pom &
26974                          - dPOLdR1 * hawk &
26975                          - dPOLdR2 * (erhead_tail(k,2) &
26976       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26977                          - dGLJdR * pom &
26978                          - dQUADdR * pom&
26979                          - tuna(k) &
26980                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26981                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26982
26983          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26984 !c! this acts on hydrophobic center of interaction
26985          gheadtail(k,2,1) = gheadtail(k,2,1)  &
26986                          + dGCLdR * pom      &
26987                          + dGGBdR * pom      &
26988                          + dGCVdR * pom      &
26989                          + dPOLdR1 * (erhead_tail(k,1) &
26990       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26991                          + dPOLdR2 * condor &
26992                          + dGLJdR * pom &
26993                          + dQUADdR * pom &
26994                          + tuna(k) &
26995                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26996                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26997
26998 !c! this acts on Calpha
26999          gheadtail(k,3,1) = gheadtail(k,3,1)  &
27000                          - dGCLdR * erhead(k)&
27001                          - dGGBdR * erhead(k)&
27002                          - dGCVdR * erhead(k)&
27003                          - dPOLdR1 * erhead_tail(k,1)&
27004                          - dPOLdR2 * erhead_tail(k,2)&
27005                          - dGLJdR * erhead(k) &
27006                          - dQUADdR * erhead(k)&
27007                          - tuna(k)
27008 !c! this acts on Calpha
27009          gheadtail(k,4,1) = gheadtail(k,4,1)   &
27010                           + dGCLdR * erhead(k) &
27011                           + dGGBdR * erhead(k) &
27012                           + dGCVdR * erhead(k) &
27013                           + dPOLdR1 * erhead_tail(k,1) &
27014                           + dPOLdR2 * erhead_tail(k,2) &
27015                           + dGLJdR * erhead(k) &
27016                           + dQUADdR * erhead(k)&
27017                           + tuna(k)
27018         END DO
27019         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27020         eheadtail = eheadtail &
27021                   + wstate(istate, itypi, itypj) &
27022                   * dexp(-betaT * ener(istate))
27023 !c! foreach cartesian dimension
27024         DO k = 1, 3
27025 !c! foreach of two gvdwx and gvdwc
27026          DO l = 1, 4
27027           gheadtail(k,l,2) = gheadtail(k,l,2)  &
27028                            + wstate( istate, itypi, itypj ) &
27029                            * dexp(-betaT * ener(istate)) &
27030                            * gheadtail(k,l,1)
27031           gheadtail(k,l,1) = 0.0d0
27032          END DO
27033         END DO
27034        END DO
27035 !c! Here ended the gigantic DO istate = 1, 4, which starts
27036 !c! at the beggining of the subroutine
27037
27038        DO k = 1, 3
27039         DO l = 1, 4
27040          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27041         END DO
27042         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27043         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27044         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27045         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27046         DO l = 1, 4
27047          gheadtail(k,l,1) = 0.0d0
27048          gheadtail(k,l,2) = 0.0d0
27049         END DO
27050        END DO
27051        eheadtail = (-dlog(eheadtail)) / betaT
27052        dPOLdOM1 = 0.0d0
27053        dPOLdOM2 = 0.0d0
27054        dQUADdOM1 = 0.0d0
27055        dQUADdOM2 = 0.0d0
27056        dQUADdOM12 = 0.0d0
27057        RETURN
27058       END SUBROUTINE energy_quad
27059 !!-----------------------------------------------------------
27060       SUBROUTINE eqn(Epol)
27061       use comm_momo
27062       use calc_data
27063
27064       double precision  facd4, federmaus,epol
27065       alphapol1 = alphapol(itypi,itypj)
27066 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27067        R1 = 0.0d0
27068        DO k = 1, 3
27069 !c! Calculate head-to-tail distances
27070         R1=R1+(ctail(k,2)-chead(k,1))**2
27071        END DO
27072 !c! Pitagoras
27073        R1 = dsqrt(R1)
27074
27075 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27076 !c!     &        +dhead(1,1,itypi,itypj))**2))
27077 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27078 !c!     &        +dhead(2,1,itypi,itypj))**2))
27079 !c--------------------------------------------------------------------
27080 !c Polarization energy
27081 !c Epol
27082        MomoFac1 = (1.0d0 - chi1 * sqom2)
27083        RR1  = R1 * R1 / MomoFac1
27084        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27085        fgb1 = sqrt( RR1 + a12sq * ee1)
27086        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27087        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27088                / (fgb1 ** 5.0d0)
27089        dFGBdR1 = ( (R1 / MomoFac1) &
27090               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27091               / ( 2.0d0 * fgb1 )
27092        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27093                 * (2.0d0 - 0.5d0 * ee1) ) &
27094                 / (2.0d0 * fgb1)
27095        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27096 !c!       dPOLdR1 = 0.0d0
27097        dPOLdOM1 = 0.0d0
27098        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27099        DO k = 1, 3
27100         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27101        END DO
27102        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27103        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27104        facd1 = d1 * vbld_inv(i+nres)
27105        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27106
27107        DO k = 1, 3
27108         hawk = (erhead_tail(k,1) + &
27109         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27110
27111         gvdwx(k,i) = gvdwx(k,i) &
27112                    - dPOLdR1 * hawk
27113         gvdwx(k,j) = gvdwx(k,j) &
27114                    + dPOLdR1 * (erhead_tail(k,1) &
27115        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27116
27117         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27118         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27119
27120        END DO
27121        RETURN
27122       END SUBROUTINE eqn
27123       SUBROUTINE enq(Epol)
27124       use calc_data
27125       use comm_momo
27126        double precision facd3, adler,epol
27127        alphapol2 = alphapol(itypj,itypi)
27128 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27129        R2 = 0.0d0
27130        DO k = 1, 3
27131 !c! Calculate head-to-tail distances
27132         R2=R2+(chead(k,2)-ctail(k,1))**2
27133        END DO
27134 !c! Pitagoras
27135        R2 = dsqrt(R2)
27136
27137 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27138 !c!     &        +dhead(1,1,itypi,itypj))**2))
27139 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27140 !c!     &        +dhead(2,1,itypi,itypj))**2))
27141 !c------------------------------------------------------------------------
27142 !c Polarization energy
27143        MomoFac2 = (1.0d0 - chi2 * sqom1)
27144        RR2  = R2 * R2 / MomoFac2
27145        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27146        fgb2 = sqrt(RR2  + a12sq * ee2)
27147        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27148        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27149                 / (fgb2 ** 5.0d0)
27150        dFGBdR2 = ( (R2 / MomoFac2)  &
27151               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27152               / (2.0d0 * fgb2)
27153        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27154                 * (2.0d0 - 0.5d0 * ee2) ) &
27155                 / (2.0d0 * fgb2)
27156        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27157 !c!       dPOLdR2 = 0.0d0
27158        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27159 !c!       dPOLdOM1 = 0.0d0
27160        dPOLdOM2 = 0.0d0
27161 !c!-------------------------------------------------------------------
27162 !c! Return the results
27163 !c! (See comments in Eqq)
27164        DO k = 1, 3
27165         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27166        END DO
27167        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27168        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27169        facd2 = d2 * vbld_inv(j+nres)
27170        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27171        DO k = 1, 3
27172         condor = (erhead_tail(k,2) &
27173        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27174
27175         gvdwx(k,i) = gvdwx(k,i) &
27176                    - dPOLdR2 * (erhead_tail(k,2) &
27177        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27178         gvdwx(k,j) = gvdwx(k,j)   &
27179                    + dPOLdR2 * condor
27180
27181         gvdwc(k,i) = gvdwc(k,i) &
27182                    - dPOLdR2 * erhead_tail(k,2)
27183         gvdwc(k,j) = gvdwc(k,j) &
27184                    + dPOLdR2 * erhead_tail(k,2)
27185
27186        END DO
27187       RETURN
27188       END SUBROUTINE enq
27189
27190       SUBROUTINE enq_cat(Epol)
27191       use calc_data
27192       use comm_momo
27193        double precision facd3, adler,epol
27194        alphapol2 = alphapolcat(itypj,itypi)
27195 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27196        R2 = 0.0d0
27197        DO k = 1, 3
27198 !c! Calculate head-to-tail distances
27199         R2=R2+(chead(k,2)-ctail(k,1))**2
27200        END DO
27201 !c! Pitagoras
27202        R2 = dsqrt(R2)
27203
27204 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27205 !c!     &        +dhead(1,1,itypi,itypj))**2))
27206 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27207 !c!     &        +dhead(2,1,itypi,itypj))**2))
27208 !c------------------------------------------------------------------------
27209 !c Polarization energy
27210        MomoFac2 = (1.0d0 - chi2 * sqom1)
27211        RR2  = R2 * R2 / MomoFac2
27212        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27213        fgb2 = sqrt(RR2  + a12sq * ee2)
27214        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27215        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27216                 / (fgb2 ** 5.0d0)
27217        dFGBdR2 = ( (R2 / MomoFac2)  &
27218               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27219               / (2.0d0 * fgb2)
27220        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27221                 * (2.0d0 - 0.5d0 * ee2) ) &
27222                 / (2.0d0 * fgb2)
27223        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27224 !c!       dPOLdR2 = 0.0d0
27225        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27226 !c!       dPOLdOM1 = 0.0d0
27227        dPOLdOM2 = 0.0d0
27228
27229 !c!-------------------------------------------------------------------
27230 !c! Return the results
27231 !c! (See comments in Eqq)
27232        DO k = 1, 3
27233         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27234        END DO
27235        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27236        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27237        facd2 = d2 * vbld_inv(j+nres)
27238        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27239        DO k = 1, 3
27240         condor = (erhead_tail(k,2) &
27241        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27242
27243         gradpepcatx(k,i) = gradpepcatx(k,i) &
27244                    - dPOLdR2 * (erhead_tail(k,2) &
27245        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27246 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
27247 !                   + dPOLdR2 * condor
27248
27249         gradpepcat(k,i) = gradpepcat(k,i) &
27250                    - dPOLdR2 * erhead_tail(k,2)
27251         gradpepcat(k,j) = gradpepcat(k,j) &
27252                    + dPOLdR2 * erhead_tail(k,2)
27253
27254        END DO
27255       RETURN
27256       END SUBROUTINE enq_cat
27257
27258       SUBROUTINE eqd(Ecl,Elj,Epol)
27259       use calc_data
27260       use comm_momo
27261        double precision  facd4, federmaus,ecl,elj,epol
27262        alphapol1 = alphapol(itypi,itypj)
27263        w1        = wqdip(1,itypi,itypj)
27264        w2        = wqdip(2,itypi,itypj)
27265        pis       = sig0head(itypi,itypj)
27266        eps_head   = epshead(itypi,itypj)
27267 !c!-------------------------------------------------------------------
27268 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27269        R1 = 0.0d0
27270        DO k = 1, 3
27271 !c! Calculate head-to-tail distances
27272         R1=R1+(ctail(k,2)-chead(k,1))**2
27273        END DO
27274 !c! Pitagoras
27275        R1 = dsqrt(R1)
27276
27277 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27278 !c!     &        +dhead(1,1,itypi,itypj))**2))
27279 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27280 !c!     &        +dhead(2,1,itypi,itypj))**2))
27281
27282 !c!-------------------------------------------------------------------
27283 !c! ecl
27284        sparrow  = w1 * Qi * om1
27285        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27286        Ecl = sparrow / Rhead**2.0d0 &
27287            - hawk    / Rhead**4.0d0
27288        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27289                  + 4.0d0 * hawk    / Rhead**5.0d0
27290 !c! dF/dom1
27291        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27292 !c! dF/dom2
27293        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27294 !c--------------------------------------------------------------------
27295 !c Polarization energy
27296 !c Epol
27297        MomoFac1 = (1.0d0 - chi1 * sqom2)
27298        RR1  = R1 * R1 / MomoFac1
27299        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27300        fgb1 = sqrt( RR1 + a12sq * ee1)
27301        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27302 !c!       epol = 0.0d0
27303 !c!------------------------------------------------------------------
27304 !c! derivative of Epol is Gpol...
27305        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27306                / (fgb1 ** 5.0d0)
27307        dFGBdR1 = ( (R1 / MomoFac1)  &
27308              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27309              / ( 2.0d0 * fgb1 )
27310        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27311                * (2.0d0 - 0.5d0 * ee1) ) &
27312                / (2.0d0 * fgb1)
27313        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27314 !c!       dPOLdR1 = 0.0d0
27315        dPOLdOM1 = 0.0d0
27316        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27317 !c!       dPOLdOM2 = 0.0d0
27318 !c!-------------------------------------------------------------------
27319 !c! Elj
27320        pom = (pis / Rhead)**6.0d0
27321        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27322 !c! derivative of Elj is Glj
27323        dGLJdR = 4.0d0 * eps_head &
27324           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27325           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27326        DO k = 1, 3
27327         erhead(k) = Rhead_distance(k)/Rhead
27328         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27329        END DO
27330
27331        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27332        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27333        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27334        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27335        facd1 = d1 * vbld_inv(i+nres)
27336        facd2 = d2 * vbld_inv(j+nres)
27337        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27338
27339        DO k = 1, 3
27340         hawk = (erhead_tail(k,1) +  &
27341         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27342
27343         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27344         gvdwx(k,i) = gvdwx(k,i)  &
27345                    - dGCLdR * pom&
27346                    - dPOLdR1 * hawk &
27347                    - dGLJdR * pom
27348
27349         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27350         gvdwx(k,j) = gvdwx(k,j)    &
27351                    + dGCLdR * pom  &
27352                    + dPOLdR1 * (erhead_tail(k,1) &
27353        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27354                    + dGLJdR * pom
27355
27356
27357         gvdwc(k,i) = gvdwc(k,i)          &
27358                    - dGCLdR * erhead(k)  &
27359                    - dPOLdR1 * erhead_tail(k,1) &
27360                    - dGLJdR * erhead(k)
27361
27362         gvdwc(k,j) = gvdwc(k,j)          &
27363                    + dGCLdR * erhead(k)  &
27364                    + dPOLdR1 * erhead_tail(k,1) &
27365                    + dGLJdR * erhead(k)
27366
27367        END DO
27368        RETURN
27369       END SUBROUTINE eqd
27370       SUBROUTINE edq(Ecl,Elj,Epol)
27371 !       IMPLICIT NONE
27372        use comm_momo
27373       use calc_data
27374
27375       double precision  facd3, adler,ecl,elj,epol
27376        alphapol2 = alphapol(itypj,itypi)
27377        w1        = wqdip(1,itypi,itypj)
27378        w2        = wqdip(2,itypi,itypj)
27379        pis       = sig0head(itypi,itypj)
27380        eps_head  = epshead(itypi,itypj)
27381 !c!-------------------------------------------------------------------
27382 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27383        R2 = 0.0d0
27384        DO k = 1, 3
27385 !c! Calculate head-to-tail distances
27386         R2=R2+(chead(k,2)-ctail(k,1))**2
27387        END DO
27388 !c! Pitagoras
27389        R2 = dsqrt(R2)
27390
27391 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27392 !c!     &        +dhead(1,1,itypi,itypj))**2))
27393 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27394 !c!     &        +dhead(2,1,itypi,itypj))**2))
27395
27396
27397 !c!-------------------------------------------------------------------
27398 !c! ecl
27399        sparrow  = w1 * Qj * om1
27400        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27401        ECL = sparrow / Rhead**2.0d0 &
27402            - hawk    / Rhead**4.0d0
27403 !c!-------------------------------------------------------------------
27404 !c! derivative of ecl is Gcl
27405 !c! dF/dr part
27406        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27407                  + 4.0d0 * hawk    / Rhead**5.0d0
27408 !c! dF/dom1
27409        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27410 !c! dF/dom2
27411        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27412 !c--------------------------------------------------------------------
27413 !c Polarization energy
27414 !c Epol
27415        MomoFac2 = (1.0d0 - chi2 * sqom1)
27416        RR2  = R2 * R2 / MomoFac2
27417        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27418        fgb2 = sqrt(RR2  + a12sq * ee2)
27419        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27420        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27421                / (fgb2 ** 5.0d0)
27422        dFGBdR2 = ( (R2 / MomoFac2)  &
27423                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27424                / (2.0d0 * fgb2)
27425        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27426                 * (2.0d0 - 0.5d0 * ee2) ) &
27427                 / (2.0d0 * fgb2)
27428        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27429 !c!       dPOLdR2 = 0.0d0
27430        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27431 !c!       dPOLdOM1 = 0.0d0
27432        dPOLdOM2 = 0.0d0
27433 !c!-------------------------------------------------------------------
27434 !c! Elj
27435        pom = (pis / Rhead)**6.0d0
27436        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27437 !c! derivative of Elj is Glj
27438        dGLJdR = 4.0d0 * eps_head &
27439            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27440            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27441 !c!-------------------------------------------------------------------
27442 !c! Return the results
27443 !c! (see comments in Eqq)
27444        DO k = 1, 3
27445         erhead(k) = Rhead_distance(k)/Rhead
27446         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27447        END DO
27448        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27449        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27450        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27451        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27452        facd1 = d1 * vbld_inv(i+nres)
27453        facd2 = d2 * vbld_inv(j+nres)
27454        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27455        DO k = 1, 3
27456         condor = (erhead_tail(k,2) &
27457        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27458
27459         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27460         gvdwx(k,i) = gvdwx(k,i) &
27461                   - dGCLdR * pom &
27462                   - dPOLdR2 * (erhead_tail(k,2) &
27463        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27464                   - dGLJdR * pom
27465
27466         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27467         gvdwx(k,j) = gvdwx(k,j) &
27468                   + dGCLdR * pom &
27469                   + dPOLdR2 * condor &
27470                   + dGLJdR * pom
27471
27472
27473         gvdwc(k,i) = gvdwc(k,i) &
27474                   - dGCLdR * erhead(k) &
27475                   - dPOLdR2 * erhead_tail(k,2) &
27476                   - dGLJdR * erhead(k)
27477
27478         gvdwc(k,j) = gvdwc(k,j) &
27479                   + dGCLdR * erhead(k) &
27480                   + dPOLdR2 * erhead_tail(k,2) &
27481                   + dGLJdR * erhead(k)
27482
27483        END DO
27484        RETURN
27485       END SUBROUTINE edq
27486
27487       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27488       use comm_momo
27489       use calc_data
27490
27491       double precision  facd3, adler,ecl,elj,epol
27492        alphapol2 = alphapolcat(itypj,itypi)
27493        w1        = wqdipcat(1,itypi,itypj)
27494        w2        = wqdipcat(2,itypi,itypj)
27495        pis       = sig0headcat(itypi,itypj)
27496        eps_head  = epsheadcat(itypi,itypj)
27497 !c!-------------------------------------------------------------------
27498 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27499        R2 = 0.0d0
27500        DO k = 1, 3
27501 !c! Calculate head-to-tail distances
27502         R2=R2+(chead(k,2)-ctail(k,1))**2
27503        END DO
27504 !c! Pitagoras
27505        R2 = dsqrt(R2)
27506
27507 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27508 !c!     &        +dhead(1,1,itypi,itypj))**2))
27509 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27510 !c!     &        +dhead(2,1,itypi,itypj))**2))
27511
27512
27513 !c!-------------------------------------------------------------------
27514 !c! ecl
27515        sparrow  = w1 * Qj * om1
27516        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27517        ECL = sparrow / Rhead**2.0d0 &
27518            - hawk    / Rhead**4.0d0
27519 !c!-------------------------------------------------------------------
27520 !c! derivative of ecl is Gcl
27521 !c! dF/dr part
27522        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27523                  + 4.0d0 * hawk    / Rhead**5.0d0
27524 !c! dF/dom1
27525        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27526 !c! dF/dom2
27527        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27528 !c--------------------------------------------------------------------
27529 !c--------------------------------------------------------------------
27530 !c Polarization energy
27531 !c Epol
27532        MomoFac2 = (1.0d0 - chi2 * sqom1)
27533        RR2  = R2 * R2 / MomoFac2
27534        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27535        fgb2 = sqrt(RR2  + a12sq * ee2)
27536        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27537        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27538                / (fgb2 ** 5.0d0)
27539        dFGBdR2 = ( (R2 / MomoFac2)  &
27540                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27541                / (2.0d0 * fgb2)
27542        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27543                 * (2.0d0 - 0.5d0 * ee2) ) &
27544                 / (2.0d0 * fgb2)
27545        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27546 !c!       dPOLdR2 = 0.0d0
27547        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27548 !c!       dPOLdOM1 = 0.0d0
27549        dPOLdOM2 = 0.0d0
27550 !c!-------------------------------------------------------------------
27551 !c! Elj
27552        pom = (pis / Rhead)**6.0d0
27553        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27554 !c! derivative of Elj is Glj
27555        dGLJdR = 4.0d0 * eps_head &
27556            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27557            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27558 !c!-------------------------------------------------------------------
27559
27560 !c! Return the results
27561 !c! (see comments in Eqq)
27562        DO k = 1, 3
27563         erhead(k) = Rhead_distance(k)/Rhead
27564         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27565        END DO
27566        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27567        erdxj = scalar( erhead(1), dC_norm(1,j) )
27568        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27569        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27570        facd1 = d1 * vbld_inv(i+nres)
27571        facd2 = d2 * vbld_inv(j)
27572        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27573        DO k = 1, 3
27574         condor = (erhead_tail(k,2) &
27575        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27576
27577         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27578         gradpepcatx(k,i) = gradpepcatx(k,i) &
27579                   - dGCLdR * pom &
27580                   - dPOLdR2 * (erhead_tail(k,2) &
27581        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27582                   - dGLJdR * pom
27583
27584         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27585 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27586 !                  + dGCLdR * pom &
27587 !                  + dPOLdR2 * condor &
27588 !                  + dGLJdR * pom
27589
27590
27591         gradpepcat(k,i) = gradpepcat(k,i) &
27592                   - dGCLdR * erhead(k) &
27593                   - dPOLdR2 * erhead_tail(k,2) &
27594                   - dGLJdR * erhead(k)
27595
27596         gradpepcat(k,j) = gradpepcat(k,j) &
27597                   + dGCLdR * erhead(k) &
27598                   + dPOLdR2 * erhead_tail(k,2) &
27599                   + dGLJdR * erhead(k)
27600
27601        END DO
27602        RETURN
27603       END SUBROUTINE edq_cat
27604
27605       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27606       use comm_momo
27607       use calc_data
27608
27609       double precision  facd3, adler,ecl,elj,epol
27610        alphapol2 = alphapolcat(itypj,itypi)
27611        w1        = wqdipcat(1,itypi,itypj)
27612        w2        = wqdipcat(2,itypi,itypj)
27613        pis       = sig0headcat(itypi,itypj)
27614        eps_head  = epsheadcat(itypi,itypj)
27615 !c!-------------------------------------------------------------------
27616 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27617        R2 = 0.0d0
27618        DO k = 1, 3
27619 !c! Calculate head-to-tail distances
27620         R2=R2+(chead(k,2)-ctail(k,1))**2
27621        END DO
27622 !c! Pitagoras
27623        R2 = dsqrt(R2)
27624
27625 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27626 !c!     &        +dhead(1,1,itypi,itypj))**2))
27627 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27628 !c!     &        +dhead(2,1,itypi,itypj))**2))
27629
27630
27631 !c!-------------------------------------------------------------------
27632 !c! ecl
27633        sparrow  = w1 * Qj * om1
27634        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27635        print *,"CO?!.", w1,w2,Qj,om1
27636        ECL = sparrow / Rhead**2.0d0 &
27637            - hawk    / Rhead**4.0d0
27638 !c!-------------------------------------------------------------------
27639 !c! derivative of ecl is Gcl
27640 !c! dF/dr part
27641        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27642                  + 4.0d0 * hawk    / Rhead**5.0d0
27643 !c! dF/dom1
27644        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27645 !c! dF/dom2
27646        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27647 !c--------------------------------------------------------------------
27648 !c--------------------------------------------------------------------
27649 !c Polarization energy
27650 !c Epol
27651        MomoFac2 = (1.0d0 - chi2 * sqom1)
27652        RR2  = R2 * R2 / MomoFac2
27653        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27654        fgb2 = sqrt(RR2  + a12sq * ee2)
27655        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27656        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27657                / (fgb2 ** 5.0d0)
27658        dFGBdR2 = ( (R2 / MomoFac2)  &
27659                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27660                / (2.0d0 * fgb2)
27661        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27662                 * (2.0d0 - 0.5d0 * ee2) ) &
27663                 / (2.0d0 * fgb2)
27664        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27665 !c!       dPOLdR2 = 0.0d0
27666        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27667 !c!       dPOLdOM1 = 0.0d0
27668        dPOLdOM2 = 0.0d0
27669 !c!-------------------------------------------------------------------
27670 !c! Elj
27671        pom = (pis / Rhead)**6.0d0
27672        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27673 !c! derivative of Elj is Glj
27674        dGLJdR = 4.0d0 * eps_head &
27675            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27676            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27677 !c!-------------------------------------------------------------------
27678
27679 !c! Return the results
27680 !c! (see comments in Eqq)
27681        DO k = 1, 3
27682         erhead(k) = Rhead_distance(k)/Rhead
27683         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27684        END DO
27685        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27686        erdxj = scalar( erhead(1), dC_norm(1,j) )
27687        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27688        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27689        facd1 = d1 * vbld_inv(i+1)/2.0
27690        facd2 = d2 * vbld_inv(j)
27691        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27692        DO k = 1, 3
27693         condor = (erhead_tail(k,2) &
27694        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27695
27696         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27697 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27698 !                  - dGCLdR * pom &
27699 !                  - dPOLdR2 * (erhead_tail(k,2) &
27700 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27701 !                  - dGLJdR * pom
27702
27703         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27704 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27705 !                  + dGCLdR * pom &
27706 !                  + dPOLdR2 * condor &
27707 !                  + dGLJdR * pom
27708
27709
27710         gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27711                   - dGCLdR * erhead(k) &
27712                   - dPOLdR2 * erhead_tail(k,2) &
27713                   - dGLJdR * erhead(k))
27714         gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27715                   - dGCLdR * erhead(k) &
27716                   - dPOLdR2 * erhead_tail(k,2) &
27717                   - dGLJdR * erhead(k))
27718
27719
27720         gradpepcat(k,j) = gradpepcat(k,j) &
27721                   + dGCLdR * erhead(k) &
27722                   + dPOLdR2 * erhead_tail(k,2) &
27723                   + dGLJdR * erhead(k)
27724
27725        END DO
27726        RETURN
27727       END SUBROUTINE edq_cat_pep
27728
27729       SUBROUTINE edd(ECL)
27730 !       IMPLICIT NONE
27731        use comm_momo
27732       use calc_data
27733
27734        double precision ecl
27735 !c!       csig = sigiso(itypi,itypj)
27736        w1 = wqdip(1,itypi,itypj)
27737        w2 = wqdip(2,itypi,itypj)
27738 !c!-------------------------------------------------------------------
27739 !c! ECL
27740        fac = (om12 - 3.0d0 * om1 * om2)
27741        c1 = (w1 / (Rhead**3.0d0)) * fac
27742        c2 = (w2 / Rhead ** 6.0d0) &
27743           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27744        ECL = c1 - c2
27745 !c!       write (*,*) "w1 = ", w1
27746 !c!       write (*,*) "w2 = ", w2
27747 !c!       write (*,*) "om1 = ", om1
27748 !c!       write (*,*) "om2 = ", om2
27749 !c!       write (*,*) "om12 = ", om12
27750 !c!       write (*,*) "fac = ", fac
27751 !c!       write (*,*) "c1 = ", c1
27752 !c!       write (*,*) "c2 = ", c2
27753 !c!       write (*,*) "Ecl = ", Ecl
27754 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27755 !c!       write (*,*) "c2_2 = ",
27756 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27757 !c!-------------------------------------------------------------------
27758 !c! dervative of ECL is GCL...
27759 !c! dECL/dr
27760        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27761        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27762           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27763        dGCLdR = c1 - c2
27764 !c! dECL/dom1
27765        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27766        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27767           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27768        dGCLdOM1 = c1 - c2
27769 !c! dECL/dom2
27770        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27771        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27772           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27773        dGCLdOM2 = c1 - c2
27774 !c! dECL/dom12
27775        c1 = w1 / (Rhead ** 3.0d0)
27776        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27777        dGCLdOM12 = c1 - c2
27778 !c!-------------------------------------------------------------------
27779 !c! Return the results
27780 !c! (see comments in Eqq)
27781        DO k= 1, 3
27782         erhead(k) = Rhead_distance(k)/Rhead
27783        END DO
27784        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27785        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27786        facd1 = d1 * vbld_inv(i+nres)
27787        facd2 = d2 * vbld_inv(j+nres)
27788        DO k = 1, 3
27789
27790         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27791         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27792         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27793         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27794
27795         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27796         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27797        END DO
27798        RETURN
27799       END SUBROUTINE edd
27800       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27801 !       IMPLICIT NONE
27802        use comm_momo
27803       use calc_data
27804
27805        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27806        eps_out=80.0d0
27807        itypi = itype(i,1)
27808        itypj = itype(j,1)
27809 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27810 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27811 !c!       t_bath = 300
27812 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27813        Rb=0.001986d0
27814        BetaT = 1.0d0 / (298.0d0 * Rb)
27815 !c! Gay-berne var's
27816        sig0ij = sigma( itypi,itypj )
27817        chi1   = chi( itypi, itypj )
27818        chi2   = chi( itypj, itypi )
27819        chi12  = chi1 * chi2
27820        chip1  = chipp( itypi, itypj )
27821        chip2  = chipp( itypj, itypi )
27822        chip12 = chip1 * chip2
27823 !       chi1=0.0
27824 !       chi2=0.0
27825 !       chi12=0.0
27826 !       chip1=0.0
27827 !       chip2=0.0
27828 !       chip12=0.0
27829 !c! not used by momo potential, but needed by sc_angular which is shared
27830 !c! by all energy_potential subroutines
27831        alf1   = 0.0d0
27832        alf2   = 0.0d0
27833        alf12  = 0.0d0
27834 !c! location, location, location
27835 !       xj  = c( 1, nres+j ) - xi
27836 !       yj  = c( 2, nres+j ) - yi
27837 !       zj  = c( 3, nres+j ) - zi
27838        dxj = dc_norm( 1, nres+j )
27839        dyj = dc_norm( 2, nres+j )
27840        dzj = dc_norm( 3, nres+j )
27841 !c! distance from center of chain(?) to polar/charged head
27842 !c!       write (*,*) "istate = ", 1
27843 !c!       write (*,*) "ii = ", 1
27844 !c!       write (*,*) "jj = ", 1
27845        d1 = dhead(1, 1, itypi, itypj)
27846        d2 = dhead(2, 1, itypi, itypj)
27847 !c! ai*aj from Fgb
27848        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27849 !c!       a12sq = a12sq * a12sq
27850 !c! charge of amino acid itypi is...
27851        Qi  = icharge(itypi)
27852        Qj  = icharge(itypj)
27853        Qij = Qi * Qj
27854 !c! chis1,2,12
27855        chis1 = chis(itypi,itypj)
27856        chis2 = chis(itypj,itypi)
27857        chis12 = chis1 * chis2
27858        sig1 = sigmap1(itypi,itypj)
27859        sig2 = sigmap2(itypi,itypj)
27860 !c!       write (*,*) "sig1 = ", sig1
27861 !c!       write (*,*) "sig2 = ", sig2
27862 !c! alpha factors from Fcav/Gcav
27863        b1cav = alphasur(1,itypi,itypj)
27864 !       b1cav=0.0
27865        b2cav = alphasur(2,itypi,itypj)
27866        b3cav = alphasur(3,itypi,itypj)
27867        b4cav = alphasur(4,itypi,itypj)
27868        wqd = wquad(itypi, itypj)
27869 !c! used by Fgb
27870        eps_in = epsintab(itypi,itypj)
27871        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27872 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27873 !c!-------------------------------------------------------------------
27874 !c! tail location and distance calculations
27875        Rtail = 0.0d0
27876        DO k = 1, 3
27877         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27878         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27879        END DO
27880 !c! tail distances will be themselves usefull elswhere
27881 !c1 (in Gcav, for example)
27882        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27883        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27884        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27885        Rtail = dsqrt(  &
27886           (Rtail_distance(1)*Rtail_distance(1))  &
27887         + (Rtail_distance(2)*Rtail_distance(2))  &
27888         + (Rtail_distance(3)*Rtail_distance(3)))
27889 !c!-------------------------------------------------------------------
27890 !c! Calculate location and distance between polar heads
27891 !c! distance between heads
27892 !c! for each one of our three dimensional space...
27893        d1 = dhead(1, 1, itypi, itypj)
27894        d2 = dhead(2, 1, itypi, itypj)
27895
27896        DO k = 1,3
27897 !c! location of polar head is computed by taking hydrophobic centre
27898 !c! and moving by a d1 * dc_norm vector
27899 !c! see unres publications for very informative images
27900         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27901         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27902 !c! distance
27903 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27904 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27905         Rhead_distance(k) = chead(k,2) - chead(k,1)
27906        END DO
27907 !c! pitagoras (root of sum of squares)
27908        Rhead = dsqrt(   &
27909           (Rhead_distance(1)*Rhead_distance(1)) &
27910         + (Rhead_distance(2)*Rhead_distance(2)) &
27911         + (Rhead_distance(3)*Rhead_distance(3)))
27912 !c!-------------------------------------------------------------------
27913 !c! zero everything that should be zero'ed
27914        Egb = 0.0d0
27915        ECL = 0.0d0
27916        Elj = 0.0d0
27917        Equad = 0.0d0
27918        Epol = 0.0d0
27919        eheadtail = 0.0d0
27920        dGCLdOM1 = 0.0d0
27921        dGCLdOM2 = 0.0d0
27922        dGCLdOM12 = 0.0d0
27923        dPOLdOM1 = 0.0d0
27924        dPOLdOM2 = 0.0d0
27925        RETURN
27926       END SUBROUTINE elgrad_init
27927
27928
27929       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27930       use comm_momo
27931       use calc_data
27932        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27933        eps_out=80.0d0
27934        itypi = itype(i,1)
27935        itypj = itype(j,5)
27936 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27937 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27938 !c!       t_bath = 300
27939 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27940        Rb=0.001986d0
27941        BetaT = 1.0d0 / (298.0d0 * Rb)
27942 !c! Gay-berne var's
27943        sig0ij = sigmacat( itypi,itypj )
27944        chi1   = chicat( itypi, itypj )
27945        chi2   = 0.0d0
27946        chi12  = 0.0d0
27947        chip1  = chippcat( itypi, itypj )
27948        chip2  = 0.0d0
27949        chip12 = 0.0d0
27950 !c! not used by momo potential, but needed by sc_angular which is shared
27951 !c! by all energy_potential subroutines
27952        alf1   = 0.0d0
27953        alf2   = 0.0d0
27954        alf12  = 0.0d0
27955        dxj = dc_norm( 1, nres+j )
27956        dyj = dc_norm( 2, nres+j )
27957        dzj = dc_norm( 3, nres+j )
27958 !c! distance from center of chain(?) to polar/charged head
27959        d1 = dheadcat(1, 1, itypi, itypj)
27960        d2 = dheadcat(2, 1, itypi, itypj)
27961 !c! ai*aj from Fgb
27962        a12sq = rborncat(itypi,itypj) * rborncat(itypj,itypi)
27963 !c!       a12sq = a12sq * a12sq
27964 !c! charge of amino acid itypi is...
27965        Qi  = icharge(itypi)
27966        Qj  = ichargecat(itypj)
27967        Qij = Qi * Qj
27968 !c! chis1,2,12
27969        chis1 = chiscat(itypi,itypj)
27970        chis2 = 0.0d0
27971        chis12 = 0.0d0
27972        sig1 = sigmap1cat(itypi,itypj)
27973        sig2 = sigmap2cat(itypi,itypj)
27974 !c! alpha factors from Fcav/Gcav
27975        b1cav = alphasurcat(1,itypi,itypj)
27976        b2cav = alphasurcat(2,itypi,itypj)
27977        b3cav = alphasurcat(3,itypi,itypj)
27978        b4cav = alphasurcat(4,itypi,itypj)
27979        wqd = wquadcat(itypi, itypj)
27980 !c! used by Fgb
27981        eps_in = epsintabcat(itypi,itypj)
27982        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27983 !c!-------------------------------------------------------------------
27984 !c! tail location and distance calculations
27985        Rtail = 0.0d0
27986        DO k = 1, 3
27987         ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27988         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27989        END DO
27990 !c! tail distances will be themselves usefull elswhere
27991 !c1 (in Gcav, for example)
27992        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27993        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27994        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27995        Rtail = dsqrt(  &
27996           (Rtail_distance(1)*Rtail_distance(1))  &
27997         + (Rtail_distance(2)*Rtail_distance(2))  &
27998         + (Rtail_distance(3)*Rtail_distance(3)))
27999 !c!-------------------------------------------------------------------
28000 !c! Calculate location and distance between polar heads
28001 !c! distance between heads
28002 !c! for each one of our three dimensional space...
28003        d1 = dheadcat(1, 1, itypi, itypj)
28004        d2 = dheadcat(2, 1, itypi, itypj)
28005
28006        DO k = 1,3
28007 !c! location of polar head is computed by taking hydrophobic centre
28008 !c! and moving by a d1 * dc_norm vector
28009 !c! see unres publications for very informative images
28010         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28011         chead(k,2) = c(k, j)
28012 !c! distance
28013 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28014 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28015         Rhead_distance(k) = chead(k,2) - chead(k,1)
28016        END DO
28017 !c! pitagoras (root of sum of squares)
28018        Rhead = dsqrt(   &
28019           (Rhead_distance(1)*Rhead_distance(1)) &
28020         + (Rhead_distance(2)*Rhead_distance(2)) &
28021         + (Rhead_distance(3)*Rhead_distance(3)))
28022 !c!-------------------------------------------------------------------
28023 !c! zero everything that should be zero'ed
28024        Egb = 0.0d0
28025        ECL = 0.0d0
28026        Elj = 0.0d0
28027        Equad = 0.0d0
28028        Epol = 0.0d0
28029        eheadtail = 0.0d0
28030        dGCLdOM1 = 0.0d0
28031        dGCLdOM2 = 0.0d0
28032        dGCLdOM12 = 0.0d0
28033        dPOLdOM1 = 0.0d0
28034        dPOLdOM2 = 0.0d0
28035        RETURN
28036       END SUBROUTINE elgrad_init_cat
28037
28038       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28039       use comm_momo
28040       use calc_data
28041        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28042        eps_out=80.0d0
28043        itypi = 10
28044        itypj = itype(j,5)
28045 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28046 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28047 !c!       t_bath = 300
28048 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28049        Rb=0.001986d0
28050        BetaT = 1.0d0 / (298.0d0 * Rb)
28051 !c! Gay-berne var's
28052        sig0ij = sigmacat( itypi,itypj )
28053        chi1   = chicat( itypi, itypj )
28054        chi2   = 0.0d0
28055        chi12  = 0.0d0
28056        chip1  = chippcat( itypi, itypj )
28057        chip2  = 0.0d0
28058        chip12 = 0.0d0
28059 !c! not used by momo potential, but needed by sc_angular which is shared
28060 !c! by all energy_potential subroutines
28061        alf1   = 0.0d0
28062        alf2   = 0.0d0
28063        alf12  = 0.0d0
28064        dxj = 0.0d0 !dc_norm( 1, nres+j )
28065        dyj = 0.0d0 !dc_norm( 2, nres+j )
28066        dzj = 0.0d0 !dc_norm( 3, nres+j )
28067 !c! distance from center of chain(?) to polar/charged head
28068        d1 = dheadcat(1, 1, itypi, itypj)
28069        d2 = dheadcat(2, 1, itypi, itypj)
28070 !c! ai*aj from Fgb
28071        a12sq = rborncat(itypi,itypj) * rborncat(itypj,itypi)
28072 !c!       a12sq = a12sq * a12sq
28073 !c! charge of amino acid itypi is...
28074        Qi  = 0
28075        Qj  = ichargecat(itypj)
28076 !       Qij = Qi * Qj
28077 !c! chis1,2,12
28078        chis1 = chiscat(itypi,itypj)
28079        chis2 = 0.0d0
28080        chis12 = 0.0d0
28081        sig1 = sigmap1cat(itypi,itypj)
28082        sig2 = sigmap2cat(itypi,itypj)
28083 !c! alpha factors from Fcav/Gcav
28084        b1cav = alphasurcat(1,itypi,itypj)
28085        b2cav = alphasurcat(2,itypi,itypj)
28086        b3cav = alphasurcat(3,itypi,itypj)
28087        b4cav = alphasurcat(4,itypi,itypj)
28088        wqd = wquadcat(itypi, itypj)
28089 !c! used by Fgb
28090        eps_in = epsintabcat(itypi,itypj)
28091        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28092 !c!-------------------------------------------------------------------
28093 !c! tail location and distance calculations
28094        Rtail = 0.0d0
28095        DO k = 1, 3
28096         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28097         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28098        END DO
28099 !c! tail distances will be themselves usefull elswhere
28100 !c1 (in Gcav, for example)
28101        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28102        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28103        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28104        Rtail = dsqrt(  &
28105           (Rtail_distance(1)*Rtail_distance(1))  &
28106         + (Rtail_distance(2)*Rtail_distance(2))  &
28107         + (Rtail_distance(3)*Rtail_distance(3)))
28108 !c!-------------------------------------------------------------------
28109 !c! Calculate location and distance between polar heads
28110 !c! distance between heads
28111 !c! for each one of our three dimensional space...
28112        d1 = dheadcat(1, 1, itypi, itypj)
28113        d2 = dheadcat(2, 1, itypi, itypj)
28114
28115        DO k = 1,3
28116 !c! location of polar head is computed by taking hydrophobic centre
28117 !c! and moving by a d1 * dc_norm vector
28118 !c! see unres publications for very informative images
28119         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28120         chead(k,2) = c(k, j)
28121 !c! distance
28122 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28123 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28124         Rhead_distance(k) = chead(k,2) - chead(k,1)
28125        END DO
28126 !c! pitagoras (root of sum of squares)
28127        Rhead = dsqrt(   &
28128           (Rhead_distance(1)*Rhead_distance(1)) &
28129         + (Rhead_distance(2)*Rhead_distance(2)) &
28130         + (Rhead_distance(3)*Rhead_distance(3)))
28131 !c!-------------------------------------------------------------------
28132 !c! zero everything that should be zero'ed
28133        Egb = 0.0d0
28134        ECL = 0.0d0
28135        Elj = 0.0d0
28136        Equad = 0.0d0
28137        Epol = 0.0d0
28138        eheadtail = 0.0d0
28139        dGCLdOM1 = 0.0d0
28140        dGCLdOM2 = 0.0d0
28141        dGCLdOM12 = 0.0d0
28142        dPOLdOM1 = 0.0d0
28143        dPOLdOM2 = 0.0d0
28144        RETURN
28145       END SUBROUTINE elgrad_init_cat_pep
28146
28147       double precision function tschebyshev(m,n,x,y)
28148       implicit none
28149       integer i,m,n
28150       double precision x(n),y,yy(0:maxvar),aux
28151 !c Tschebyshev polynomial. Note that the first term is omitted
28152 !c m=0: the constant term is included
28153 !c m=1: the constant term is not included
28154       yy(0)=1.0d0
28155       yy(1)=y
28156       do i=2,n
28157         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28158       enddo
28159       aux=0.0d0
28160       do i=m,n
28161         aux=aux+x(i)*yy(i)
28162       enddo
28163       tschebyshev=aux
28164       return
28165       end function tschebyshev
28166 !C--------------------------------------------------------------------------
28167       double precision function gradtschebyshev(m,n,x,y)
28168       implicit none
28169       integer i,m,n
28170       double precision x(n+1),y,yy(0:maxvar),aux
28171 !c Tschebyshev polynomial. Note that the first term is omitted
28172 !c m=0: the constant term is included
28173 !c m=1: the constant term is not included
28174       yy(0)=1.0d0
28175       yy(1)=2.0d0*y
28176       do i=2,n
28177         yy(i)=2*y*yy(i-1)-yy(i-2)
28178       enddo
28179       aux=0.0d0
28180       do i=m,n
28181         aux=aux+x(i+1)*yy(i)*(i+1)
28182 !C        print *, x(i+1),yy(i),i
28183       enddo
28184       gradtschebyshev=aux
28185       return
28186       end function gradtschebyshev
28187
28188
28189
28190
28191
28192       end module energy