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 !      implicit real*8 (a-h,o-z)
11900       use calc_data
11901 !      include 'DIMENSIONS'
11902 !      include 'COMMON.CHAIN'
11903 !      include 'COMMON.DERIV'
11904 !      include 'COMMON.CALC'
11905 !      include 'COMMON.IOUNITS'
11906       real(kind=8), dimension(3) :: dcosom1,dcosom2
11907 !      print *,"wchodze"
11908       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11909           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11910       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11911           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11912
11913       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11914            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11915            +dCAVdOM12+ dGCLdOM12
11916 ! diagnostics only
11917 !      eom1=0.0d0
11918 !      eom2=0.0d0
11919 !      eom12=evdwij*eps1_om12
11920 ! end diagnostics
11921 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11922 !       " sigder",sigder
11923 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11924 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11925 !C      print *,sss_ele_cut,'in sc_grad'
11926
11927       do k=1,3
11928         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11929         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11930       enddo
11931       do k=1,3
11932         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11933 !C      print *,'gg',k,gg(k)
11934        enddo
11935 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11936 !      write (iout,*) "gg",(gg(k),k=1,3)
11937       do k=1,3
11938         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11939                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11940                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11941
11942 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11943 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11944 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11945
11946 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11947 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11948 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11949 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11950       enddo
11951 !
11952 ! Calculate the components of the gradient in DC and X
11953 !
11954 !grad      do k=i,j-1
11955 !grad        do l=1,3
11956 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11957 !grad        enddo
11958 !grad      enddo
11959       do l=1,3
11960         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11961         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11962       enddo
11963       end subroutine sc_grad_cat
11964
11965
11966 #ifdef CRYST_THETA
11967 !-----------------------------------------------------------------------------
11968       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11969
11970       use comm_calcthet
11971 !      implicit real*8 (a-h,o-z)
11972 !      include 'DIMENSIONS'
11973 !      include 'COMMON.LOCAL'
11974 !      include 'COMMON.IOUNITS'
11975 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11976 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11977 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11978       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11979       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11980 !el      integer :: it
11981 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11982 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11983 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11984 !el local variables
11985
11986       delthec=thetai-thet_pred_mean
11987       delthe0=thetai-theta0i
11988 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11989       t3 = thetai-thet_pred_mean
11990       t6 = t3**2
11991       t9 = term1
11992       t12 = t3*sigcsq
11993       t14 = t12+t6*sigsqtc
11994       t16 = 1.0d0
11995       t21 = thetai-theta0i
11996       t23 = t21**2
11997       t26 = term2
11998       t27 = t21*t26
11999       t32 = termexp
12000       t40 = t32**2
12001       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12002        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12003        *(-t12*t9-ak*sig0inv*t27)
12004       return
12005       end subroutine mixder
12006 #endif
12007 !-----------------------------------------------------------------------------
12008 ! cartder.F
12009 !-----------------------------------------------------------------------------
12010       subroutine cartder
12011 !-----------------------------------------------------------------------------
12012 ! This subroutine calculates the derivatives of the consecutive virtual
12013 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12014 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12015 ! in the angles alpha and omega, describing the location of a side chain
12016 ! in its local coordinate system.
12017 !
12018 ! The derivatives are stored in the following arrays:
12019 !
12020 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12021 ! The structure is as follows:
12022 !
12023 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12024 ! 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)
12025 !         . . . . . . . . . . . .  . . . . . .
12026 ! 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)
12027 !                          .
12028 !                          .
12029 !                          .
12030 ! 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)
12031 !
12032 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12033 ! The structure is same as above.
12034 !
12035 ! DCDS - the derivatives of the side chain vectors in the local spherical
12036 ! andgles alph and omega:
12037 !
12038 ! 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)
12039 ! 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)
12040 !                          .
12041 !                          .
12042 !                          .
12043 ! 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)
12044 !
12045 ! Version of March '95, based on an early version of November '91.
12046 !
12047 !**********************************************************************
12048 !      implicit real*8 (a-h,o-z)
12049 !      include 'DIMENSIONS'
12050 !      include 'COMMON.VAR'
12051 !      include 'COMMON.CHAIN'
12052 !      include 'COMMON.DERIV'
12053 !      include 'COMMON.GEO'
12054 !      include 'COMMON.LOCAL'
12055 !      include 'COMMON.INTERACT'
12056       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12057       real(kind=8),dimension(3,3) :: dp,temp
12058 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12059       real(kind=8),dimension(3) :: xx,xx1
12060 !el local variables
12061       integer :: i,k,l,j,m,ind,ind1,jjj
12062       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12063                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12064                  sint2,xp,yp,xxp,yyp,zzp,dj
12065
12066 !      common /przechowalnia/ fromto
12067       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12068 ! get the position of the jth ijth fragment of the chain coordinate system
12069 ! in the fromto array.
12070 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12071 !
12072 !      maxdim=(nres-1)*(nres-2)/2
12073 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12074 ! calculate the derivatives of transformation matrix elements in theta
12075 !
12076
12077 !el      call flush(iout) !el
12078       do i=1,nres-2
12079         rdt(1,1,i)=-rt(1,2,i)
12080         rdt(1,2,i)= rt(1,1,i)
12081         rdt(1,3,i)= 0.0d0
12082         rdt(2,1,i)=-rt(2,2,i)
12083         rdt(2,2,i)= rt(2,1,i)
12084         rdt(2,3,i)= 0.0d0
12085         rdt(3,1,i)=-rt(3,2,i)
12086         rdt(3,2,i)= rt(3,1,i)
12087         rdt(3,3,i)= 0.0d0
12088       enddo
12089 !
12090 ! derivatives in phi
12091 !
12092       do i=2,nres-2
12093         drt(1,1,i)= 0.0d0
12094         drt(1,2,i)= 0.0d0
12095         drt(1,3,i)= 0.0d0
12096         drt(2,1,i)= rt(3,1,i)
12097         drt(2,2,i)= rt(3,2,i)
12098         drt(2,3,i)= rt(3,3,i)
12099         drt(3,1,i)=-rt(2,1,i)
12100         drt(3,2,i)=-rt(2,2,i)
12101         drt(3,3,i)=-rt(2,3,i)
12102       enddo
12103 !
12104 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12105 !
12106       do i=2,nres-2
12107         ind=indmat(i,i+1)
12108         do k=1,3
12109           do l=1,3
12110             temp(k,l)=rt(k,l,i)
12111           enddo
12112         enddo
12113         do k=1,3
12114           do l=1,3
12115             fromto(k,l,ind)=temp(k,l)
12116           enddo
12117         enddo
12118         do j=i+1,nres-2
12119           ind=indmat(i,j+1)
12120           do k=1,3
12121             do l=1,3
12122               dpkl=0.0d0
12123               do m=1,3
12124                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12125               enddo
12126               dp(k,l)=dpkl
12127               fromto(k,l,ind)=dpkl
12128             enddo
12129           enddo
12130           do k=1,3
12131             do l=1,3
12132               temp(k,l)=dp(k,l)
12133             enddo
12134           enddo
12135         enddo
12136       enddo
12137 !
12138 ! Calculate derivatives.
12139 !
12140       ind1=0
12141       do i=1,nres-2
12142       ind1=ind1+1
12143 !
12144 ! Derivatives of DC(i+1) in theta(i+2)
12145 !
12146         do j=1,3
12147           do k=1,2
12148             dpjk=0.0D0
12149             do l=1,3
12150               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12151             enddo
12152             dp(j,k)=dpjk
12153             prordt(j,k,i)=dp(j,k)
12154           enddo
12155           dp(j,3)=0.0D0
12156           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12157         enddo
12158 !
12159 ! Derivatives of SC(i+1) in theta(i+2)
12160 !
12161         xx1(1)=-0.5D0*xloc(2,i+1)
12162         xx1(2)= 0.5D0*xloc(1,i+1)
12163         do j=1,3
12164           xj=0.0D0
12165           do k=1,2
12166             xj=xj+r(j,k,i)*xx1(k)
12167           enddo
12168           xx(j)=xj
12169         enddo
12170         do j=1,3
12171           rj=0.0D0
12172           do k=1,3
12173             rj=rj+prod(j,k,i)*xx(k)
12174           enddo
12175           dxdv(j,ind1)=rj
12176         enddo
12177 !
12178 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12179 ! than the other off-diagonal derivatives.
12180 !
12181         do j=1,3
12182           dxoiij=0.0D0
12183           do k=1,3
12184             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12185           enddo
12186           dxdv(j,ind1+1)=dxoiij
12187         enddo
12188 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12189 !
12190 ! Derivatives of DC(i+1) in phi(i+2)
12191 !
12192         do j=1,3
12193           do k=1,3
12194             dpjk=0.0
12195             do l=2,3
12196               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12197             enddo
12198             dp(j,k)=dpjk
12199             prodrt(j,k,i)=dp(j,k)
12200           enddo
12201           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12202         enddo
12203 !
12204 ! Derivatives of SC(i+1) in phi(i+2)
12205 !
12206         xx(1)= 0.0D0
12207         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12208         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12209         do j=1,3
12210           rj=0.0D0
12211           do k=2,3
12212             rj=rj+prod(j,k,i)*xx(k)
12213           enddo
12214           dxdv(j+3,ind1)=-rj
12215         enddo
12216 !
12217 ! Derivatives of SC(i+1) in phi(i+3).
12218 !
12219         do j=1,3
12220           dxoiij=0.0D0
12221           do k=1,3
12222             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12223           enddo
12224           dxdv(j+3,ind1+1)=dxoiij
12225         enddo
12226 !
12227 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12228 ! theta(nres) and phi(i+3) thru phi(nres).
12229 !
12230         do j=i+1,nres-2
12231         ind1=ind1+1
12232         ind=indmat(i+1,j+1)
12233 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12234           do k=1,3
12235             do l=1,3
12236               tempkl=0.0D0
12237               do m=1,2
12238                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12239               enddo
12240               temp(k,l)=tempkl
12241             enddo
12242           enddo
12243 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12244 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12245 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12246 ! Derivatives of virtual-bond vectors in theta
12247           do k=1,3
12248             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12249           enddo
12250 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12251 ! Derivatives of SC vectors in theta
12252           do k=1,3
12253             dxoijk=0.0D0
12254             do l=1,3
12255               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12256             enddo
12257             dxdv(k,ind1+1)=dxoijk
12258           enddo
12259 !
12260 !--- Calculate the derivatives in phi
12261 !
12262           do k=1,3
12263             do l=1,3
12264               tempkl=0.0D0
12265               do m=1,3
12266                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12267               enddo
12268               temp(k,l)=tempkl
12269             enddo
12270           enddo
12271           do k=1,3
12272             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12273         enddo
12274           do k=1,3
12275             dxoijk=0.0D0
12276             do l=1,3
12277               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12278             enddo
12279             dxdv(k+3,ind1+1)=dxoijk
12280           enddo
12281         enddo
12282       enddo
12283 !
12284 ! Derivatives in alpha and omega:
12285 !
12286       do i=2,nres-1
12287 !       dsci=dsc(itype(i,1))
12288         dsci=vbld(i+nres)
12289 #ifdef OSF
12290         alphi=alph(i)
12291         omegi=omeg(i)
12292         if(alphi.ne.alphi) alphi=100.0
12293         if(omegi.ne.omegi) omegi=-100.0
12294 #else
12295       alphi=alph(i)
12296       omegi=omeg(i)
12297 #endif
12298 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12299       cosalphi=dcos(alphi)
12300       sinalphi=dsin(alphi)
12301       cosomegi=dcos(omegi)
12302       sinomegi=dsin(omegi)
12303       temp(1,1)=-dsci*sinalphi
12304       temp(2,1)= dsci*cosalphi*cosomegi
12305       temp(3,1)=-dsci*cosalphi*sinomegi
12306       temp(1,2)=0.0D0
12307       temp(2,2)=-dsci*sinalphi*sinomegi
12308       temp(3,2)=-dsci*sinalphi*cosomegi
12309       theta2=pi-0.5D0*theta(i+1)
12310       cost2=dcos(theta2)
12311       sint2=dsin(theta2)
12312       jjj=0
12313 !d      print *,((temp(l,k),l=1,3),k=1,2)
12314         do j=1,2
12315         xp=temp(1,j)
12316         yp=temp(2,j)
12317         xxp= xp*cost2+yp*sint2
12318         yyp=-xp*sint2+yp*cost2
12319         zzp=temp(3,j)
12320         xx(1)=xxp
12321         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12322         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12323         do k=1,3
12324           dj=0.0D0
12325           do l=1,3
12326             dj=dj+prod(k,l,i-1)*xx(l)
12327             enddo
12328           dxds(jjj+k,i)=dj
12329           enddo
12330         jjj=jjj+3
12331       enddo
12332       enddo
12333       return
12334       end subroutine cartder
12335 !-----------------------------------------------------------------------------
12336 ! checkder_p.F
12337 !-----------------------------------------------------------------------------
12338       subroutine check_cartgrad
12339 ! Check the gradient of Cartesian coordinates in internal coordinates.
12340 !      implicit real*8 (a-h,o-z)
12341 !      include 'DIMENSIONS'
12342 !      include 'COMMON.IOUNITS'
12343 !      include 'COMMON.VAR'
12344 !      include 'COMMON.CHAIN'
12345 !      include 'COMMON.GEO'
12346 !      include 'COMMON.LOCAL'
12347 !      include 'COMMON.DERIV'
12348       real(kind=8),dimension(6,nres) :: temp
12349       real(kind=8),dimension(3) :: xx,gg
12350       integer :: i,k,j,ii
12351       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12352 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12353 !
12354 ! Check the gradient of the virtual-bond and SC vectors in the internal
12355 ! coordinates.
12356 !
12357       aincr=1.0d-6
12358       aincr2=5.0d-7
12359       call cartder
12360       write (iout,'(a)') '**************** dx/dalpha'
12361       write (iout,'(a)')
12362       do i=2,nres-1
12363       alphi=alph(i)
12364       alph(i)=alph(i)+aincr
12365       do k=1,3
12366         temp(k,i)=dc(k,nres+i)
12367         enddo
12368       call chainbuild
12369       do k=1,3
12370         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12371         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12372         enddo
12373         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12374         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12375         write (iout,'(a)')
12376       alph(i)=alphi
12377       call chainbuild
12378       enddo
12379       write (iout,'(a)')
12380       write (iout,'(a)') '**************** dx/domega'
12381       write (iout,'(a)')
12382       do i=2,nres-1
12383       omegi=omeg(i)
12384       omeg(i)=omeg(i)+aincr
12385       do k=1,3
12386         temp(k,i)=dc(k,nres+i)
12387         enddo
12388       call chainbuild
12389       do k=1,3
12390           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12391           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12392                 (aincr*dabs(dxds(k+3,i))+aincr))
12393         enddo
12394         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12395             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12396         write (iout,'(a)')
12397       omeg(i)=omegi
12398       call chainbuild
12399       enddo
12400       write (iout,'(a)')
12401       write (iout,'(a)') '**************** dx/dtheta'
12402       write (iout,'(a)')
12403       do i=3,nres
12404       theti=theta(i)
12405         theta(i)=theta(i)+aincr
12406         do j=i-1,nres-1
12407           do k=1,3
12408             temp(k,j)=dc(k,nres+j)
12409           enddo
12410         enddo
12411         call chainbuild
12412         do j=i-1,nres-1
12413         ii = indmat(i-2,j)
12414 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12415         do k=1,3
12416           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12417           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12418                   (aincr*dabs(dxdv(k,ii))+aincr))
12419           enddo
12420           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12421               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12422           write(iout,'(a)')
12423         enddo
12424         write (iout,'(a)')
12425         theta(i)=theti
12426         call chainbuild
12427       enddo
12428       write (iout,'(a)') '***************** dx/dphi'
12429       write (iout,'(a)')
12430       do i=4,nres
12431         phi(i)=phi(i)+aincr
12432         do j=i-1,nres-1
12433           do k=1,3
12434             temp(k,j)=dc(k,nres+j)
12435           enddo
12436         enddo
12437         call chainbuild
12438         do j=i-1,nres-1
12439         ii = indmat(i-2,j)
12440 !         print *,'ii=',ii
12441         do k=1,3
12442           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12443             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12444                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12445           enddo
12446           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12447               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12448           write(iout,'(a)')
12449         enddo
12450         phi(i)=phi(i)-aincr
12451         call chainbuild
12452       enddo
12453       write (iout,'(a)') '****************** ddc/dtheta'
12454       do i=1,nres-2
12455         thet=theta(i+2)
12456         theta(i+2)=thet+aincr
12457         do j=i,nres
12458           do k=1,3
12459             temp(k,j)=dc(k,j)
12460           enddo
12461         enddo
12462         call chainbuild
12463         do j=i+1,nres-1
12464         ii = indmat(i,j)
12465 !         print *,'ii=',ii
12466         do k=1,3
12467           gg(k)=(dc(k,j)-temp(k,j))/aincr
12468           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12469                  (aincr*dabs(dcdv(k,ii))+aincr))
12470           enddo
12471           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12472                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12473         write (iout,'(a)')
12474         enddo
12475         do j=1,nres
12476           do k=1,3
12477             dc(k,j)=temp(k,j)
12478           enddo
12479         enddo
12480         theta(i+2)=thet
12481       enddo
12482       write (iout,'(a)') '******************* ddc/dphi'
12483       do i=1,nres-3
12484         phii=phi(i+3)
12485         phi(i+3)=phii+aincr
12486         do j=1,nres
12487           do k=1,3
12488             temp(k,j)=dc(k,j)
12489           enddo
12490         enddo
12491         call chainbuild
12492         do j=i+2,nres-1
12493         ii = indmat(i+1,j)
12494 !         print *,'ii=',ii
12495         do k=1,3
12496           gg(k)=(dc(k,j)-temp(k,j))/aincr
12497             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12498                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12499           enddo
12500           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12501                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12502         write (iout,'(a)')
12503         enddo
12504         do j=1,nres
12505           do k=1,3
12506             dc(k,j)=temp(k,j)
12507           enddo
12508         enddo
12509         phi(i+3)=phii
12510       enddo
12511       return
12512       end subroutine check_cartgrad
12513 !-----------------------------------------------------------------------------
12514       subroutine check_ecart
12515 ! Check the gradient of the energy in Cartesian coordinates.
12516 !     implicit real*8 (a-h,o-z)
12517 !     include 'DIMENSIONS'
12518 !     include 'COMMON.CHAIN'
12519 !     include 'COMMON.DERIV'
12520 !     include 'COMMON.IOUNITS'
12521 !     include 'COMMON.VAR'
12522 !     include 'COMMON.CONTACTS'
12523       use comm_srutu
12524 !el      integer :: icall
12525 !el      common /srutu/ icall
12526       real(kind=8),dimension(6) :: ggg
12527       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12528       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12529       real(kind=8),dimension(6,nres) :: grad_s
12530       real(kind=8),dimension(0:n_ene) :: energia,energia1
12531       integer :: uiparm(1)
12532       real(kind=8) :: urparm(1)
12533 !EL      external fdum
12534       integer :: nf,i,j,k
12535       real(kind=8) :: aincr,etot,etot1
12536       icg=1
12537       nf=0
12538       nfl=0
12539       call zerograd
12540       aincr=1.0D-5
12541       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12542       nf=0
12543       icall=0
12544       call geom_to_var(nvar,x)
12545       call etotal(energia)
12546       etot=energia(0)
12547 !el      call enerprint(energia)
12548       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12549       icall =1
12550       do i=1,nres
12551         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12552       enddo
12553       do i=1,nres
12554       do j=1,3
12555         grad_s(j,i)=gradc(j,i,icg)
12556         grad_s(j+3,i)=gradx(j,i,icg)
12557         enddo
12558       enddo
12559       call flush(iout)
12560       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12561       do i=1,nres
12562         do j=1,3
12563         xx(j)=c(j,i+nres)
12564         ddc(j)=dc(j,i)
12565         ddx(j)=dc(j,i+nres)
12566         enddo
12567       do j=1,3
12568         dc(j,i)=dc(j,i)+aincr
12569         do k=i+1,nres
12570           c(j,k)=c(j,k)+aincr
12571           c(j,k+nres)=c(j,k+nres)+aincr
12572           enddo
12573           call zerograd
12574           call etotal(energia1)
12575           etot1=energia1(0)
12576         ggg(j)=(etot1-etot)/aincr
12577         dc(j,i)=ddc(j)
12578         do k=i+1,nres
12579           c(j,k)=c(j,k)-aincr
12580           c(j,k+nres)=c(j,k+nres)-aincr
12581           enddo
12582         enddo
12583       do j=1,3
12584         c(j,i+nres)=c(j,i+nres)+aincr
12585         dc(j,i+nres)=dc(j,i+nres)+aincr
12586           call zerograd
12587           call etotal(energia1)
12588           etot1=energia1(0)
12589         ggg(j+3)=(etot1-etot)/aincr
12590         c(j,i+nres)=xx(j)
12591         dc(j,i+nres)=ddx(j)
12592         enddo
12593       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12594          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12595       enddo
12596       return
12597       end subroutine check_ecart
12598 #ifdef CARGRAD
12599 !-----------------------------------------------------------------------------
12600       subroutine check_ecartint
12601 ! Check the gradient of the energy in Cartesian coordinates.
12602       use io_base, only: intout
12603 !      implicit real*8 (a-h,o-z)
12604 !      include 'DIMENSIONS'
12605 !      include 'COMMON.CONTROL'
12606 !      include 'COMMON.CHAIN'
12607 !      include 'COMMON.DERIV'
12608 !      include 'COMMON.IOUNITS'
12609 !      include 'COMMON.VAR'
12610 !      include 'COMMON.CONTACTS'
12611 !      include 'COMMON.MD'
12612 !      include 'COMMON.LOCAL'
12613 !      include 'COMMON.SPLITELE'
12614       use comm_srutu
12615 !el      integer :: icall
12616 !el      common /srutu/ icall
12617       real(kind=8),dimension(6) :: ggg,ggg1
12618       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12619       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12620       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12621       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12622       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12623       real(kind=8),dimension(0:n_ene) :: energia,energia1
12624       integer :: uiparm(1)
12625       real(kind=8) :: urparm(1)
12626 !EL      external fdum
12627       integer :: i,j,k,nf
12628       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12629                    etot21,etot22
12630       r_cut=2.0d0
12631       rlambd=0.3d0
12632       icg=1
12633       nf=0
12634       nfl=0
12635       call intout
12636 !      call intcartderiv
12637 !      call checkintcartgrad
12638       call zerograd
12639       aincr=1.0D-4
12640       write(iout,*) 'Calling CHECK_ECARTINT.'
12641       nf=0
12642       icall=0
12643       call geom_to_var(nvar,x)
12644       write (iout,*) "split_ene ",split_ene
12645       call flush(iout)
12646       if (.not.split_ene) then
12647         call zerograd
12648         call etotal(energia)
12649         etot=energia(0)
12650         call cartgrad
12651         icall =1
12652         do i=1,nres
12653           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12654         enddo
12655         do j=1,3
12656           grad_s(j,0)=gcart(j,0)
12657         enddo
12658         do i=1,nres
12659           do j=1,3
12660             grad_s(j,i)=gcart(j,i)
12661             grad_s(j+3,i)=gxcart(j,i)
12662           enddo
12663         enddo
12664       else
12665 !- split gradient check
12666         call zerograd
12667         call etotal_long(energia)
12668 !el        call enerprint(energia)
12669         call cartgrad
12670         icall =1
12671         do i=1,nres
12672           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12673           (gxcart(j,i),j=1,3)
12674         enddo
12675         do j=1,3
12676           grad_s(j,0)=gcart(j,0)
12677         enddo
12678         do i=1,nres
12679           do j=1,3
12680             grad_s(j,i)=gcart(j,i)
12681             grad_s(j+3,i)=gxcart(j,i)
12682           enddo
12683         enddo
12684         call zerograd
12685         call etotal_short(energia)
12686         call enerprint(energia)
12687         call cartgrad
12688         icall =1
12689         do i=1,nres
12690           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12691           (gxcart(j,i),j=1,3)
12692         enddo
12693         do j=1,3
12694           grad_s1(j,0)=gcart(j,0)
12695         enddo
12696         do i=1,nres
12697           do j=1,3
12698             grad_s1(j,i)=gcart(j,i)
12699             grad_s1(j+3,i)=gxcart(j,i)
12700           enddo
12701         enddo
12702       endif
12703       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12704 !      do i=1,nres
12705       do i=nnt,nct
12706         do j=1,3
12707           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12708           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12709         ddc(j)=c(j,i)
12710         ddx(j)=c(j,i+nres)
12711           dcnorm_safe1(j)=dc_norm(j,i-1)
12712           dcnorm_safe2(j)=dc_norm(j,i)
12713           dxnorm_safe(j)=dc_norm(j,i+nres)
12714         enddo
12715       do j=1,3
12716         c(j,i)=ddc(j)+aincr
12717           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12718           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12719           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12720           dc(j,i)=c(j,i+1)-c(j,i)
12721           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12722           call int_from_cart1(.false.)
12723           if (.not.split_ene) then
12724            call zerograd
12725             call etotal(energia1)
12726             etot1=energia1(0)
12727             write (iout,*) "ij",i,j," etot1",etot1
12728           else
12729 !- split gradient
12730             call etotal_long(energia1)
12731             etot11=energia1(0)
12732             call etotal_short(energia1)
12733             etot12=energia1(0)
12734           endif
12735 !- end split gradient
12736 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12737         c(j,i)=ddc(j)-aincr
12738           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12739           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12740           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12741           dc(j,i)=c(j,i+1)-c(j,i)
12742           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12743           call int_from_cart1(.false.)
12744           if (.not.split_ene) then
12745             call zerograd
12746             call etotal(energia1)
12747             etot2=energia1(0)
12748             write (iout,*) "ij",i,j," etot2",etot2
12749           ggg(j)=(etot1-etot2)/(2*aincr)
12750           else
12751 !- split gradient
12752             call etotal_long(energia1)
12753             etot21=energia1(0)
12754           ggg(j)=(etot11-etot21)/(2*aincr)
12755             call etotal_short(energia1)
12756             etot22=energia1(0)
12757           ggg1(j)=(etot12-etot22)/(2*aincr)
12758 !- end split gradient
12759 !            write (iout,*) "etot21",etot21," etot22",etot22
12760           endif
12761 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12762         c(j,i)=ddc(j)
12763           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12764           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12765           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12766           dc(j,i)=c(j,i+1)-c(j,i)
12767           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12768           dc_norm(j,i-1)=dcnorm_safe1(j)
12769           dc_norm(j,i)=dcnorm_safe2(j)
12770           dc_norm(j,i+nres)=dxnorm_safe(j)
12771         enddo
12772       do j=1,3
12773         c(j,i+nres)=ddx(j)+aincr
12774           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12775           call int_from_cart1(.false.)
12776           if (.not.split_ene) then
12777             call zerograd
12778             call etotal(energia1)
12779             etot1=energia1(0)
12780           else
12781 !- split gradient
12782             call etotal_long(energia1)
12783             etot11=energia1(0)
12784             call etotal_short(energia1)
12785             etot12=energia1(0)
12786           endif
12787 !- end split gradient
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             etot2=energia1(0)
12795           ggg(j+3)=(etot1-etot2)/(2*aincr)
12796           else
12797 !- split gradient
12798             call etotal_long(energia1)
12799             etot21=energia1(0)
12800           ggg(j+3)=(etot11-etot21)/(2*aincr)
12801             call etotal_short(energia1)
12802             etot22=energia1(0)
12803           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12804 !- end split gradient
12805           endif
12806 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12807         c(j,i+nres)=ddx(j)
12808           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12809           dc_norm(j,i+nres)=dxnorm_safe(j)
12810           call int_from_cart1(.false.)
12811         enddo
12812       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12813          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12814         if (split_ene) then
12815           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12816          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12817          k=1,6)
12818          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12819          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12820          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12821         endif
12822       enddo
12823       return
12824       end subroutine check_ecartint
12825 #else
12826 !-----------------------------------------------------------------------------
12827       subroutine check_ecartint
12828 ! Check the gradient of the energy in Cartesian coordinates.
12829       use io_base, only: intout
12830 !      implicit real*8 (a-h,o-z)
12831 !      include 'DIMENSIONS'
12832 !      include 'COMMON.CONTROL'
12833 !      include 'COMMON.CHAIN'
12834 !      include 'COMMON.DERIV'
12835 !      include 'COMMON.IOUNITS'
12836 !      include 'COMMON.VAR'
12837 !      include 'COMMON.CONTACTS'
12838 !      include 'COMMON.MD'
12839 !      include 'COMMON.LOCAL'
12840 !      include 'COMMON.SPLITELE'
12841       use comm_srutu
12842 !el      integer :: icall
12843 !el      common /srutu/ icall
12844       real(kind=8),dimension(6) :: ggg,ggg1
12845       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12846       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12847       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12848       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12849       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12850       real(kind=8),dimension(0:n_ene) :: energia,energia1
12851       integer :: uiparm(1)
12852       real(kind=8) :: urparm(1)
12853 !EL      external fdum
12854       integer :: i,j,k,nf
12855       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12856                    etot21,etot22
12857       r_cut=2.0d0
12858       rlambd=0.3d0
12859       icg=1
12860       nf=0
12861       nfl=0
12862       call intout
12863 !      call intcartderiv
12864 !      call checkintcartgrad
12865       call zerograd
12866       aincr=1.0D-7
12867       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12868       nf=0
12869       icall=0
12870       call geom_to_var(nvar,x)
12871       if (.not.split_ene) then
12872         call etotal(energia)
12873         etot=energia(0)
12874 !el        call enerprint(energia)
12875         call cartgrad
12876         icall =1
12877         do i=1,nres
12878           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12879         enddo
12880         do j=1,3
12881           grad_s(j,0)=gcart(j,0)
12882         enddo
12883         do i=1,nres
12884           do j=1,3
12885             grad_s(j,i)=gcart(j,i)
12886 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12887
12888 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12889             grad_s(j+3,i)=gxcart(j,i)
12890           enddo
12891         enddo
12892       else
12893 !- split gradient check
12894         call zerograd
12895         call etotal_long(energia)
12896 !el        call enerprint(energia)
12897         call cartgrad
12898         icall =1
12899         do i=1,nres
12900           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12901           (gxcart(j,i),j=1,3)
12902         enddo
12903         do j=1,3
12904           grad_s(j,0)=gcart(j,0)
12905         enddo
12906         do i=1,nres
12907           do j=1,3
12908             grad_s(j,i)=gcart(j,i)
12909 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12910             grad_s(j+3,i)=gxcart(j,i)
12911           enddo
12912         enddo
12913         call zerograd
12914         call etotal_short(energia)
12915 !el        call enerprint(energia)
12916         call cartgrad
12917         icall =1
12918         do i=1,nres
12919           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12920           (gxcart(j,i),j=1,3)
12921         enddo
12922         do j=1,3
12923           grad_s1(j,0)=gcart(j,0)
12924         enddo
12925         do i=1,nres
12926           do j=1,3
12927             grad_s1(j,i)=gcart(j,i)
12928             grad_s1(j+3,i)=gxcart(j,i)
12929           enddo
12930         enddo
12931       endif
12932       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12933       do i=0,nres
12934         do j=1,3
12935         xx(j)=c(j,i+nres)
12936         ddc(j)=dc(j,i)
12937         ddx(j)=dc(j,i+nres)
12938           do k=1,3
12939             dcnorm_safe(k)=dc_norm(k,i)
12940             dxnorm_safe(k)=dc_norm(k,i+nres)
12941           enddo
12942         enddo
12943       do j=1,3
12944         dc(j,i)=ddc(j)+aincr
12945           call chainbuild_cart
12946 #ifdef MPI
12947 ! Broadcast the order to compute internal coordinates to the slaves.
12948 !          if (nfgtasks.gt.1)
12949 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12950 #endif
12951 !          call int_from_cart1(.false.)
12952           if (.not.split_ene) then
12953            call zerograd
12954             call etotal(energia1)
12955             etot1=energia1(0)
12956 !            call enerprint(energia1)
12957           else
12958 !- split gradient
12959             call etotal_long(energia1)
12960             etot11=energia1(0)
12961             call etotal_short(energia1)
12962             etot12=energia1(0)
12963 !            write (iout,*) "etot11",etot11," etot12",etot12
12964           endif
12965 !- end split gradient
12966 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12967         dc(j,i)=ddc(j)-aincr
12968           call chainbuild_cart
12969 !          call int_from_cart1(.false.)
12970           if (.not.split_ene) then
12971                   call zerograd
12972             call etotal(energia1)
12973             etot2=energia1(0)
12974           ggg(j)=(etot1-etot2)/(2*aincr)
12975           else
12976 !- split gradient
12977             call etotal_long(energia1)
12978             etot21=energia1(0)
12979           ggg(j)=(etot11-etot21)/(2*aincr)
12980             call etotal_short(energia1)
12981             etot22=energia1(0)
12982           ggg1(j)=(etot12-etot22)/(2*aincr)
12983 !- end split gradient
12984 !            write (iout,*) "etot21",etot21," etot22",etot22
12985           endif
12986 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12987         dc(j,i)=ddc(j)
12988           call chainbuild_cart
12989         enddo
12990       do j=1,3
12991         dc(j,i+nres)=ddx(j)+aincr
12992           call chainbuild_cart
12993 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12994 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12995 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12996 !          write (iout,*) "dxnormnorm",dsqrt(
12997 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12998 !          write (iout,*) "dxnormnormsafe",dsqrt(
12999 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13000 !          write (iout,*)
13001           if (.not.split_ene) then
13002             call zerograd
13003             call etotal(energia1)
13004             etot1=energia1(0)
13005           else
13006 !- split gradient
13007             call etotal_long(energia1)
13008             etot11=energia1(0)
13009             call etotal_short(energia1)
13010             etot12=energia1(0)
13011           endif
13012 !- end split gradient
13013 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13014         dc(j,i+nres)=ddx(j)-aincr
13015           call chainbuild_cart
13016 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13017 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13018 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13019 !          write (iout,*)
13020 !          write (iout,*) "dxnormnorm",dsqrt(
13021 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13022 !          write (iout,*) "dxnormnormsafe",dsqrt(
13023 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13024           if (.not.split_ene) then
13025             call zerograd
13026             call etotal(energia1)
13027             etot2=energia1(0)
13028           ggg(j+3)=(etot1-etot2)/(2*aincr)
13029           else
13030 !- split gradient
13031             call etotal_long(energia1)
13032             etot21=energia1(0)
13033           ggg(j+3)=(etot11-etot21)/(2*aincr)
13034             call etotal_short(energia1)
13035             etot22=energia1(0)
13036           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13037 !- end split gradient
13038           endif
13039 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13040         dc(j,i+nres)=ddx(j)
13041           call chainbuild_cart
13042         enddo
13043       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13044          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13045         if (split_ene) then
13046           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13047          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13048          k=1,6)
13049          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13050          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13051          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13052         endif
13053       enddo
13054       return
13055       end subroutine check_ecartint
13056 #endif
13057 !-----------------------------------------------------------------------------
13058       subroutine check_eint
13059 ! Check the gradient of energy in internal coordinates.
13060 !      implicit real*8 (a-h,o-z)
13061 !      include 'DIMENSIONS'
13062 !      include 'COMMON.CHAIN'
13063 !      include 'COMMON.DERIV'
13064 !      include 'COMMON.IOUNITS'
13065 !      include 'COMMON.VAR'
13066 !      include 'COMMON.GEO'
13067       use comm_srutu
13068 !el      integer :: icall
13069 !el      common /srutu/ icall
13070       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13071       integer :: uiparm(1)
13072       real(kind=8) :: urparm(1)
13073       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13074       character(len=6) :: key
13075 !EL      external fdum
13076       integer :: i,ii,nf
13077       real(kind=8) :: xi,aincr,etot,etot1,etot2
13078       call zerograd
13079       aincr=1.0D-7
13080       print '(a)','Calling CHECK_INT.'
13081       nf=0
13082       nfl=0
13083       icg=1
13084       call geom_to_var(nvar,x)
13085       call var_to_geom(nvar,x)
13086       call chainbuild
13087       icall=1
13088 !      print *,'ICG=',ICG
13089       call etotal(energia)
13090       etot = energia(0)
13091 !el      call enerprint(energia)
13092 !      print *,'ICG=',ICG
13093 #ifdef MPL
13094       if (MyID.ne.BossID) then
13095         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13096         nf=x(nvar+1)
13097         nfl=x(nvar+2)
13098         icg=x(nvar+3)
13099       endif
13100 #endif
13101       nf=1
13102       nfl=3
13103 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13104       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13105 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13106       icall=1
13107       do i=1,nvar
13108         xi=x(i)
13109         x(i)=xi-0.5D0*aincr
13110         call var_to_geom(nvar,x)
13111         call chainbuild
13112         call etotal(energia1)
13113         etot1=energia1(0)
13114         x(i)=xi+0.5D0*aincr
13115         call var_to_geom(nvar,x)
13116         call chainbuild
13117         call etotal(energia2)
13118         etot2=energia2(0)
13119         gg(i)=(etot2-etot1)/aincr
13120         write (iout,*) i,etot1,etot2
13121         x(i)=xi
13122       enddo
13123       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13124           '     RelDiff*100% '
13125       do i=1,nvar
13126         if (i.le.nphi) then
13127           ii=i
13128           key = ' phi'
13129         else if (i.le.nphi+ntheta) then
13130           ii=i-nphi
13131           key=' theta'
13132         else if (i.le.nphi+ntheta+nside) then
13133            ii=i-(nphi+ntheta)
13134            key=' alpha'
13135         else
13136            ii=i-(nphi+ntheta+nside)
13137            key=' omega'
13138         endif
13139         write (iout,'(i3,a,i3,3(1pd16.6))') &
13140        i,key,ii,gg(i),gana(i),&
13141        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13142       enddo
13143       return
13144       end subroutine check_eint
13145 !-----------------------------------------------------------------------------
13146 ! econstr_local.F
13147 !-----------------------------------------------------------------------------
13148       subroutine Econstr_back
13149 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13150 !      implicit real*8 (a-h,o-z)
13151 !      include 'DIMENSIONS'
13152 !      include 'COMMON.CONTROL'
13153 !      include 'COMMON.VAR'
13154 !      include 'COMMON.MD'
13155       use MD_data
13156 !#ifndef LANG0
13157 !      include 'COMMON.LANGEVIN'
13158 !#else
13159 !      include 'COMMON.LANGEVIN.lang0'
13160 !#endif
13161 !      include 'COMMON.CHAIN'
13162 !      include 'COMMON.DERIV'
13163 !      include 'COMMON.GEO'
13164 !      include 'COMMON.LOCAL'
13165 !      include 'COMMON.INTERACT'
13166 !      include 'COMMON.IOUNITS'
13167 !      include 'COMMON.NAMES'
13168 !      include 'COMMON.TIME1'
13169       integer :: i,j,ii,k
13170       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13171
13172       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13173       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13174       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13175
13176       Uconst_back=0.0d0
13177       do i=1,nres
13178         dutheta(i)=0.0d0
13179         dugamma(i)=0.0d0
13180         do j=1,3
13181           duscdiff(j,i)=0.0d0
13182           duscdiffx(j,i)=0.0d0
13183         enddo
13184       enddo
13185       do i=1,nfrag_back
13186         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13187 !
13188 ! Deviations from theta angles
13189 !
13190         utheta_i=0.0d0
13191         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13192           dtheta_i=theta(j)-thetaref(j)
13193           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13194           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13195         enddo
13196         utheta(i)=utheta_i/(ii-1)
13197 !
13198 ! Deviations from gamma angles
13199 !
13200         ugamma_i=0.0d0
13201         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13202           dgamma_i=pinorm(phi(j)-phiref(j))
13203 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13204           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13205           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13206 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13207         enddo
13208         ugamma(i)=ugamma_i/(ii-2)
13209 !
13210 ! Deviations from local SC geometry
13211 !
13212         uscdiff(i)=0.0d0
13213         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13214           dxx=xxtab(j)-xxref(j)
13215           dyy=yytab(j)-yyref(j)
13216           dzz=zztab(j)-zzref(j)
13217           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13218           do k=1,3
13219             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13220              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13221              (ii-1)
13222             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13223              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13224              (ii-1)
13225             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13226            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13227             /(ii-1)
13228           enddo
13229 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13230 !     &      xxref(j),yyref(j),zzref(j)
13231         enddo
13232         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13233 !        write (iout,*) i," uscdiff",uscdiff(i)
13234 !
13235 ! Put together deviations from local geometry
13236 !
13237         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13238           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13239 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13240 !     &   " uconst_back",uconst_back
13241         utheta(i)=dsqrt(utheta(i))
13242         ugamma(i)=dsqrt(ugamma(i))
13243         uscdiff(i)=dsqrt(uscdiff(i))
13244       enddo
13245       return
13246       end subroutine Econstr_back
13247 !-----------------------------------------------------------------------------
13248 ! energy_p_new-sep_barrier.F
13249 !-----------------------------------------------------------------------------
13250       real(kind=8) function sscale(r)
13251 !      include "COMMON.SPLITELE"
13252       real(kind=8) :: r,gamm
13253       if(r.lt.r_cut-rlamb) then
13254         sscale=1.0d0
13255       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13256         gamm=(r-(r_cut-rlamb))/rlamb
13257         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13258       else
13259         sscale=0d0
13260       endif
13261       return
13262       end function sscale
13263       real(kind=8) function sscale_grad(r)
13264 !      include "COMMON.SPLITELE"
13265       real(kind=8) :: r,gamm
13266       if(r.lt.r_cut-rlamb) then
13267         sscale_grad=0.0d0
13268       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13269         gamm=(r-(r_cut-rlamb))/rlamb
13270         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13271       else
13272         sscale_grad=0d0
13273       endif
13274       return
13275       end function sscale_grad
13276
13277 !!!!!!!!!! PBCSCALE
13278       real(kind=8) function sscale_ele(r)
13279 !      include "COMMON.SPLITELE"
13280       real(kind=8) :: r,gamm
13281       if(r.lt.r_cut_ele-rlamb_ele) then
13282         sscale_ele=1.0d0
13283       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13284         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13285         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13286       else
13287         sscale_ele=0d0
13288       endif
13289       return
13290       end function sscale_ele
13291
13292       real(kind=8)  function sscagrad_ele(r)
13293       real(kind=8) :: r,gamm
13294 !      include "COMMON.SPLITELE"
13295       if(r.lt.r_cut_ele-rlamb_ele) then
13296         sscagrad_ele=0.0d0
13297       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13298         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13299         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13300       else
13301         sscagrad_ele=0.0d0
13302       endif
13303       return
13304       end function sscagrad_ele
13305       real(kind=8) function sscalelip(r)
13306       real(kind=8) r,gamm
13307         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13308       return
13309       end function sscalelip
13310 !C-----------------------------------------------------------------------
13311       real(kind=8) function sscagradlip(r)
13312       real(kind=8) r,gamm
13313         sscagradlip=r*(6.0d0*r-6.0d0)
13314       return
13315       end function sscagradlip
13316
13317 !!!!!!!!!!!!!!!
13318 !-----------------------------------------------------------------------------
13319       subroutine elj_long(evdw)
13320 !
13321 ! This subroutine calculates the interaction energy of nonbonded side chains
13322 ! assuming the LJ potential of interaction.
13323 !
13324 !      implicit real*8 (a-h,o-z)
13325 !      include 'DIMENSIONS'
13326 !      include 'COMMON.GEO'
13327 !      include 'COMMON.VAR'
13328 !      include 'COMMON.LOCAL'
13329 !      include 'COMMON.CHAIN'
13330 !      include 'COMMON.DERIV'
13331 !      include 'COMMON.INTERACT'
13332 !      include 'COMMON.TORSION'
13333 !      include 'COMMON.SBRIDGE'
13334 !      include 'COMMON.NAMES'
13335 !      include 'COMMON.IOUNITS'
13336 !      include 'COMMON.CONTACTS'
13337       real(kind=8),parameter :: accur=1.0d-10
13338       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13339 !el local variables
13340       integer :: i,iint,j,k,itypi,itypi1,itypj
13341       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13342       real(kind=8) :: e1,e2,evdwij,evdw
13343 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13344       evdw=0.0D0
13345       do i=iatsc_s,iatsc_e
13346         itypi=itype(i,1)
13347         if (itypi.eq.ntyp1) cycle
13348         itypi1=itype(i+1,1)
13349         xi=c(1,nres+i)
13350         yi=c(2,nres+i)
13351         zi=c(3,nres+i)
13352 !
13353 ! Calculate SC interaction energy.
13354 !
13355         do iint=1,nint_gr(i)
13356 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13357 !d   &                  'iend=',iend(i,iint)
13358           do j=istart(i,iint),iend(i,iint)
13359             itypj=itype(j,1)
13360             if (itypj.eq.ntyp1) cycle
13361             xj=c(1,nres+j)-xi
13362             yj=c(2,nres+j)-yi
13363             zj=c(3,nres+j)-zi
13364             rij=xj*xj+yj*yj+zj*zj
13365             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13366             if (sss.lt.1.0d0) then
13367               rrij=1.0D0/rij
13368               eps0ij=eps(itypi,itypj)
13369               fac=rrij**expon2
13370               e1=fac*fac*aa_aq(itypi,itypj)
13371               e2=fac*bb_aq(itypi,itypj)
13372               evdwij=e1+e2
13373               evdw=evdw+(1.0d0-sss)*evdwij
13374 !
13375 ! Calculate the components of the gradient in DC and X
13376 !
13377               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13378               gg(1)=xj*fac
13379               gg(2)=yj*fac
13380               gg(3)=zj*fac
13381               do k=1,3
13382                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13383                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13384                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13385                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13386               enddo
13387             endif
13388           enddo      ! j
13389         enddo        ! iint
13390       enddo          ! i
13391       do i=1,nct
13392         do j=1,3
13393           gvdwc(j,i)=expon*gvdwc(j,i)
13394           gvdwx(j,i)=expon*gvdwx(j,i)
13395         enddo
13396       enddo
13397 !******************************************************************************
13398 !
13399 !                              N O T E !!!
13400 !
13401 ! To save time, the factor of EXPON has been extracted from ALL components
13402 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13403 ! use!
13404 !
13405 !******************************************************************************
13406       return
13407       end subroutine elj_long
13408 !-----------------------------------------------------------------------------
13409       subroutine elj_short(evdw)
13410 !
13411 ! This subroutine calculates the interaction energy of nonbonded side chains
13412 ! assuming the LJ potential of interaction.
13413 !
13414 !      implicit real*8 (a-h,o-z)
13415 !      include 'DIMENSIONS'
13416 !      include 'COMMON.GEO'
13417 !      include 'COMMON.VAR'
13418 !      include 'COMMON.LOCAL'
13419 !      include 'COMMON.CHAIN'
13420 !      include 'COMMON.DERIV'
13421 !      include 'COMMON.INTERACT'
13422 !      include 'COMMON.TORSION'
13423 !      include 'COMMON.SBRIDGE'
13424 !      include 'COMMON.NAMES'
13425 !      include 'COMMON.IOUNITS'
13426 !      include 'COMMON.CONTACTS'
13427       real(kind=8),parameter :: accur=1.0d-10
13428       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13429 !el local variables
13430       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13431       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13432       real(kind=8) :: e1,e2,evdwij,evdw
13433 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13434       evdw=0.0D0
13435       do i=iatsc_s,iatsc_e
13436         itypi=itype(i,1)
13437         if (itypi.eq.ntyp1) cycle
13438         itypi1=itype(i+1,1)
13439         xi=c(1,nres+i)
13440         yi=c(2,nres+i)
13441         zi=c(3,nres+i)
13442 ! Change 12/1/95
13443         num_conti=0
13444 !
13445 ! Calculate SC interaction energy.
13446 !
13447         do iint=1,nint_gr(i)
13448 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13449 !d   &                  'iend=',iend(i,iint)
13450           do j=istart(i,iint),iend(i,iint)
13451             itypj=itype(j,1)
13452             if (itypj.eq.ntyp1) cycle
13453             xj=c(1,nres+j)-xi
13454             yj=c(2,nres+j)-yi
13455             zj=c(3,nres+j)-zi
13456 ! Change 12/1/95 to calculate four-body interactions
13457             rij=xj*xj+yj*yj+zj*zj
13458             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13459             if (sss.gt.0.0d0) then
13460               rrij=1.0D0/rij
13461               eps0ij=eps(itypi,itypj)
13462               fac=rrij**expon2
13463               e1=fac*fac*aa_aq(itypi,itypj)
13464               e2=fac*bb_aq(itypi,itypj)
13465               evdwij=e1+e2
13466               evdw=evdw+sss*evdwij
13467 !
13468 ! Calculate the components of the gradient in DC and X
13469 !
13470               fac=-rrij*(e1+evdwij)*sss
13471               gg(1)=xj*fac
13472               gg(2)=yj*fac
13473               gg(3)=zj*fac
13474               do k=1,3
13475                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13476                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13477                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13478                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13479               enddo
13480             endif
13481           enddo      ! j
13482         enddo        ! iint
13483       enddo          ! i
13484       do i=1,nct
13485         do j=1,3
13486           gvdwc(j,i)=expon*gvdwc(j,i)
13487           gvdwx(j,i)=expon*gvdwx(j,i)
13488         enddo
13489       enddo
13490 !******************************************************************************
13491 !
13492 !                              N O T E !!!
13493 !
13494 ! To save time, the factor of EXPON has been extracted from ALL components
13495 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13496 ! use!
13497 !
13498 !******************************************************************************
13499       return
13500       end subroutine elj_short
13501 !-----------------------------------------------------------------------------
13502       subroutine eljk_long(evdw)
13503 !
13504 ! This subroutine calculates the interaction energy of nonbonded side chains
13505 ! assuming the LJK potential of interaction.
13506 !
13507 !      implicit real*8 (a-h,o-z)
13508 !      include 'DIMENSIONS'
13509 !      include 'COMMON.GEO'
13510 !      include 'COMMON.VAR'
13511 !      include 'COMMON.LOCAL'
13512 !      include 'COMMON.CHAIN'
13513 !      include 'COMMON.DERIV'
13514 !      include 'COMMON.INTERACT'
13515 !      include 'COMMON.IOUNITS'
13516 !      include 'COMMON.NAMES'
13517       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13518       logical :: scheck
13519 !el local variables
13520       integer :: i,iint,j,k,itypi,itypi1,itypj
13521       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13522                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13523 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13524       evdw=0.0D0
13525       do i=iatsc_s,iatsc_e
13526         itypi=itype(i,1)
13527         if (itypi.eq.ntyp1) cycle
13528         itypi1=itype(i+1,1)
13529         xi=c(1,nres+i)
13530         yi=c(2,nres+i)
13531         zi=c(3,nres+i)
13532 !
13533 ! Calculate SC interaction energy.
13534 !
13535         do iint=1,nint_gr(i)
13536           do j=istart(i,iint),iend(i,iint)
13537             itypj=itype(j,1)
13538             if (itypj.eq.ntyp1) cycle
13539             xj=c(1,nres+j)-xi
13540             yj=c(2,nres+j)-yi
13541             zj=c(3,nres+j)-zi
13542             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13543             fac_augm=rrij**expon
13544             e_augm=augm(itypi,itypj)*fac_augm
13545             r_inv_ij=dsqrt(rrij)
13546             rij=1.0D0/r_inv_ij
13547             sss=sscale(rij/sigma(itypi,itypj))
13548             if (sss.lt.1.0d0) then
13549               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13550               fac=r_shift_inv**expon
13551               e1=fac*fac*aa_aq(itypi,itypj)
13552               e2=fac*bb_aq(itypi,itypj)
13553               evdwij=e_augm+e1+e2
13554 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13555 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13556 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13557 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13558 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13559 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13560 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13561               evdw=evdw+(1.0d0-sss)*evdwij
13562 !
13563 ! Calculate the components of the gradient in DC and X
13564 !
13565               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13566               fac=fac*(1.0d0-sss)
13567               gg(1)=xj*fac
13568               gg(2)=yj*fac
13569               gg(3)=zj*fac
13570               do k=1,3
13571                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13572                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13573                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13574                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13575               enddo
13576             endif
13577           enddo      ! j
13578         enddo        ! iint
13579       enddo          ! i
13580       do i=1,nct
13581         do j=1,3
13582           gvdwc(j,i)=expon*gvdwc(j,i)
13583           gvdwx(j,i)=expon*gvdwx(j,i)
13584         enddo
13585       enddo
13586       return
13587       end subroutine eljk_long
13588 !-----------------------------------------------------------------------------
13589       subroutine eljk_short(evdw)
13590 !
13591 ! This subroutine calculates the interaction energy of nonbonded side chains
13592 ! assuming the LJK potential of interaction.
13593 !
13594 !      implicit real*8 (a-h,o-z)
13595 !      include 'DIMENSIONS'
13596 !      include 'COMMON.GEO'
13597 !      include 'COMMON.VAR'
13598 !      include 'COMMON.LOCAL'
13599 !      include 'COMMON.CHAIN'
13600 !      include 'COMMON.DERIV'
13601 !      include 'COMMON.INTERACT'
13602 !      include 'COMMON.IOUNITS'
13603 !      include 'COMMON.NAMES'
13604       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13605       logical :: scheck
13606 !el local variables
13607       integer :: i,iint,j,k,itypi,itypi1,itypj
13608       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13609                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13610 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13611       evdw=0.0D0
13612       do i=iatsc_s,iatsc_e
13613         itypi=itype(i,1)
13614         if (itypi.eq.ntyp1) cycle
13615         itypi1=itype(i+1,1)
13616         xi=c(1,nres+i)
13617         yi=c(2,nres+i)
13618         zi=c(3,nres+i)
13619 !
13620 ! Calculate SC interaction energy.
13621 !
13622         do iint=1,nint_gr(i)
13623           do j=istart(i,iint),iend(i,iint)
13624             itypj=itype(j,1)
13625             if (itypj.eq.ntyp1) cycle
13626             xj=c(1,nres+j)-xi
13627             yj=c(2,nres+j)-yi
13628             zj=c(3,nres+j)-zi
13629             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13630             fac_augm=rrij**expon
13631             e_augm=augm(itypi,itypj)*fac_augm
13632             r_inv_ij=dsqrt(rrij)
13633             rij=1.0D0/r_inv_ij
13634             sss=sscale(rij/sigma(itypi,itypj))
13635             if (sss.gt.0.0d0) then
13636               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13637               fac=r_shift_inv**expon
13638               e1=fac*fac*aa_aq(itypi,itypj)
13639               e2=fac*bb_aq(itypi,itypj)
13640               evdwij=e_augm+e1+e2
13641 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13642 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13643 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13644 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13645 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13646 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13647 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13648               evdw=evdw+sss*evdwij
13649 !
13650 ! Calculate the components of the gradient in DC and X
13651 !
13652               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13653               fac=fac*sss
13654               gg(1)=xj*fac
13655               gg(2)=yj*fac
13656               gg(3)=zj*fac
13657               do k=1,3
13658                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13659                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13660                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13661                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13662               enddo
13663             endif
13664           enddo      ! j
13665         enddo        ! iint
13666       enddo          ! i
13667       do i=1,nct
13668         do j=1,3
13669           gvdwc(j,i)=expon*gvdwc(j,i)
13670           gvdwx(j,i)=expon*gvdwx(j,i)
13671         enddo
13672       enddo
13673       return
13674       end subroutine eljk_short
13675 !-----------------------------------------------------------------------------
13676       subroutine ebp_long(evdw)
13677 !
13678 ! This subroutine calculates the interaction energy of nonbonded side chains
13679 ! assuming the Berne-Pechukas potential of interaction.
13680 !
13681       use calc_data
13682 !      implicit real*8 (a-h,o-z)
13683 !      include 'DIMENSIONS'
13684 !      include 'COMMON.GEO'
13685 !      include 'COMMON.VAR'
13686 !      include 'COMMON.LOCAL'
13687 !      include 'COMMON.CHAIN'
13688 !      include 'COMMON.DERIV'
13689 !      include 'COMMON.NAMES'
13690 !      include 'COMMON.INTERACT'
13691 !      include 'COMMON.IOUNITS'
13692 !      include 'COMMON.CALC'
13693       use comm_srutu
13694 !el      integer :: icall
13695 !el      common /srutu/ icall
13696 !     double precision rrsave(maxdim)
13697       logical :: lprn
13698 !el local variables
13699       integer :: iint,itypi,itypi1,itypj
13700       real(kind=8) :: rrij,xi,yi,zi,fac
13701       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13702       evdw=0.0D0
13703 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13704       evdw=0.0D0
13705 !     if (icall.eq.0) then
13706 !       lprn=.true.
13707 !     else
13708         lprn=.false.
13709 !     endif
13710 !el      ind=0
13711       do i=iatsc_s,iatsc_e
13712         itypi=itype(i,1)
13713         if (itypi.eq.ntyp1) cycle
13714         itypi1=itype(i+1,1)
13715         xi=c(1,nres+i)
13716         yi=c(2,nres+i)
13717         zi=c(3,nres+i)
13718         dxi=dc_norm(1,nres+i)
13719         dyi=dc_norm(2,nres+i)
13720         dzi=dc_norm(3,nres+i)
13721 !        dsci_inv=dsc_inv(itypi)
13722         dsci_inv=vbld_inv(i+nres)
13723 !
13724 ! Calculate SC interaction energy.
13725 !
13726         do iint=1,nint_gr(i)
13727           do j=istart(i,iint),iend(i,iint)
13728 !el            ind=ind+1
13729             itypj=itype(j,1)
13730             if (itypj.eq.ntyp1) cycle
13731 !            dscj_inv=dsc_inv(itypj)
13732             dscj_inv=vbld_inv(j+nres)
13733             chi1=chi(itypi,itypj)
13734             chi2=chi(itypj,itypi)
13735             chi12=chi1*chi2
13736             chip1=chip(itypi)
13737             chip2=chip(itypj)
13738             chip12=chip1*chip2
13739             alf1=alp(itypi)
13740             alf2=alp(itypj)
13741             alf12=0.5D0*(alf1+alf2)
13742             xj=c(1,nres+j)-xi
13743             yj=c(2,nres+j)-yi
13744             zj=c(3,nres+j)-zi
13745             dxj=dc_norm(1,nres+j)
13746             dyj=dc_norm(2,nres+j)
13747             dzj=dc_norm(3,nres+j)
13748             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13749             rij=dsqrt(rrij)
13750             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13751
13752             if (sss.lt.1.0d0) then
13753
13754 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13755               call sc_angular
13756 ! Calculate whole angle-dependent part of epsilon and contributions
13757 ! to its derivatives
13758               fac=(rrij*sigsq)**expon2
13759               e1=fac*fac*aa_aq(itypi,itypj)
13760               e2=fac*bb_aq(itypi,itypj)
13761               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13762               eps2der=evdwij*eps3rt
13763               eps3der=evdwij*eps2rt
13764               evdwij=evdwij*eps2rt*eps3rt
13765               evdw=evdw+evdwij*(1.0d0-sss)
13766               if (lprn) then
13767               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13768               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13769 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13770 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13771 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13772 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13773 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13774 !d     &          evdwij
13775               endif
13776 ! Calculate gradient components.
13777               e1=e1*eps1*eps2rt**2*eps3rt**2
13778               fac=-expon*(e1+evdwij)
13779               sigder=fac/sigsq
13780               fac=rrij*fac
13781 ! Calculate radial part of the gradient
13782               gg(1)=xj*fac
13783               gg(2)=yj*fac
13784               gg(3)=zj*fac
13785 ! Calculate the angular part of the gradient and sum add the contributions
13786 ! to the appropriate components of the Cartesian gradient.
13787               call sc_grad_scale(1.0d0-sss)
13788             endif
13789           enddo      ! j
13790         enddo        ! iint
13791       enddo          ! i
13792 !     stop
13793       return
13794       end subroutine ebp_long
13795 !-----------------------------------------------------------------------------
13796       subroutine ebp_short(evdw)
13797 !
13798 ! This subroutine calculates the interaction energy of nonbonded side chains
13799 ! assuming the Berne-Pechukas potential of interaction.
13800 !
13801       use calc_data
13802 !      implicit real*8 (a-h,o-z)
13803 !      include 'DIMENSIONS'
13804 !      include 'COMMON.GEO'
13805 !      include 'COMMON.VAR'
13806 !      include 'COMMON.LOCAL'
13807 !      include 'COMMON.CHAIN'
13808 !      include 'COMMON.DERIV'
13809 !      include 'COMMON.NAMES'
13810 !      include 'COMMON.INTERACT'
13811 !      include 'COMMON.IOUNITS'
13812 !      include 'COMMON.CALC'
13813       use comm_srutu
13814 !el      integer :: icall
13815 !el      common /srutu/ icall
13816 !     double precision rrsave(maxdim)
13817       logical :: lprn
13818 !el local variables
13819       integer :: iint,itypi,itypi1,itypj
13820       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13821       real(kind=8) :: sss,e1,e2,evdw
13822       evdw=0.0D0
13823 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13824       evdw=0.0D0
13825 !     if (icall.eq.0) then
13826 !       lprn=.true.
13827 !     else
13828         lprn=.false.
13829 !     endif
13830 !el      ind=0
13831       do i=iatsc_s,iatsc_e
13832         itypi=itype(i,1)
13833         if (itypi.eq.ntyp1) cycle
13834         itypi1=itype(i+1,1)
13835         xi=c(1,nres+i)
13836         yi=c(2,nres+i)
13837         zi=c(3,nres+i)
13838         dxi=dc_norm(1,nres+i)
13839         dyi=dc_norm(2,nres+i)
13840         dzi=dc_norm(3,nres+i)
13841 !        dsci_inv=dsc_inv(itypi)
13842         dsci_inv=vbld_inv(i+nres)
13843 !
13844 ! Calculate SC interaction energy.
13845 !
13846         do iint=1,nint_gr(i)
13847           do j=istart(i,iint),iend(i,iint)
13848 !el            ind=ind+1
13849             itypj=itype(j,1)
13850             if (itypj.eq.ntyp1) cycle
13851 !            dscj_inv=dsc_inv(itypj)
13852             dscj_inv=vbld_inv(j+nres)
13853             chi1=chi(itypi,itypj)
13854             chi2=chi(itypj,itypi)
13855             chi12=chi1*chi2
13856             chip1=chip(itypi)
13857             chip2=chip(itypj)
13858             chip12=chip1*chip2
13859             alf1=alp(itypi)
13860             alf2=alp(itypj)
13861             alf12=0.5D0*(alf1+alf2)
13862             xj=c(1,nres+j)-xi
13863             yj=c(2,nres+j)-yi
13864             zj=c(3,nres+j)-zi
13865             dxj=dc_norm(1,nres+j)
13866             dyj=dc_norm(2,nres+j)
13867             dzj=dc_norm(3,nres+j)
13868             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13869             rij=dsqrt(rrij)
13870             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13871
13872             if (sss.gt.0.0d0) then
13873
13874 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13875               call sc_angular
13876 ! Calculate whole angle-dependent part of epsilon and contributions
13877 ! to its derivatives
13878               fac=(rrij*sigsq)**expon2
13879               e1=fac*fac*aa_aq(itypi,itypj)
13880               e2=fac*bb_aq(itypi,itypj)
13881               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13882               eps2der=evdwij*eps3rt
13883               eps3der=evdwij*eps2rt
13884               evdwij=evdwij*eps2rt*eps3rt
13885               evdw=evdw+evdwij*sss
13886               if (lprn) then
13887               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13888               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13889 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13890 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13891 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13892 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13893 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13894 !d     &          evdwij
13895               endif
13896 ! Calculate gradient components.
13897               e1=e1*eps1*eps2rt**2*eps3rt**2
13898               fac=-expon*(e1+evdwij)
13899               sigder=fac/sigsq
13900               fac=rrij*fac
13901 ! Calculate radial part of the gradient
13902               gg(1)=xj*fac
13903               gg(2)=yj*fac
13904               gg(3)=zj*fac
13905 ! Calculate the angular part of the gradient and sum add the contributions
13906 ! to the appropriate components of the Cartesian gradient.
13907               call sc_grad_scale(sss)
13908             endif
13909           enddo      ! j
13910         enddo        ! iint
13911       enddo          ! i
13912 !     stop
13913       return
13914       end subroutine ebp_short
13915 !-----------------------------------------------------------------------------
13916       subroutine egb_long(evdw)
13917 !
13918 ! This subroutine calculates the interaction energy of nonbonded side chains
13919 ! assuming the Gay-Berne potential of interaction.
13920 !
13921       use calc_data
13922 !      implicit real*8 (a-h,o-z)
13923 !      include 'DIMENSIONS'
13924 !      include 'COMMON.GEO'
13925 !      include 'COMMON.VAR'
13926 !      include 'COMMON.LOCAL'
13927 !      include 'COMMON.CHAIN'
13928 !      include 'COMMON.DERIV'
13929 !      include 'COMMON.NAMES'
13930 !      include 'COMMON.INTERACT'
13931 !      include 'COMMON.IOUNITS'
13932 !      include 'COMMON.CALC'
13933 !      include 'COMMON.CONTROL'
13934       logical :: lprn
13935 !el local variables
13936       integer :: iint,itypi,itypi1,itypj,subchap
13937       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13938       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13939       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13940                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13941                     ssgradlipi,ssgradlipj
13942
13943
13944       evdw=0.0D0
13945 !cccc      energy_dec=.false.
13946 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13947       evdw=0.0D0
13948       lprn=.false.
13949 !     if (icall.eq.0) lprn=.false.
13950 !el      ind=0
13951       do i=iatsc_s,iatsc_e
13952         itypi=itype(i,1)
13953         if (itypi.eq.ntyp1) cycle
13954         itypi1=itype(i+1,1)
13955         xi=c(1,nres+i)
13956         yi=c(2,nres+i)
13957         zi=c(3,nres+i)
13958           xi=mod(xi,boxxsize)
13959           if (xi.lt.0) xi=xi+boxxsize
13960           yi=mod(yi,boxysize)
13961           if (yi.lt.0) yi=yi+boxysize
13962           zi=mod(zi,boxzsize)
13963           if (zi.lt.0) zi=zi+boxzsize
13964        if ((zi.gt.bordlipbot)    &
13965         .and.(zi.lt.bordliptop)) then
13966 !C the energy transfer exist
13967         if (zi.lt.buflipbot) then
13968 !C what fraction I am in
13969          fracinbuf=1.0d0-    &
13970              ((zi-bordlipbot)/lipbufthick)
13971 !C lipbufthick is thickenes of lipid buffore
13972          sslipi=sscalelip(fracinbuf)
13973          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13974         elseif (zi.gt.bufliptop) then
13975          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13976          sslipi=sscalelip(fracinbuf)
13977          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13978         else
13979          sslipi=1.0d0
13980          ssgradlipi=0.0
13981         endif
13982        else
13983          sslipi=0.0d0
13984          ssgradlipi=0.0
13985        endif
13986
13987         dxi=dc_norm(1,nres+i)
13988         dyi=dc_norm(2,nres+i)
13989         dzi=dc_norm(3,nres+i)
13990 !        dsci_inv=dsc_inv(itypi)
13991         dsci_inv=vbld_inv(i+nres)
13992 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13993 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13994 !
13995 ! Calculate SC interaction energy.
13996 !
13997         do iint=1,nint_gr(i)
13998           do j=istart(i,iint),iend(i,iint)
13999             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14000 !              call dyn_ssbond_ene(i,j,evdwij)
14001 !              evdw=evdw+evdwij
14002 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14003 !                              'evdw',i,j,evdwij,' ss'
14004 !              if (energy_dec) write (iout,*) &
14005 !                              'evdw',i,j,evdwij,' ss'
14006 !             do k=j+1,iend(i,iint)
14007 !C search over all next residues
14008 !              if (dyn_ss_mask(k)) then
14009 !C check if they are cysteins
14010 !C              write(iout,*) 'k=',k
14011
14012 !c              write(iout,*) "PRZED TRI", evdwij
14013 !               evdwij_przed_tri=evdwij
14014 !              call triple_ssbond_ene(i,j,k,evdwij)
14015 !c               if(evdwij_przed_tri.ne.evdwij) then
14016 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14017 !c               endif
14018
14019 !c              write(iout,*) "PO TRI", evdwij
14020 !C call the energy function that removes the artifical triple disulfide
14021 !C bond the soubroutine is located in ssMD.F
14022 !              evdw=evdw+evdwij
14023               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14024                             'evdw',i,j,evdwij,'tss'
14025 !              endif!dyn_ss_mask(k)
14026 !             enddo! k
14027
14028             ELSE
14029 !el            ind=ind+1
14030             itypj=itype(j,1)
14031             if (itypj.eq.ntyp1) cycle
14032 !            dscj_inv=dsc_inv(itypj)
14033             dscj_inv=vbld_inv(j+nres)
14034 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14035 !     &       1.0d0/vbld(j+nres)
14036 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14037             sig0ij=sigma(itypi,itypj)
14038             chi1=chi(itypi,itypj)
14039             chi2=chi(itypj,itypi)
14040             chi12=chi1*chi2
14041             chip1=chip(itypi)
14042             chip2=chip(itypj)
14043             chip12=chip1*chip2
14044             alf1=alp(itypi)
14045             alf2=alp(itypj)
14046             alf12=0.5D0*(alf1+alf2)
14047             xj=c(1,nres+j)
14048             yj=c(2,nres+j)
14049             zj=c(3,nres+j)
14050 ! Searching for nearest neighbour
14051           xj=mod(xj,boxxsize)
14052           if (xj.lt.0) xj=xj+boxxsize
14053           yj=mod(yj,boxysize)
14054           if (yj.lt.0) yj=yj+boxysize
14055           zj=mod(zj,boxzsize)
14056           if (zj.lt.0) zj=zj+boxzsize
14057        if ((zj.gt.bordlipbot)   &
14058       .and.(zj.lt.bordliptop)) then
14059 !C the energy transfer exist
14060         if (zj.lt.buflipbot) then
14061 !C what fraction I am in
14062          fracinbuf=1.0d0-  &
14063              ((zj-bordlipbot)/lipbufthick)
14064 !C lipbufthick is thickenes of lipid buffore
14065          sslipj=sscalelip(fracinbuf)
14066          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14067         elseif (zj.gt.bufliptop) then
14068          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14069          sslipj=sscalelip(fracinbuf)
14070          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14071         else
14072          sslipj=1.0d0
14073          ssgradlipj=0.0
14074         endif
14075        else
14076          sslipj=0.0d0
14077          ssgradlipj=0.0
14078        endif
14079       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14080        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14081       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14082        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14083
14084           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14085           xj_safe=xj
14086           yj_safe=yj
14087           zj_safe=zj
14088           subchap=0
14089           do xshift=-1,1
14090           do yshift=-1,1
14091           do zshift=-1,1
14092           xj=xj_safe+xshift*boxxsize
14093           yj=yj_safe+yshift*boxysize
14094           zj=zj_safe+zshift*boxzsize
14095           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14096           if(dist_temp.lt.dist_init) then
14097             dist_init=dist_temp
14098             xj_temp=xj
14099             yj_temp=yj
14100             zj_temp=zj
14101             subchap=1
14102           endif
14103           enddo
14104           enddo
14105           enddo
14106           if (subchap.eq.1) then
14107           xj=xj_temp-xi
14108           yj=yj_temp-yi
14109           zj=zj_temp-zi
14110           else
14111           xj=xj_safe-xi
14112           yj=yj_safe-yi
14113           zj=zj_safe-zi
14114           endif
14115
14116             dxj=dc_norm(1,nres+j)
14117             dyj=dc_norm(2,nres+j)
14118             dzj=dc_norm(3,nres+j)
14119             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14120             rij=dsqrt(rrij)
14121             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14122             sss_ele_cut=sscale_ele(1.0d0/(rij))
14123             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14124             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14125             if (sss_ele_cut.le.0.0) cycle
14126             if (sss.lt.1.0d0) then
14127
14128 ! Calculate angle-dependent terms of energy and contributions to their
14129 ! derivatives.
14130               call sc_angular
14131               sigsq=1.0D0/sigsq
14132               sig=sig0ij*dsqrt(sigsq)
14133               rij_shift=1.0D0/rij-sig+sig0ij
14134 ! for diagnostics; uncomment
14135 !              rij_shift=1.2*sig0ij
14136 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14137               if (rij_shift.le.0.0D0) then
14138                 evdw=1.0D20
14139 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14140 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14141 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14142                 return
14143               endif
14144               sigder=-sig*sigsq
14145 !---------------------------------------------------------------
14146               rij_shift=1.0D0/rij_shift
14147               fac=rij_shift**expon
14148               e1=fac*fac*aa
14149               e2=fac*bb
14150               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14151               eps2der=evdwij*eps3rt
14152               eps3der=evdwij*eps2rt
14153 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14154 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14155               evdwij=evdwij*eps2rt*eps3rt
14156               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14157               if (lprn) then
14158               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14159               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14160               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14161                 restyp(itypi,1),i,restyp(itypj,1),j,&
14162                 epsi,sigm,chi1,chi2,chip1,chip2,&
14163                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14164                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14165                 evdwij
14166               endif
14167
14168               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14169                               'evdw',i,j,evdwij
14170 !              if (energy_dec) write (iout,*) &
14171 !                              'evdw',i,j,evdwij,"egb_long"
14172
14173 ! Calculate gradient components.
14174               e1=e1*eps1*eps2rt**2*eps3rt**2
14175               fac=-expon*(e1+evdwij)*rij_shift
14176               sigder=fac*sigder
14177               fac=rij*fac
14178               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14179               *rij-sss_grad/(1.0-sss)*rij  &
14180             /sigmaii(itypi,itypj))
14181 !              fac=0.0d0
14182 ! Calculate the radial part of the gradient
14183               gg(1)=xj*fac
14184               gg(2)=yj*fac
14185               gg(3)=zj*fac
14186 ! Calculate angular part of the gradient.
14187               call sc_grad_scale(1.0d0-sss)
14188             ENDIF    !mask_dyn_ss
14189             endif
14190           enddo      ! j
14191         enddo        ! iint
14192       enddo          ! i
14193 !      write (iout,*) "Number of loop steps in EGB:",ind
14194 !ccc      energy_dec=.false.
14195       return
14196       end subroutine egb_long
14197 !-----------------------------------------------------------------------------
14198       subroutine egb_short(evdw)
14199 !
14200 ! This subroutine calculates the interaction energy of nonbonded side chains
14201 ! assuming the Gay-Berne potential of interaction.
14202 !
14203       use calc_data
14204 !      implicit real*8 (a-h,o-z)
14205 !      include 'DIMENSIONS'
14206 !      include 'COMMON.GEO'
14207 !      include 'COMMON.VAR'
14208 !      include 'COMMON.LOCAL'
14209 !      include 'COMMON.CHAIN'
14210 !      include 'COMMON.DERIV'
14211 !      include 'COMMON.NAMES'
14212 !      include 'COMMON.INTERACT'
14213 !      include 'COMMON.IOUNITS'
14214 !      include 'COMMON.CALC'
14215 !      include 'COMMON.CONTROL'
14216       logical :: lprn
14217 !el local variables
14218       integer :: iint,itypi,itypi1,itypj,subchap
14219       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14220       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14221       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14222                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14223                     ssgradlipi,ssgradlipj
14224       evdw=0.0D0
14225 !cccc      energy_dec=.false.
14226 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14227       evdw=0.0D0
14228       lprn=.false.
14229 !     if (icall.eq.0) lprn=.false.
14230 !el      ind=0
14231       do i=iatsc_s,iatsc_e
14232         itypi=itype(i,1)
14233         if (itypi.eq.ntyp1) cycle
14234         itypi1=itype(i+1,1)
14235         xi=c(1,nres+i)
14236         yi=c(2,nres+i)
14237         zi=c(3,nres+i)
14238           xi=mod(xi,boxxsize)
14239           if (xi.lt.0) xi=xi+boxxsize
14240           yi=mod(yi,boxysize)
14241           if (yi.lt.0) yi=yi+boxysize
14242           zi=mod(zi,boxzsize)
14243           if (zi.lt.0) zi=zi+boxzsize
14244        if ((zi.gt.bordlipbot)    &
14245         .and.(zi.lt.bordliptop)) then
14246 !C the energy transfer exist
14247         if (zi.lt.buflipbot) then
14248 !C what fraction I am in
14249          fracinbuf=1.0d0-    &
14250              ((zi-bordlipbot)/lipbufthick)
14251 !C lipbufthick is thickenes of lipid buffore
14252          sslipi=sscalelip(fracinbuf)
14253          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14254         elseif (zi.gt.bufliptop) then
14255          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14256          sslipi=sscalelip(fracinbuf)
14257          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14258         else
14259          sslipi=1.0d0
14260          ssgradlipi=0.0
14261         endif
14262        else
14263          sslipi=0.0d0
14264          ssgradlipi=0.0
14265        endif
14266
14267         dxi=dc_norm(1,nres+i)
14268         dyi=dc_norm(2,nres+i)
14269         dzi=dc_norm(3,nres+i)
14270 !        dsci_inv=dsc_inv(itypi)
14271         dsci_inv=vbld_inv(i+nres)
14272
14273         dxi=dc_norm(1,nres+i)
14274         dyi=dc_norm(2,nres+i)
14275         dzi=dc_norm(3,nres+i)
14276 !        dsci_inv=dsc_inv(itypi)
14277         dsci_inv=vbld_inv(i+nres)
14278 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14279 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14280 !
14281 ! Calculate SC interaction energy.
14282 !
14283         do iint=1,nint_gr(i)
14284           do j=istart(i,iint),iend(i,iint)
14285             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14286               call dyn_ssbond_ene(i,j,evdwij)
14287               evdw=evdw+evdwij
14288               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14289                               'evdw',i,j,evdwij,' ss'
14290              do k=j+1,iend(i,iint)
14291 !C search over all next residues
14292               if (dyn_ss_mask(k)) then
14293 !C check if they are cysteins
14294 !C              write(iout,*) 'k=',k
14295
14296 !c              write(iout,*) "PRZED TRI", evdwij
14297 !               evdwij_przed_tri=evdwij
14298               call triple_ssbond_ene(i,j,k,evdwij)
14299 !c               if(evdwij_przed_tri.ne.evdwij) then
14300 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14301 !c               endif
14302
14303 !c              write(iout,*) "PO TRI", evdwij
14304 !C call the energy function that removes the artifical triple disulfide
14305 !C bond the soubroutine is located in ssMD.F
14306               evdw=evdw+evdwij
14307               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14308                             'evdw',i,j,evdwij,'tss'
14309               endif!dyn_ss_mask(k)
14310              enddo! k
14311
14312 !              if (energy_dec) write (iout,*) &
14313 !                              'evdw',i,j,evdwij,' ss'
14314             ELSE
14315 !el            ind=ind+1
14316             itypj=itype(j,1)
14317             if (itypj.eq.ntyp1) cycle
14318 !            dscj_inv=dsc_inv(itypj)
14319             dscj_inv=vbld_inv(j+nres)
14320 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14321 !     &       1.0d0/vbld(j+nres)
14322 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14323             sig0ij=sigma(itypi,itypj)
14324             chi1=chi(itypi,itypj)
14325             chi2=chi(itypj,itypi)
14326             chi12=chi1*chi2
14327             chip1=chip(itypi)
14328             chip2=chip(itypj)
14329             chip12=chip1*chip2
14330             alf1=alp(itypi)
14331             alf2=alp(itypj)
14332             alf12=0.5D0*(alf1+alf2)
14333 !            xj=c(1,nres+j)-xi
14334 !            yj=c(2,nres+j)-yi
14335 !            zj=c(3,nres+j)-zi
14336             xj=c(1,nres+j)
14337             yj=c(2,nres+j)
14338             zj=c(3,nres+j)
14339 ! Searching for nearest neighbour
14340           xj=mod(xj,boxxsize)
14341           if (xj.lt.0) xj=xj+boxxsize
14342           yj=mod(yj,boxysize)
14343           if (yj.lt.0) yj=yj+boxysize
14344           zj=mod(zj,boxzsize)
14345           if (zj.lt.0) zj=zj+boxzsize
14346        if ((zj.gt.bordlipbot)   &
14347       .and.(zj.lt.bordliptop)) then
14348 !C the energy transfer exist
14349         if (zj.lt.buflipbot) then
14350 !C what fraction I am in
14351          fracinbuf=1.0d0-  &
14352              ((zj-bordlipbot)/lipbufthick)
14353 !C lipbufthick is thickenes of lipid buffore
14354          sslipj=sscalelip(fracinbuf)
14355          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14356         elseif (zj.gt.bufliptop) then
14357          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14358          sslipj=sscalelip(fracinbuf)
14359          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14360         else
14361          sslipj=1.0d0
14362          ssgradlipj=0.0
14363         endif
14364        else
14365          sslipj=0.0d0
14366          ssgradlipj=0.0
14367        endif
14368       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14369        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14370       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14371        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14372
14373           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14374           xj_safe=xj
14375           yj_safe=yj
14376           zj_safe=zj
14377           subchap=0
14378
14379           do xshift=-1,1
14380           do yshift=-1,1
14381           do zshift=-1,1
14382           xj=xj_safe+xshift*boxxsize
14383           yj=yj_safe+yshift*boxysize
14384           zj=zj_safe+zshift*boxzsize
14385           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14386           if(dist_temp.lt.dist_init) then
14387             dist_init=dist_temp
14388             xj_temp=xj
14389             yj_temp=yj
14390             zj_temp=zj
14391             subchap=1
14392           endif
14393           enddo
14394           enddo
14395           enddo
14396           if (subchap.eq.1) then
14397           xj=xj_temp-xi
14398           yj=yj_temp-yi
14399           zj=zj_temp-zi
14400           else
14401           xj=xj_safe-xi
14402           yj=yj_safe-yi
14403           zj=zj_safe-zi
14404           endif
14405
14406             dxj=dc_norm(1,nres+j)
14407             dyj=dc_norm(2,nres+j)
14408             dzj=dc_norm(3,nres+j)
14409             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14410             rij=dsqrt(rrij)
14411             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14412             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14413             sss_ele_cut=sscale_ele(1.0d0/(rij))
14414             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14415             if (sss_ele_cut.le.0.0) cycle
14416
14417             if (sss.gt.0.0d0) then
14418
14419 ! Calculate angle-dependent terms of energy and contributions to their
14420 ! derivatives.
14421               call sc_angular
14422               sigsq=1.0D0/sigsq
14423               sig=sig0ij*dsqrt(sigsq)
14424               rij_shift=1.0D0/rij-sig+sig0ij
14425 ! for diagnostics; uncomment
14426 !              rij_shift=1.2*sig0ij
14427 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14428               if (rij_shift.le.0.0D0) then
14429                 evdw=1.0D20
14430 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14431 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14432 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14433                 return
14434               endif
14435               sigder=-sig*sigsq
14436 !---------------------------------------------------------------
14437               rij_shift=1.0D0/rij_shift
14438               fac=rij_shift**expon
14439               e1=fac*fac*aa
14440               e2=fac*bb
14441               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14442               eps2der=evdwij*eps3rt
14443               eps3der=evdwij*eps2rt
14444 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14445 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14446               evdwij=evdwij*eps2rt*eps3rt
14447               evdw=evdw+evdwij*sss*sss_ele_cut
14448               if (lprn) then
14449               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14450               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14451               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14452                 restyp(itypi,1),i,restyp(itypj,1),j,&
14453                 epsi,sigm,chi1,chi2,chip1,chip2,&
14454                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14455                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14456                 evdwij
14457               endif
14458
14459               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14460                               'evdw',i,j,evdwij
14461 !              if (energy_dec) write (iout,*) &
14462 !                              'evdw',i,j,evdwij,"egb_short"
14463
14464 ! Calculate gradient components.
14465               e1=e1*eps1*eps2rt**2*eps3rt**2
14466               fac=-expon*(e1+evdwij)*rij_shift
14467               sigder=fac*sigder
14468               fac=rij*fac
14469               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14470             *rij+sss_grad/sss*rij  &
14471             /sigmaii(itypi,itypj))
14472
14473 !              fac=0.0d0
14474 ! Calculate the radial part of the gradient
14475               gg(1)=xj*fac
14476               gg(2)=yj*fac
14477               gg(3)=zj*fac
14478 ! Calculate angular part of the gradient.
14479               call sc_grad_scale(sss)
14480             endif
14481           ENDIF !mask_dyn_ss
14482           enddo      ! j
14483         enddo        ! iint
14484       enddo          ! i
14485 !      write (iout,*) "Number of loop steps in EGB:",ind
14486 !ccc      energy_dec=.false.
14487       return
14488       end subroutine egb_short
14489 !-----------------------------------------------------------------------------
14490       subroutine egbv_long(evdw)
14491 !
14492 ! This subroutine calculates the interaction energy of nonbonded side chains
14493 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14494 !
14495       use calc_data
14496 !      implicit real*8 (a-h,o-z)
14497 !      include 'DIMENSIONS'
14498 !      include 'COMMON.GEO'
14499 !      include 'COMMON.VAR'
14500 !      include 'COMMON.LOCAL'
14501 !      include 'COMMON.CHAIN'
14502 !      include 'COMMON.DERIV'
14503 !      include 'COMMON.NAMES'
14504 !      include 'COMMON.INTERACT'
14505 !      include 'COMMON.IOUNITS'
14506 !      include 'COMMON.CALC'
14507       use comm_srutu
14508 !el      integer :: icall
14509 !el      common /srutu/ icall
14510       logical :: lprn
14511 !el local variables
14512       integer :: iint,itypi,itypi1,itypj
14513       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14514       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14515       evdw=0.0D0
14516 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14517       evdw=0.0D0
14518       lprn=.false.
14519 !     if (icall.eq.0) lprn=.true.
14520 !el      ind=0
14521       do i=iatsc_s,iatsc_e
14522         itypi=itype(i,1)
14523         if (itypi.eq.ntyp1) cycle
14524         itypi1=itype(i+1,1)
14525         xi=c(1,nres+i)
14526         yi=c(2,nres+i)
14527         zi=c(3,nres+i)
14528         dxi=dc_norm(1,nres+i)
14529         dyi=dc_norm(2,nres+i)
14530         dzi=dc_norm(3,nres+i)
14531 !        dsci_inv=dsc_inv(itypi)
14532         dsci_inv=vbld_inv(i+nres)
14533 !
14534 ! Calculate SC interaction energy.
14535 !
14536         do iint=1,nint_gr(i)
14537           do j=istart(i,iint),iend(i,iint)
14538 !el            ind=ind+1
14539             itypj=itype(j,1)
14540             if (itypj.eq.ntyp1) cycle
14541 !            dscj_inv=dsc_inv(itypj)
14542             dscj_inv=vbld_inv(j+nres)
14543             sig0ij=sigma(itypi,itypj)
14544             r0ij=r0(itypi,itypj)
14545             chi1=chi(itypi,itypj)
14546             chi2=chi(itypj,itypi)
14547             chi12=chi1*chi2
14548             chip1=chip(itypi)
14549             chip2=chip(itypj)
14550             chip12=chip1*chip2
14551             alf1=alp(itypi)
14552             alf2=alp(itypj)
14553             alf12=0.5D0*(alf1+alf2)
14554             xj=c(1,nres+j)-xi
14555             yj=c(2,nres+j)-yi
14556             zj=c(3,nres+j)-zi
14557             dxj=dc_norm(1,nres+j)
14558             dyj=dc_norm(2,nres+j)
14559             dzj=dc_norm(3,nres+j)
14560             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14561             rij=dsqrt(rrij)
14562
14563             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14564
14565             if (sss.lt.1.0d0) then
14566
14567 ! Calculate angle-dependent terms of energy and contributions to their
14568 ! derivatives.
14569               call sc_angular
14570               sigsq=1.0D0/sigsq
14571               sig=sig0ij*dsqrt(sigsq)
14572               rij_shift=1.0D0/rij-sig+r0ij
14573 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14574               if (rij_shift.le.0.0D0) then
14575                 evdw=1.0D20
14576                 return
14577               endif
14578               sigder=-sig*sigsq
14579 !---------------------------------------------------------------
14580               rij_shift=1.0D0/rij_shift
14581               fac=rij_shift**expon
14582               e1=fac*fac*aa_aq(itypi,itypj)
14583               e2=fac*bb_aq(itypi,itypj)
14584               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14585               eps2der=evdwij*eps3rt
14586               eps3der=evdwij*eps2rt
14587               fac_augm=rrij**expon
14588               e_augm=augm(itypi,itypj)*fac_augm
14589               evdwij=evdwij*eps2rt*eps3rt
14590               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14591               if (lprn) then
14592               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14593               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14594               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14595                 restyp(itypi,1),i,restyp(itypj,1),j,&
14596                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14597                 chi1,chi2,chip1,chip2,&
14598                 eps1,eps2rt**2,eps3rt**2,&
14599                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14600                 evdwij+e_augm
14601               endif
14602 ! Calculate gradient components.
14603               e1=e1*eps1*eps2rt**2*eps3rt**2
14604               fac=-expon*(e1+evdwij)*rij_shift
14605               sigder=fac*sigder
14606               fac=rij*fac-2*expon*rrij*e_augm
14607 ! Calculate the radial part of the gradient
14608               gg(1)=xj*fac
14609               gg(2)=yj*fac
14610               gg(3)=zj*fac
14611 ! Calculate angular part of the gradient.
14612               call sc_grad_scale(1.0d0-sss)
14613             endif
14614           enddo      ! j
14615         enddo        ! iint
14616       enddo          ! i
14617       end subroutine egbv_long
14618 !-----------------------------------------------------------------------------
14619       subroutine egbv_short(evdw)
14620 !
14621 ! This subroutine calculates the interaction energy of nonbonded side chains
14622 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14623 !
14624       use calc_data
14625 !      implicit real*8 (a-h,o-z)
14626 !      include 'DIMENSIONS'
14627 !      include 'COMMON.GEO'
14628 !      include 'COMMON.VAR'
14629 !      include 'COMMON.LOCAL'
14630 !      include 'COMMON.CHAIN'
14631 !      include 'COMMON.DERIV'
14632 !      include 'COMMON.NAMES'
14633 !      include 'COMMON.INTERACT'
14634 !      include 'COMMON.IOUNITS'
14635 !      include 'COMMON.CALC'
14636       use comm_srutu
14637 !el      integer :: icall
14638 !el      common /srutu/ icall
14639       logical :: lprn
14640 !el local variables
14641       integer :: iint,itypi,itypi1,itypj
14642       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14643       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14644       evdw=0.0D0
14645 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14646       evdw=0.0D0
14647       lprn=.false.
14648 !     if (icall.eq.0) lprn=.true.
14649 !el      ind=0
14650       do i=iatsc_s,iatsc_e
14651         itypi=itype(i,1)
14652         if (itypi.eq.ntyp1) cycle
14653         itypi1=itype(i+1,1)
14654         xi=c(1,nres+i)
14655         yi=c(2,nres+i)
14656         zi=c(3,nres+i)
14657         dxi=dc_norm(1,nres+i)
14658         dyi=dc_norm(2,nres+i)
14659         dzi=dc_norm(3,nres+i)
14660 !        dsci_inv=dsc_inv(itypi)
14661         dsci_inv=vbld_inv(i+nres)
14662 !
14663 ! Calculate SC interaction energy.
14664 !
14665         do iint=1,nint_gr(i)
14666           do j=istart(i,iint),iend(i,iint)
14667 !el            ind=ind+1
14668             itypj=itype(j,1)
14669             if (itypj.eq.ntyp1) cycle
14670 !            dscj_inv=dsc_inv(itypj)
14671             dscj_inv=vbld_inv(j+nres)
14672             sig0ij=sigma(itypi,itypj)
14673             r0ij=r0(itypi,itypj)
14674             chi1=chi(itypi,itypj)
14675             chi2=chi(itypj,itypi)
14676             chi12=chi1*chi2
14677             chip1=chip(itypi)
14678             chip2=chip(itypj)
14679             chip12=chip1*chip2
14680             alf1=alp(itypi)
14681             alf2=alp(itypj)
14682             alf12=0.5D0*(alf1+alf2)
14683             xj=c(1,nres+j)-xi
14684             yj=c(2,nres+j)-yi
14685             zj=c(3,nres+j)-zi
14686             dxj=dc_norm(1,nres+j)
14687             dyj=dc_norm(2,nres+j)
14688             dzj=dc_norm(3,nres+j)
14689             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14690             rij=dsqrt(rrij)
14691
14692             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14693
14694             if (sss.gt.0.0d0) then
14695
14696 ! Calculate angle-dependent terms of energy and contributions to their
14697 ! derivatives.
14698               call sc_angular
14699               sigsq=1.0D0/sigsq
14700               sig=sig0ij*dsqrt(sigsq)
14701               rij_shift=1.0D0/rij-sig+r0ij
14702 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14703               if (rij_shift.le.0.0D0) then
14704                 evdw=1.0D20
14705                 return
14706               endif
14707               sigder=-sig*sigsq
14708 !---------------------------------------------------------------
14709               rij_shift=1.0D0/rij_shift
14710               fac=rij_shift**expon
14711               e1=fac*fac*aa_aq(itypi,itypj)
14712               e2=fac*bb_aq(itypi,itypj)
14713               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14714               eps2der=evdwij*eps3rt
14715               eps3der=evdwij*eps2rt
14716               fac_augm=rrij**expon
14717               e_augm=augm(itypi,itypj)*fac_augm
14718               evdwij=evdwij*eps2rt*eps3rt
14719               evdw=evdw+(evdwij+e_augm)*sss
14720               if (lprn) then
14721               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14722               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14723               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14724                 restyp(itypi,1),i,restyp(itypj,1),j,&
14725                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14726                 chi1,chi2,chip1,chip2,&
14727                 eps1,eps2rt**2,eps3rt**2,&
14728                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14729                 evdwij+e_augm
14730               endif
14731 ! Calculate gradient components.
14732               e1=e1*eps1*eps2rt**2*eps3rt**2
14733               fac=-expon*(e1+evdwij)*rij_shift
14734               sigder=fac*sigder
14735               fac=rij*fac-2*expon*rrij*e_augm
14736 ! Calculate the radial part of the gradient
14737               gg(1)=xj*fac
14738               gg(2)=yj*fac
14739               gg(3)=zj*fac
14740 ! Calculate angular part of the gradient.
14741               call sc_grad_scale(sss)
14742             endif
14743           enddo      ! j
14744         enddo        ! iint
14745       enddo          ! i
14746       end subroutine egbv_short
14747 !-----------------------------------------------------------------------------
14748       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14749 !
14750 ! This subroutine calculates the average interaction energy and its gradient
14751 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14752 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14753 ! The potential depends both on the distance of peptide-group centers and on
14754 ! the orientation of the CA-CA virtual bonds.
14755 !
14756 !      implicit real*8 (a-h,o-z)
14757
14758       use comm_locel
14759 #ifdef MPI
14760       include 'mpif.h'
14761 #endif
14762 !      include 'DIMENSIONS'
14763 !      include 'COMMON.CONTROL'
14764 !      include 'COMMON.SETUP'
14765 !      include 'COMMON.IOUNITS'
14766 !      include 'COMMON.GEO'
14767 !      include 'COMMON.VAR'
14768 !      include 'COMMON.LOCAL'
14769 !      include 'COMMON.CHAIN'
14770 !      include 'COMMON.DERIV'
14771 !      include 'COMMON.INTERACT'
14772 !      include 'COMMON.CONTACTS'
14773 !      include 'COMMON.TORSION'
14774 !      include 'COMMON.VECTORS'
14775 !      include 'COMMON.FFIELD'
14776 !      include 'COMMON.TIME1'
14777       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14778       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14779       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14780 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14781       real(kind=8),dimension(4) :: muij
14782 !el      integer :: num_conti,j1,j2
14783 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14784 !el                   dz_normi,xmedi,ymedi,zmedi
14785 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14786 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14787 !el          num_conti,j1,j2
14788 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14789 #ifdef MOMENT
14790       real(kind=8) :: scal_el=1.0d0
14791 #else
14792       real(kind=8) :: scal_el=0.5d0
14793 #endif
14794 ! 12/13/98
14795 ! 13-go grudnia roku pamietnego...
14796       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14797                                              0.0d0,1.0d0,0.0d0,&
14798                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14799 !el local variables
14800       integer :: i,j,k
14801       real(kind=8) :: fac
14802       real(kind=8) :: dxj,dyj,dzj
14803       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14804
14805 !      allocate(num_cont_hb(nres)) !(maxres)
14806 !d      write(iout,*) 'In EELEC'
14807 !d      do i=1,nloctyp
14808 !d        write(iout,*) 'Type',i
14809 !d        write(iout,*) 'B1',B1(:,i)
14810 !d        write(iout,*) 'B2',B2(:,i)
14811 !d        write(iout,*) 'CC',CC(:,:,i)
14812 !d        write(iout,*) 'DD',DD(:,:,i)
14813 !d        write(iout,*) 'EE',EE(:,:,i)
14814 !d      enddo
14815 !d      call check_vecgrad
14816 !d      stop
14817       if (icheckgrad.eq.1) then
14818         do i=1,nres-1
14819           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14820           do k=1,3
14821             dc_norm(k,i)=dc(k,i)*fac
14822           enddo
14823 !          write (iout,*) 'i',i,' fac',fac
14824         enddo
14825       endif
14826       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14827           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14828           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14829 !        call vec_and_deriv
14830 #ifdef TIMING
14831         time01=MPI_Wtime()
14832 #endif
14833 !        print *, "before set matrices"
14834         call set_matrices
14835 !        print *,"after set martices"
14836 #ifdef TIMING
14837         time_mat=time_mat+MPI_Wtime()-time01
14838 #endif
14839       endif
14840 !d      do i=1,nres-1
14841 !d        write (iout,*) 'i=',i
14842 !d        do k=1,3
14843 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14844 !d        enddo
14845 !d        do k=1,3
14846 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14847 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14848 !d        enddo
14849 !d      enddo
14850       t_eelecij=0.0d0
14851       ees=0.0D0
14852       evdw1=0.0D0
14853       eel_loc=0.0d0
14854       eello_turn3=0.0d0
14855       eello_turn4=0.0d0
14856 !el      ind=0
14857       do i=1,nres
14858         num_cont_hb(i)=0
14859       enddo
14860 !d      print '(a)','Enter EELEC'
14861 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14862 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14863 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14864       do i=1,nres
14865         gel_loc_loc(i)=0.0d0
14866         gcorr_loc(i)=0.0d0
14867       enddo
14868 !
14869 !
14870 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14871 !
14872 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14873 !
14874       do i=iturn3_start,iturn3_end
14875         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14876         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14877         dxi=dc(1,i)
14878         dyi=dc(2,i)
14879         dzi=dc(3,i)
14880         dx_normi=dc_norm(1,i)
14881         dy_normi=dc_norm(2,i)
14882         dz_normi=dc_norm(3,i)
14883         xmedi=c(1,i)+0.5d0*dxi
14884         ymedi=c(2,i)+0.5d0*dyi
14885         zmedi=c(3,i)+0.5d0*dzi
14886           xmedi=dmod(xmedi,boxxsize)
14887           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14888           ymedi=dmod(ymedi,boxysize)
14889           if (ymedi.lt.0) ymedi=ymedi+boxysize
14890           zmedi=dmod(zmedi,boxzsize)
14891           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14892         num_conti=0
14893         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14894         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14895         num_cont_hb(i)=num_conti
14896       enddo
14897       do i=iturn4_start,iturn4_end
14898         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14899           .or. itype(i+3,1).eq.ntyp1 &
14900           .or. itype(i+4,1).eq.ntyp1) cycle
14901         dxi=dc(1,i)
14902         dyi=dc(2,i)
14903         dzi=dc(3,i)
14904         dx_normi=dc_norm(1,i)
14905         dy_normi=dc_norm(2,i)
14906         dz_normi=dc_norm(3,i)
14907         xmedi=c(1,i)+0.5d0*dxi
14908         ymedi=c(2,i)+0.5d0*dyi
14909         zmedi=c(3,i)+0.5d0*dzi
14910           xmedi=dmod(xmedi,boxxsize)
14911           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14912           ymedi=dmod(ymedi,boxysize)
14913           if (ymedi.lt.0) ymedi=ymedi+boxysize
14914           zmedi=dmod(zmedi,boxzsize)
14915           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14916         num_conti=num_cont_hb(i)
14917         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14918         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14919           call eturn4(i,eello_turn4)
14920         num_cont_hb(i)=num_conti
14921       enddo   ! i
14922 !
14923 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14924 !
14925       do i=iatel_s,iatel_e
14926         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14927         dxi=dc(1,i)
14928         dyi=dc(2,i)
14929         dzi=dc(3,i)
14930         dx_normi=dc_norm(1,i)
14931         dy_normi=dc_norm(2,i)
14932         dz_normi=dc_norm(3,i)
14933         xmedi=c(1,i)+0.5d0*dxi
14934         ymedi=c(2,i)+0.5d0*dyi
14935         zmedi=c(3,i)+0.5d0*dzi
14936           xmedi=dmod(xmedi,boxxsize)
14937           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14938           ymedi=dmod(ymedi,boxysize)
14939           if (ymedi.lt.0) ymedi=ymedi+boxysize
14940           zmedi=dmod(zmedi,boxzsize)
14941           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14942 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14943         num_conti=num_cont_hb(i)
14944         do j=ielstart(i),ielend(i)
14945           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14946           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14947         enddo ! j
14948         num_cont_hb(i)=num_conti
14949       enddo   ! i
14950 !      write (iout,*) "Number of loop steps in EELEC:",ind
14951 !d      do i=1,nres
14952 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14953 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14954 !d      enddo
14955 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14956 !cc      eel_loc=eel_loc+eello_turn3
14957 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14958       return
14959       end subroutine eelec_scale
14960 !-----------------------------------------------------------------------------
14961       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14962 !      implicit real*8 (a-h,o-z)
14963
14964       use comm_locel
14965 !      include 'DIMENSIONS'
14966 #ifdef MPI
14967       include "mpif.h"
14968 #endif
14969 !      include 'COMMON.CONTROL'
14970 !      include 'COMMON.IOUNITS'
14971 !      include 'COMMON.GEO'
14972 !      include 'COMMON.VAR'
14973 !      include 'COMMON.LOCAL'
14974 !      include 'COMMON.CHAIN'
14975 !      include 'COMMON.DERIV'
14976 !      include 'COMMON.INTERACT'
14977 !      include 'COMMON.CONTACTS'
14978 !      include 'COMMON.TORSION'
14979 !      include 'COMMON.VECTORS'
14980 !      include 'COMMON.FFIELD'
14981 !      include 'COMMON.TIME1'
14982       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14983       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14984       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14985 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14986       real(kind=8),dimension(4) :: muij
14987       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14988                     dist_temp, dist_init,sss_grad
14989       integer xshift,yshift,zshift
14990
14991 !el      integer :: num_conti,j1,j2
14992 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14993 !el                   dz_normi,xmedi,ymedi,zmedi
14994 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14995 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14996 !el          num_conti,j1,j2
14997 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14998 #ifdef MOMENT
14999       real(kind=8) :: scal_el=1.0d0
15000 #else
15001       real(kind=8) :: scal_el=0.5d0
15002 #endif
15003 ! 12/13/98
15004 ! 13-go grudnia roku pamietnego...
15005       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15006                                              0.0d0,1.0d0,0.0d0,&
15007                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15008 !el local variables
15009       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15010       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15011       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15012       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15013       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15014       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15015       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15016                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15017                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15018                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15019                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15020                   ecosam,ecosbm,ecosgm,ghalf,time00
15021 !      integer :: maxconts
15022 !      maxconts = nres/4
15023 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15024 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15025 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15026 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15027 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15028 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15029 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15030 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15031 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15032 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15033 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15034 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15035 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15036
15037 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15038 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15039
15040 #ifdef MPI
15041           time00=MPI_Wtime()
15042 #endif
15043 !d      write (iout,*) "eelecij",i,j
15044 !el          ind=ind+1
15045           iteli=itel(i)
15046           itelj=itel(j)
15047           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15048           aaa=app(iteli,itelj)
15049           bbb=bpp(iteli,itelj)
15050           ael6i=ael6(iteli,itelj)
15051           ael3i=ael3(iteli,itelj)
15052           dxj=dc(1,j)
15053           dyj=dc(2,j)
15054           dzj=dc(3,j)
15055           dx_normj=dc_norm(1,j)
15056           dy_normj=dc_norm(2,j)
15057           dz_normj=dc_norm(3,j)
15058 !          xj=c(1,j)+0.5D0*dxj-xmedi
15059 !          yj=c(2,j)+0.5D0*dyj-ymedi
15060 !          zj=c(3,j)+0.5D0*dzj-zmedi
15061           xj=c(1,j)+0.5D0*dxj
15062           yj=c(2,j)+0.5D0*dyj
15063           zj=c(3,j)+0.5D0*dzj
15064           xj=mod(xj,boxxsize)
15065           if (xj.lt.0) xj=xj+boxxsize
15066           yj=mod(yj,boxysize)
15067           if (yj.lt.0) yj=yj+boxysize
15068           zj=mod(zj,boxzsize)
15069           if (zj.lt.0) zj=zj+boxzsize
15070       isubchap=0
15071       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15072       xj_safe=xj
15073       yj_safe=yj
15074       zj_safe=zj
15075       do xshift=-1,1
15076       do yshift=-1,1
15077       do zshift=-1,1
15078           xj=xj_safe+xshift*boxxsize
15079           yj=yj_safe+yshift*boxysize
15080           zj=zj_safe+zshift*boxzsize
15081           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15082           if(dist_temp.lt.dist_init) then
15083             dist_init=dist_temp
15084             xj_temp=xj
15085             yj_temp=yj
15086             zj_temp=zj
15087             isubchap=1
15088           endif
15089        enddo
15090        enddo
15091        enddo
15092        if (isubchap.eq.1) then
15093 !C          print *,i,j
15094           xj=xj_temp-xmedi
15095           yj=yj_temp-ymedi
15096           zj=zj_temp-zmedi
15097        else
15098           xj=xj_safe-xmedi
15099           yj=yj_safe-ymedi
15100           zj=zj_safe-zmedi
15101        endif
15102
15103           rij=xj*xj+yj*yj+zj*zj
15104           rrmij=1.0D0/rij
15105           rij=dsqrt(rij)
15106           rmij=1.0D0/rij
15107 ! For extracting the short-range part of Evdwpp
15108           sss=sscale(rij/rpp(iteli,itelj))
15109             sss_ele_cut=sscale_ele(rij)
15110             sss_ele_grad=sscagrad_ele(rij)
15111             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15112 !             sss_ele_cut=1.0d0
15113 !             sss_ele_grad=0.0d0
15114             if (sss_ele_cut.le.0.0) go to 128
15115
15116           r3ij=rrmij*rmij
15117           r6ij=r3ij*r3ij
15118           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15119           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15120           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15121           fac=cosa-3.0D0*cosb*cosg
15122           ev1=aaa*r6ij*r6ij
15123 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15124           if (j.eq.i+2) ev1=scal_el*ev1
15125           ev2=bbb*r6ij
15126           fac3=ael6i*r6ij
15127           fac4=ael3i*r3ij
15128           evdwij=ev1+ev2
15129           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15130           el2=fac4*fac
15131           eesij=el1+el2
15132 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15133           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15134           ees=ees+eesij*sss_ele_cut
15135           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15136 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15137 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15138 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15139 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15140
15141           if (energy_dec) then
15142               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15143               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15144           endif
15145
15146 !
15147 ! Calculate contributions to the Cartesian gradient.
15148 !
15149 #ifdef SPLITELE
15150           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15151           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15152           fac1=fac
15153           erij(1)=xj*rmij
15154           erij(2)=yj*rmij
15155           erij(3)=zj*rmij
15156 !
15157 ! Radial derivatives. First process both termini of the fragment (i,j)
15158 !
15159           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15160           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15161           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15162 !          do k=1,3
15163 !            ghalf=0.5D0*ggg(k)
15164 !            gelc(k,i)=gelc(k,i)+ghalf
15165 !            gelc(k,j)=gelc(k,j)+ghalf
15166 !          enddo
15167 ! 9/28/08 AL Gradient compotents will be summed only at the end
15168           do k=1,3
15169             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15170             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15171           enddo
15172 !
15173 ! Loop over residues i+1 thru j-1.
15174 !
15175 !grad          do k=i+1,j-1
15176 !grad            do l=1,3
15177 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15178 !grad            enddo
15179 !grad          enddo
15180           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15181           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15182           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15183           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15184           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15185           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15186 !          do k=1,3
15187 !            ghalf=0.5D0*ggg(k)
15188 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15189 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15190 !          enddo
15191 ! 9/28/08 AL Gradient compotents will be summed only at the end
15192           do k=1,3
15193             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15194             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15195           enddo
15196 !
15197 ! Loop over residues i+1 thru j-1.
15198 !
15199 !grad          do k=i+1,j-1
15200 !grad            do l=1,3
15201 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15202 !grad            enddo
15203 !grad          enddo
15204 #else
15205           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15206           facel=(el1+eesij)*sss_ele_cut
15207           fac1=fac
15208           fac=-3*rrmij*(facvdw+facvdw+facel)
15209           erij(1)=xj*rmij
15210           erij(2)=yj*rmij
15211           erij(3)=zj*rmij
15212 !
15213 ! Radial derivatives. First process both termini of the fragment (i,j)
15214 !
15215           ggg(1)=fac*xj
15216           ggg(2)=fac*yj
15217           ggg(3)=fac*zj
15218 !          do k=1,3
15219 !            ghalf=0.5D0*ggg(k)
15220 !            gelc(k,i)=gelc(k,i)+ghalf
15221 !            gelc(k,j)=gelc(k,j)+ghalf
15222 !          enddo
15223 ! 9/28/08 AL Gradient compotents will be summed only at the end
15224           do k=1,3
15225             gelc_long(k,j)=gelc(k,j)+ggg(k)
15226             gelc_long(k,i)=gelc(k,i)-ggg(k)
15227           enddo
15228 !
15229 ! Loop over residues i+1 thru j-1.
15230 !
15231 !grad          do k=i+1,j-1
15232 !grad            do l=1,3
15233 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15234 !grad            enddo
15235 !grad          enddo
15236 ! 9/28/08 AL Gradient compotents will be summed only at the end
15237           ggg(1)=facvdw*xj
15238           ggg(2)=facvdw*yj
15239           ggg(3)=facvdw*zj
15240           do k=1,3
15241             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15242             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15243           enddo
15244 #endif
15245 !
15246 ! Angular part
15247 !
15248           ecosa=2.0D0*fac3*fac1+fac4
15249           fac4=-3.0D0*fac4
15250           fac3=-6.0D0*fac3
15251           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15252           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15253           do k=1,3
15254             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15255             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15256           enddo
15257 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15258 !d   &          (dcosg(k),k=1,3)
15259           do k=1,3
15260             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15261           enddo
15262 !          do k=1,3
15263 !            ghalf=0.5D0*ggg(k)
15264 !            gelc(k,i)=gelc(k,i)+ghalf
15265 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15266 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15267 !            gelc(k,j)=gelc(k,j)+ghalf
15268 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15269 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15270 !          enddo
15271 !grad          do k=i+1,j-1
15272 !grad            do l=1,3
15273 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15274 !grad            enddo
15275 !grad          enddo
15276           do k=1,3
15277             gelc(k,i)=gelc(k,i) &
15278                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15279                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15280                      *sss_ele_cut
15281             gelc(k,j)=gelc(k,j) &
15282                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15283                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15284                      *sss_ele_cut
15285             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15286             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15287           enddo
15288           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15289               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15290               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15291 !
15292 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15293 !   energy of a peptide unit is assumed in the form of a second-order
15294 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15295 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15296 !   are computed for EVERY pair of non-contiguous peptide groups.
15297 !
15298           if (j.lt.nres-1) then
15299             j1=j+1
15300             j2=j-1
15301           else
15302             j1=j-1
15303             j2=j-2
15304           endif
15305           kkk=0
15306           do k=1,2
15307             do l=1,2
15308               kkk=kkk+1
15309               muij(kkk)=mu(k,i)*mu(l,j)
15310             enddo
15311           enddo
15312 !d         write (iout,*) 'EELEC: i',i,' j',j
15313 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15314 !d          write(iout,*) 'muij',muij
15315           ury=scalar(uy(1,i),erij)
15316           urz=scalar(uz(1,i),erij)
15317           vry=scalar(uy(1,j),erij)
15318           vrz=scalar(uz(1,j),erij)
15319           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15320           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15321           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15322           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15323           fac=dsqrt(-ael6i)*r3ij
15324           a22=a22*fac
15325           a23=a23*fac
15326           a32=a32*fac
15327           a33=a33*fac
15328 !d          write (iout,'(4i5,4f10.5)')
15329 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15330 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15331 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15332 !d     &      uy(:,j),uz(:,j)
15333 !d          write (iout,'(4f10.5)')
15334 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15335 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15336 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15337 !d           write (iout,'(9f10.5/)')
15338 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15339 ! Derivatives of the elements of A in virtual-bond vectors
15340           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15341           do k=1,3
15342             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15343             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15344             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15345             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15346             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15347             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15348             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15349             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15350             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15351             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15352             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15353             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15354           enddo
15355 ! Compute radial contributions to the gradient
15356           facr=-3.0d0*rrmij
15357           a22der=a22*facr
15358           a23der=a23*facr
15359           a32der=a32*facr
15360           a33der=a33*facr
15361           agg(1,1)=a22der*xj
15362           agg(2,1)=a22der*yj
15363           agg(3,1)=a22der*zj
15364           agg(1,2)=a23der*xj
15365           agg(2,2)=a23der*yj
15366           agg(3,2)=a23der*zj
15367           agg(1,3)=a32der*xj
15368           agg(2,3)=a32der*yj
15369           agg(3,3)=a32der*zj
15370           agg(1,4)=a33der*xj
15371           agg(2,4)=a33der*yj
15372           agg(3,4)=a33der*zj
15373 ! Add the contributions coming from er
15374           fac3=-3.0d0*fac
15375           do k=1,3
15376             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15377             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15378             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15379             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15380           enddo
15381           do k=1,3
15382 ! Derivatives in DC(i)
15383 !grad            ghalf1=0.5d0*agg(k,1)
15384 !grad            ghalf2=0.5d0*agg(k,2)
15385 !grad            ghalf3=0.5d0*agg(k,3)
15386 !grad            ghalf4=0.5d0*agg(k,4)
15387             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15388             -3.0d0*uryg(k,2)*vry)!+ghalf1
15389             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15390             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15391             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15392             -3.0d0*urzg(k,2)*vry)!+ghalf3
15393             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15394             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15395 ! Derivatives in DC(i+1)
15396             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15397             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15398             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15399             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15400             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15401             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15402             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15403             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15404 ! Derivatives in DC(j)
15405             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15406             -3.0d0*vryg(k,2)*ury)!+ghalf1
15407             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15408             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15409             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15410             -3.0d0*vryg(k,2)*urz)!+ghalf3
15411             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15412             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15413 ! Derivatives in DC(j+1) or DC(nres-1)
15414             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15415             -3.0d0*vryg(k,3)*ury)
15416             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15417             -3.0d0*vrzg(k,3)*ury)
15418             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15419             -3.0d0*vryg(k,3)*urz)
15420             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15421             -3.0d0*vrzg(k,3)*urz)
15422 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15423 !grad              do l=1,4
15424 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15425 !grad              enddo
15426 !grad            endif
15427           enddo
15428           acipa(1,1)=a22
15429           acipa(1,2)=a23
15430           acipa(2,1)=a32
15431           acipa(2,2)=a33
15432           a22=-a22
15433           a23=-a23
15434           do l=1,2
15435             do k=1,3
15436               agg(k,l)=-agg(k,l)
15437               aggi(k,l)=-aggi(k,l)
15438               aggi1(k,l)=-aggi1(k,l)
15439               aggj(k,l)=-aggj(k,l)
15440               aggj1(k,l)=-aggj1(k,l)
15441             enddo
15442           enddo
15443           if (j.lt.nres-1) then
15444             a22=-a22
15445             a32=-a32
15446             do l=1,3,2
15447               do k=1,3
15448                 agg(k,l)=-agg(k,l)
15449                 aggi(k,l)=-aggi(k,l)
15450                 aggi1(k,l)=-aggi1(k,l)
15451                 aggj(k,l)=-aggj(k,l)
15452                 aggj1(k,l)=-aggj1(k,l)
15453               enddo
15454             enddo
15455           else
15456             a22=-a22
15457             a23=-a23
15458             a32=-a32
15459             a33=-a33
15460             do l=1,4
15461               do k=1,3
15462                 agg(k,l)=-agg(k,l)
15463                 aggi(k,l)=-aggi(k,l)
15464                 aggi1(k,l)=-aggi1(k,l)
15465                 aggj(k,l)=-aggj(k,l)
15466                 aggj1(k,l)=-aggj1(k,l)
15467               enddo
15468             enddo
15469           endif
15470           ENDIF ! WCORR
15471           IF (wel_loc.gt.0.0d0) THEN
15472 ! Contribution to the local-electrostatic energy coming from the i-j pair
15473           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15474            +a33*muij(4)
15475 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15476 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15477           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15478                   'eelloc',i,j,eel_loc_ij
15479 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15480
15481           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15482 ! Partial derivatives in virtual-bond dihedral angles gamma
15483           if (i.gt.1) &
15484           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15485                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15486                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15487                  *sss_ele_cut
15488           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15489                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15490                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15491                  *sss_ele_cut
15492            xtemp(1)=xj
15493            xtemp(2)=yj
15494            xtemp(3)=zj
15495
15496 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15497           do l=1,3
15498             ggg(l)=(agg(l,1)*muij(1)+ &
15499                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15500             *sss_ele_cut &
15501              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15502
15503             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15504             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15505 !grad            ghalf=0.5d0*ggg(l)
15506 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15507 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15508           enddo
15509 !grad          do k=i+1,j2
15510 !grad            do l=1,3
15511 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15512 !grad            enddo
15513 !grad          enddo
15514 ! Remaining derivatives of eello
15515           do l=1,3
15516             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15517                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15518             *sss_ele_cut
15519
15520             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15521                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15522             *sss_ele_cut
15523
15524             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15525                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15526             *sss_ele_cut
15527
15528             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15529                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15530             *sss_ele_cut
15531
15532           enddo
15533           ENDIF
15534 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15535 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15536           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15537              .and. num_conti.le.maxconts) then
15538 !            write (iout,*) i,j," entered corr"
15539 !
15540 ! Calculate the contact function. The ith column of the array JCONT will
15541 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15542 ! greater than I). The arrays FACONT and GACONT will contain the values of
15543 ! the contact function and its derivative.
15544 !           r0ij=1.02D0*rpp(iteli,itelj)
15545 !           r0ij=1.11D0*rpp(iteli,itelj)
15546             r0ij=2.20D0*rpp(iteli,itelj)
15547 !           r0ij=1.55D0*rpp(iteli,itelj)
15548             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15549 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15550             if (fcont.gt.0.0D0) then
15551               num_conti=num_conti+1
15552               if (num_conti.gt.maxconts) then
15553 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15554                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15555                                ' will skip next contacts for this conf.',num_conti
15556               else
15557                 jcont_hb(num_conti,i)=j
15558 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15559 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15560                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15561                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15562 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15563 !  terms.
15564                 d_cont(num_conti,i)=rij
15565 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15566 !     --- Electrostatic-interaction matrix ---
15567                 a_chuj(1,1,num_conti,i)=a22
15568                 a_chuj(1,2,num_conti,i)=a23
15569                 a_chuj(2,1,num_conti,i)=a32
15570                 a_chuj(2,2,num_conti,i)=a33
15571 !     --- Gradient of rij
15572                 do kkk=1,3
15573                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15574                 enddo
15575                 kkll=0
15576                 do k=1,2
15577                   do l=1,2
15578                     kkll=kkll+1
15579                     do m=1,3
15580                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15581                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15582                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15583                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15584                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15585                     enddo
15586                   enddo
15587                 enddo
15588                 ENDIF
15589                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15590 ! Calculate contact energies
15591                 cosa4=4.0D0*cosa
15592                 wij=cosa-3.0D0*cosb*cosg
15593                 cosbg1=cosb+cosg
15594                 cosbg2=cosb-cosg
15595 !               fac3=dsqrt(-ael6i)/r0ij**3
15596                 fac3=dsqrt(-ael6i)*r3ij
15597 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15598                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15599                 if (ees0tmp.gt.0) then
15600                   ees0pij=dsqrt(ees0tmp)
15601                 else
15602                   ees0pij=0
15603                 endif
15604 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15605                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15606                 if (ees0tmp.gt.0) then
15607                   ees0mij=dsqrt(ees0tmp)
15608                 else
15609                   ees0mij=0
15610                 endif
15611 !               ees0mij=0.0D0
15612                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15613                      *sss_ele_cut
15614
15615                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15616                      *sss_ele_cut
15617
15618 ! Diagnostics. Comment out or remove after debugging!
15619 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15620 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15621 !               ees0m(num_conti,i)=0.0D0
15622 ! End diagnostics.
15623 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15624 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15625 ! Angular derivatives of the contact function
15626                 ees0pij1=fac3/ees0pij
15627                 ees0mij1=fac3/ees0mij
15628                 fac3p=-3.0D0*fac3*rrmij
15629                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15630                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15631 !               ees0mij1=0.0D0
15632                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15633                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15634                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15635                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15636                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15637                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15638                 ecosap=ecosa1+ecosa2
15639                 ecosbp=ecosb1+ecosb2
15640                 ecosgp=ecosg1+ecosg2
15641                 ecosam=ecosa1-ecosa2
15642                 ecosbm=ecosb1-ecosb2
15643                 ecosgm=ecosg1-ecosg2
15644 ! Diagnostics
15645 !               ecosap=ecosa1
15646 !               ecosbp=ecosb1
15647 !               ecosgp=ecosg1
15648 !               ecosam=0.0D0
15649 !               ecosbm=0.0D0
15650 !               ecosgm=0.0D0
15651 ! End diagnostics
15652                 facont_hb(num_conti,i)=fcont
15653                 fprimcont=fprimcont/rij
15654 !d              facont_hb(num_conti,i)=1.0D0
15655 ! Following line is for diagnostics.
15656 !d              fprimcont=0.0D0
15657                 do k=1,3
15658                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15659                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15660                 enddo
15661                 do k=1,3
15662                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15663                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15664                 enddo
15665 !                gggp(1)=gggp(1)+ees0pijp*xj
15666 !                gggp(2)=gggp(2)+ees0pijp*yj
15667 !                gggp(3)=gggp(3)+ees0pijp*zj
15668 !                gggm(1)=gggm(1)+ees0mijp*xj
15669 !                gggm(2)=gggm(2)+ees0mijp*yj
15670 !                gggm(3)=gggm(3)+ees0mijp*zj
15671                 gggp(1)=gggp(1)+ees0pijp*xj &
15672                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15673                 gggp(2)=gggp(2)+ees0pijp*yj &
15674                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15675                 gggp(3)=gggp(3)+ees0pijp*zj &
15676                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15677
15678                 gggm(1)=gggm(1)+ees0mijp*xj &
15679                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15680
15681                 gggm(2)=gggm(2)+ees0mijp*yj &
15682                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15683
15684                 gggm(3)=gggm(3)+ees0mijp*zj &
15685                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15686
15687 ! Derivatives due to the contact function
15688                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15689                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15690                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15691                 do k=1,3
15692 !
15693 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15694 !          following the change of gradient-summation algorithm.
15695 !
15696 !grad                  ghalfp=0.5D0*gggp(k)
15697 !grad                  ghalfm=0.5D0*gggm(k)
15698 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15699 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15700 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15701 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15702 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15703 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15704 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15705 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15706 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15707 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15708 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15709 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15710 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15711 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15712                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15713                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15714                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15715                      *sss_ele_cut
15716
15717                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15718                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15719                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15720                      *sss_ele_cut
15721
15722                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15723                      *sss_ele_cut
15724
15725                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15726                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15727                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15728                      *sss_ele_cut
15729
15730                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15731                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15732                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15733                      *sss_ele_cut
15734
15735                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15736                      *sss_ele_cut
15737
15738                 enddo
15739               ENDIF ! wcorr
15740               endif  ! num_conti.le.maxconts
15741             endif  ! fcont.gt.0
15742           endif    ! j.gt.i+1
15743           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15744             do k=1,4
15745               do l=1,3
15746                 ghalf=0.5d0*agg(l,k)
15747                 aggi(l,k)=aggi(l,k)+ghalf
15748                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15749                 aggj(l,k)=aggj(l,k)+ghalf
15750               enddo
15751             enddo
15752             if (j.eq.nres-1 .and. i.lt.j-2) then
15753               do k=1,4
15754                 do l=1,3
15755                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15756                 enddo
15757               enddo
15758             endif
15759           endif
15760  128      continue
15761 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15762       return
15763       end subroutine eelecij_scale
15764 !-----------------------------------------------------------------------------
15765       subroutine evdwpp_short(evdw1)
15766 !
15767 ! Compute Evdwpp
15768 !
15769 !      implicit real*8 (a-h,o-z)
15770 !      include 'DIMENSIONS'
15771 !      include 'COMMON.CONTROL'
15772 !      include 'COMMON.IOUNITS'
15773 !      include 'COMMON.GEO'
15774 !      include 'COMMON.VAR'
15775 !      include 'COMMON.LOCAL'
15776 !      include 'COMMON.CHAIN'
15777 !      include 'COMMON.DERIV'
15778 !      include 'COMMON.INTERACT'
15779 !      include 'COMMON.CONTACTS'
15780 !      include 'COMMON.TORSION'
15781 !      include 'COMMON.VECTORS'
15782 !      include 'COMMON.FFIELD'
15783       real(kind=8),dimension(3) :: ggg
15784 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15785 #ifdef MOMENT
15786       real(kind=8) :: scal_el=1.0d0
15787 #else
15788       real(kind=8) :: scal_el=0.5d0
15789 #endif
15790 !el local variables
15791       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15792       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15793       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15794                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15795                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15796       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15797                     dist_temp, dist_init,sss_grad
15798       integer xshift,yshift,zshift
15799
15800
15801       evdw1=0.0D0
15802 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15803 !     & " iatel_e_vdw",iatel_e_vdw
15804       call flush(iout)
15805       do i=iatel_s_vdw,iatel_e_vdw
15806         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15807         dxi=dc(1,i)
15808         dyi=dc(2,i)
15809         dzi=dc(3,i)
15810         dx_normi=dc_norm(1,i)
15811         dy_normi=dc_norm(2,i)
15812         dz_normi=dc_norm(3,i)
15813         xmedi=c(1,i)+0.5d0*dxi
15814         ymedi=c(2,i)+0.5d0*dyi
15815         zmedi=c(3,i)+0.5d0*dzi
15816           xmedi=dmod(xmedi,boxxsize)
15817           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15818           ymedi=dmod(ymedi,boxysize)
15819           if (ymedi.lt.0) ymedi=ymedi+boxysize
15820           zmedi=dmod(zmedi,boxzsize)
15821           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15822         num_conti=0
15823 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15824 !     &   ' ielend',ielend_vdw(i)
15825         call flush(iout)
15826         do j=ielstart_vdw(i),ielend_vdw(i)
15827           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15828 !el          ind=ind+1
15829           iteli=itel(i)
15830           itelj=itel(j)
15831           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15832           aaa=app(iteli,itelj)
15833           bbb=bpp(iteli,itelj)
15834           dxj=dc(1,j)
15835           dyj=dc(2,j)
15836           dzj=dc(3,j)
15837           dx_normj=dc_norm(1,j)
15838           dy_normj=dc_norm(2,j)
15839           dz_normj=dc_norm(3,j)
15840 !          xj=c(1,j)+0.5D0*dxj-xmedi
15841 !          yj=c(2,j)+0.5D0*dyj-ymedi
15842 !          zj=c(3,j)+0.5D0*dzj-zmedi
15843           xj=c(1,j)+0.5D0*dxj
15844           yj=c(2,j)+0.5D0*dyj
15845           zj=c(3,j)+0.5D0*dzj
15846           xj=mod(xj,boxxsize)
15847           if (xj.lt.0) xj=xj+boxxsize
15848           yj=mod(yj,boxysize)
15849           if (yj.lt.0) yj=yj+boxysize
15850           zj=mod(zj,boxzsize)
15851           if (zj.lt.0) zj=zj+boxzsize
15852       isubchap=0
15853       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15854       xj_safe=xj
15855       yj_safe=yj
15856       zj_safe=zj
15857       do xshift=-1,1
15858       do yshift=-1,1
15859       do zshift=-1,1
15860           xj=xj_safe+xshift*boxxsize
15861           yj=yj_safe+yshift*boxysize
15862           zj=zj_safe+zshift*boxzsize
15863           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15864           if(dist_temp.lt.dist_init) then
15865             dist_init=dist_temp
15866             xj_temp=xj
15867             yj_temp=yj
15868             zj_temp=zj
15869             isubchap=1
15870           endif
15871        enddo
15872        enddo
15873        enddo
15874        if (isubchap.eq.1) then
15875 !C          print *,i,j
15876           xj=xj_temp-xmedi
15877           yj=yj_temp-ymedi
15878           zj=zj_temp-zmedi
15879        else
15880           xj=xj_safe-xmedi
15881           yj=yj_safe-ymedi
15882           zj=zj_safe-zmedi
15883        endif
15884
15885           rij=xj*xj+yj*yj+zj*zj
15886           rrmij=1.0D0/rij
15887           rij=dsqrt(rij)
15888           sss=sscale(rij/rpp(iteli,itelj))
15889             sss_ele_cut=sscale_ele(rij)
15890             sss_ele_grad=sscagrad_ele(rij)
15891             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15892             if (sss_ele_cut.le.0.0) cycle
15893           if (sss.gt.0.0d0) then
15894             rmij=1.0D0/rij
15895             r3ij=rrmij*rmij
15896             r6ij=r3ij*r3ij
15897             ev1=aaa*r6ij*r6ij
15898 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15899             if (j.eq.i+2) ev1=scal_el*ev1
15900             ev2=bbb*r6ij
15901             evdwij=ev1+ev2
15902             if (energy_dec) then
15903               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15904             endif
15905             evdw1=evdw1+evdwij*sss*sss_ele_cut
15906 !
15907 ! Calculate contributions to the Cartesian gradient.
15908 !
15909             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15910 !            ggg(1)=facvdw*xj
15911 !            ggg(2)=facvdw*yj
15912 !            ggg(3)=facvdw*zj
15913           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15914           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15915           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15916           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15917           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15918           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15919
15920             do k=1,3
15921               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15922               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15923             enddo
15924           endif
15925         enddo ! j
15926       enddo   ! i
15927       return
15928       end subroutine evdwpp_short
15929 !-----------------------------------------------------------------------------
15930       subroutine escp_long(evdw2,evdw2_14)
15931 !
15932 ! This subroutine calculates the excluded-volume interaction energy between
15933 ! peptide-group centers and side chains and its gradient in virtual-bond and
15934 ! side-chain vectors.
15935 !
15936 !      implicit real*8 (a-h,o-z)
15937 !      include 'DIMENSIONS'
15938 !      include 'COMMON.GEO'
15939 !      include 'COMMON.VAR'
15940 !      include 'COMMON.LOCAL'
15941 !      include 'COMMON.CHAIN'
15942 !      include 'COMMON.DERIV'
15943 !      include 'COMMON.INTERACT'
15944 !      include 'COMMON.FFIELD'
15945 !      include 'COMMON.IOUNITS'
15946 !      include 'COMMON.CONTROL'
15947       real(kind=8),dimension(3) :: ggg
15948 !el local variables
15949       integer :: i,iint,j,k,iteli,itypj,subchap
15950       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15951       real(kind=8) :: evdw2,evdw2_14,evdwij
15952       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15953                     dist_temp, dist_init
15954
15955       evdw2=0.0D0
15956       evdw2_14=0.0d0
15957 !d    print '(a)','Enter ESCP'
15958 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15959       do i=iatscp_s,iatscp_e
15960         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15961         iteli=itel(i)
15962         xi=0.5D0*(c(1,i)+c(1,i+1))
15963         yi=0.5D0*(c(2,i)+c(2,i+1))
15964         zi=0.5D0*(c(3,i)+c(3,i+1))
15965           xi=mod(xi,boxxsize)
15966           if (xi.lt.0) xi=xi+boxxsize
15967           yi=mod(yi,boxysize)
15968           if (yi.lt.0) yi=yi+boxysize
15969           zi=mod(zi,boxzsize)
15970           if (zi.lt.0) zi=zi+boxzsize
15971
15972         do iint=1,nscp_gr(i)
15973
15974         do j=iscpstart(i,iint),iscpend(i,iint)
15975           itypj=itype(j,1)
15976           if (itypj.eq.ntyp1) cycle
15977 ! Uncomment following three lines for SC-p interactions
15978 !         xj=c(1,nres+j)-xi
15979 !         yj=c(2,nres+j)-yi
15980 !         zj=c(3,nres+j)-zi
15981 ! Uncomment following three lines for Ca-p interactions
15982           xj=c(1,j)
15983           yj=c(2,j)
15984           zj=c(3,j)
15985           xj=mod(xj,boxxsize)
15986           if (xj.lt.0) xj=xj+boxxsize
15987           yj=mod(yj,boxysize)
15988           if (yj.lt.0) yj=yj+boxysize
15989           zj=mod(zj,boxzsize)
15990           if (zj.lt.0) zj=zj+boxzsize
15991       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15992       xj_safe=xj
15993       yj_safe=yj
15994       zj_safe=zj
15995       subchap=0
15996       do xshift=-1,1
15997       do yshift=-1,1
15998       do zshift=-1,1
15999           xj=xj_safe+xshift*boxxsize
16000           yj=yj_safe+yshift*boxysize
16001           zj=zj_safe+zshift*boxzsize
16002           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16003           if(dist_temp.lt.dist_init) then
16004             dist_init=dist_temp
16005             xj_temp=xj
16006             yj_temp=yj
16007             zj_temp=zj
16008             subchap=1
16009           endif
16010        enddo
16011        enddo
16012        enddo
16013        if (subchap.eq.1) then
16014           xj=xj_temp-xi
16015           yj=yj_temp-yi
16016           zj=zj_temp-zi
16017        else
16018           xj=xj_safe-xi
16019           yj=yj_safe-yi
16020           zj=zj_safe-zi
16021        endif
16022           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16023
16024           rij=dsqrt(1.0d0/rrij)
16025             sss_ele_cut=sscale_ele(rij)
16026             sss_ele_grad=sscagrad_ele(rij)
16027 !            print *,sss_ele_cut,sss_ele_grad,&
16028 !            (rij),r_cut_ele,rlamb_ele
16029             if (sss_ele_cut.le.0.0) cycle
16030           sss=sscale((rij/rscp(itypj,iteli)))
16031           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16032           if (sss.lt.1.0d0) then
16033
16034             fac=rrij**expon2
16035             e1=fac*fac*aad(itypj,iteli)
16036             e2=fac*bad(itypj,iteli)
16037             if (iabs(j-i) .le. 2) then
16038               e1=scal14*e1
16039               e2=scal14*e2
16040               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16041             endif
16042             evdwij=e1+e2
16043             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16044             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16045                 'evdw2',i,j,sss,evdwij
16046 !
16047 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16048 !
16049             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16050             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16051             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16052             ggg(1)=xj*fac
16053             ggg(2)=yj*fac
16054             ggg(3)=zj*fac
16055 ! Uncomment following three lines for SC-p interactions
16056 !           do k=1,3
16057 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16058 !           enddo
16059 ! Uncomment following line for SC-p interactions
16060 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16061             do k=1,3
16062               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16063               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16064             enddo
16065           endif
16066         enddo
16067
16068         enddo ! iint
16069       enddo ! i
16070       do i=1,nct
16071         do j=1,3
16072           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16073           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16074           gradx_scp(j,i)=expon*gradx_scp(j,i)
16075         enddo
16076       enddo
16077 !******************************************************************************
16078 !
16079 !                              N O T E !!!
16080 !
16081 ! To save time the factor EXPON has been extracted from ALL components
16082 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16083 ! use!
16084 !
16085 !******************************************************************************
16086       return
16087       end subroutine escp_long
16088 !-----------------------------------------------------------------------------
16089       subroutine escp_short(evdw2,evdw2_14)
16090 !
16091 ! This subroutine calculates the excluded-volume interaction energy between
16092 ! peptide-group centers and side chains and its gradient in virtual-bond and
16093 ! side-chain vectors.
16094 !
16095 !      implicit real*8 (a-h,o-z)
16096 !      include 'DIMENSIONS'
16097 !      include 'COMMON.GEO'
16098 !      include 'COMMON.VAR'
16099 !      include 'COMMON.LOCAL'
16100 !      include 'COMMON.CHAIN'
16101 !      include 'COMMON.DERIV'
16102 !      include 'COMMON.INTERACT'
16103 !      include 'COMMON.FFIELD'
16104 !      include 'COMMON.IOUNITS'
16105 !      include 'COMMON.CONTROL'
16106       real(kind=8),dimension(3) :: ggg
16107 !el local variables
16108       integer :: i,iint,j,k,iteli,itypj,subchap
16109       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16110       real(kind=8) :: evdw2,evdw2_14,evdwij
16111       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16112                     dist_temp, dist_init
16113
16114       evdw2=0.0D0
16115       evdw2_14=0.0d0
16116 !d    print '(a)','Enter ESCP'
16117 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16118       do i=iatscp_s,iatscp_e
16119         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16120         iteli=itel(i)
16121         xi=0.5D0*(c(1,i)+c(1,i+1))
16122         yi=0.5D0*(c(2,i)+c(2,i+1))
16123         zi=0.5D0*(c(3,i)+c(3,i+1))
16124           xi=mod(xi,boxxsize)
16125           if (xi.lt.0) xi=xi+boxxsize
16126           yi=mod(yi,boxysize)
16127           if (yi.lt.0) yi=yi+boxysize
16128           zi=mod(zi,boxzsize)
16129           if (zi.lt.0) zi=zi+boxzsize
16130
16131         do iint=1,nscp_gr(i)
16132
16133         do j=iscpstart(i,iint),iscpend(i,iint)
16134           itypj=itype(j,1)
16135           if (itypj.eq.ntyp1) cycle
16136 ! Uncomment following three lines for SC-p interactions
16137 !         xj=c(1,nres+j)-xi
16138 !         yj=c(2,nres+j)-yi
16139 !         zj=c(3,nres+j)-zi
16140 ! Uncomment following three lines for Ca-p interactions
16141 !          xj=c(1,j)-xi
16142 !          yj=c(2,j)-yi
16143 !          zj=c(3,j)-zi
16144           xj=c(1,j)
16145           yj=c(2,j)
16146           zj=c(3,j)
16147           xj=mod(xj,boxxsize)
16148           if (xj.lt.0) xj=xj+boxxsize
16149           yj=mod(yj,boxysize)
16150           if (yj.lt.0) yj=yj+boxysize
16151           zj=mod(zj,boxzsize)
16152           if (zj.lt.0) zj=zj+boxzsize
16153       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16154       xj_safe=xj
16155       yj_safe=yj
16156       zj_safe=zj
16157       subchap=0
16158       do xshift=-1,1
16159       do yshift=-1,1
16160       do zshift=-1,1
16161           xj=xj_safe+xshift*boxxsize
16162           yj=yj_safe+yshift*boxysize
16163           zj=zj_safe+zshift*boxzsize
16164           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16165           if(dist_temp.lt.dist_init) then
16166             dist_init=dist_temp
16167             xj_temp=xj
16168             yj_temp=yj
16169             zj_temp=zj
16170             subchap=1
16171           endif
16172        enddo
16173        enddo
16174        enddo
16175        if (subchap.eq.1) then
16176           xj=xj_temp-xi
16177           yj=yj_temp-yi
16178           zj=zj_temp-zi
16179        else
16180           xj=xj_safe-xi
16181           yj=yj_safe-yi
16182           zj=zj_safe-zi
16183        endif
16184
16185           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16186           rij=dsqrt(1.0d0/rrij)
16187             sss_ele_cut=sscale_ele(rij)
16188             sss_ele_grad=sscagrad_ele(rij)
16189 !            print *,sss_ele_cut,sss_ele_grad,&
16190 !            (rij),r_cut_ele,rlamb_ele
16191             if (sss_ele_cut.le.0.0) cycle
16192           sss=sscale(rij/rscp(itypj,iteli))
16193           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16194           if (sss.gt.0.0d0) then
16195
16196             fac=rrij**expon2
16197             e1=fac*fac*aad(itypj,iteli)
16198             e2=fac*bad(itypj,iteli)
16199             if (iabs(j-i) .le. 2) then
16200               e1=scal14*e1
16201               e2=scal14*e2
16202               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16203             endif
16204             evdwij=e1+e2
16205             evdw2=evdw2+evdwij*sss*sss_ele_cut
16206             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16207                 'evdw2',i,j,sss,evdwij
16208 !
16209 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16210 !
16211             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16212             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16213             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16214
16215             ggg(1)=xj*fac
16216             ggg(2)=yj*fac
16217             ggg(3)=zj*fac
16218 ! Uncomment following three lines for SC-p interactions
16219 !           do k=1,3
16220 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16221 !           enddo
16222 ! Uncomment following line for SC-p interactions
16223 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16224             do k=1,3
16225               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16226               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16227             enddo
16228           endif
16229         enddo
16230
16231         enddo ! iint
16232       enddo ! i
16233       do i=1,nct
16234         do j=1,3
16235           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16236           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16237           gradx_scp(j,i)=expon*gradx_scp(j,i)
16238         enddo
16239       enddo
16240 !******************************************************************************
16241 !
16242 !                              N O T E !!!
16243 !
16244 ! To save time the factor EXPON has been extracted from ALL components
16245 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16246 ! use!
16247 !
16248 !******************************************************************************
16249       return
16250       end subroutine escp_short
16251 !-----------------------------------------------------------------------------
16252 ! energy_p_new-sep_barrier.F
16253 !-----------------------------------------------------------------------------
16254       subroutine sc_grad_scale(scalfac)
16255 !      implicit real*8 (a-h,o-z)
16256       use calc_data
16257 !      include 'DIMENSIONS'
16258 !      include 'COMMON.CHAIN'
16259 !      include 'COMMON.DERIV'
16260 !      include 'COMMON.CALC'
16261 !      include 'COMMON.IOUNITS'
16262       real(kind=8),dimension(3) :: dcosom1,dcosom2
16263       real(kind=8) :: scalfac
16264 !el local variables
16265 !      integer :: i,j,k,l
16266
16267       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16268       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16269       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16270            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16271 ! diagnostics only
16272 !      eom1=0.0d0
16273 !      eom2=0.0d0
16274 !      eom12=evdwij*eps1_om12
16275 ! end diagnostics
16276 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16277 !     &  " sigder",sigder
16278 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16279 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16280       do k=1,3
16281         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16282         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16283       enddo
16284       do k=1,3
16285         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16286          *sss_ele_cut
16287       enddo
16288 !      write (iout,*) "gg",(gg(k),k=1,3)
16289       do k=1,3
16290         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16291                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16292                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16293                  *sss_ele_cut
16294         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16295                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16296                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16297          *sss_ele_cut
16298 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16299 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16300 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16301 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16302       enddo
16303 !
16304 ! Calculate the components of the gradient in DC and X
16305 !
16306       do l=1,3
16307         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16308         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16309       enddo
16310       return
16311       end subroutine sc_grad_scale
16312 !-----------------------------------------------------------------------------
16313 ! energy_split-sep.F
16314 !-----------------------------------------------------------------------------
16315       subroutine etotal_long(energia)
16316 !
16317 ! Compute the long-range slow-varying contributions to the energy
16318 !
16319 !      implicit real*8 (a-h,o-z)
16320 !      include 'DIMENSIONS'
16321       use MD_data, only: totT,usampl,eq_time
16322 #ifndef ISNAN
16323       external proc_proc
16324 #ifdef WINPGI
16325 !MS$ATTRIBUTES C ::  proc_proc
16326 #endif
16327 #endif
16328 #ifdef MPI
16329       include "mpif.h"
16330       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16331 #endif
16332 !      include 'COMMON.SETUP'
16333 !      include 'COMMON.IOUNITS'
16334 !      include 'COMMON.FFIELD'
16335 !      include 'COMMON.DERIV'
16336 !      include 'COMMON.INTERACT'
16337 !      include 'COMMON.SBRIDGE'
16338 !      include 'COMMON.CHAIN'
16339 !      include 'COMMON.VAR'
16340 !      include 'COMMON.LOCAL'
16341 !      include 'COMMON.MD'
16342       real(kind=8),dimension(0:n_ene) :: energia
16343 !el local variables
16344       integer :: i,n_corr,n_corr1,ierror,ierr
16345       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16346                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16347                   ecorr,ecorr5,ecorr6,eturn6,time00
16348 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16349 !elwrite(iout,*)"in etotal long"
16350
16351       if (modecalc.eq.12.or.modecalc.eq.14) then
16352 #ifdef MPI
16353 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16354 #else
16355         call int_from_cart1(.false.)
16356 #endif
16357       endif
16358 !elwrite(iout,*)"in etotal long"
16359
16360 #ifdef MPI
16361 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16362 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16363       call flush(iout)
16364       if (nfgtasks.gt.1) then
16365         time00=MPI_Wtime()
16366 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16367         if (fg_rank.eq.0) then
16368           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16369 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16370 !          call flush(iout)
16371 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16372 ! FG slaves as WEIGHTS array.
16373           weights_(1)=wsc
16374           weights_(2)=wscp
16375           weights_(3)=welec
16376           weights_(4)=wcorr
16377           weights_(5)=wcorr5
16378           weights_(6)=wcorr6
16379           weights_(7)=wel_loc
16380           weights_(8)=wturn3
16381           weights_(9)=wturn4
16382           weights_(10)=wturn6
16383           weights_(11)=wang
16384           weights_(12)=wscloc
16385           weights_(13)=wtor
16386           weights_(14)=wtor_d
16387           weights_(15)=wstrain
16388           weights_(16)=wvdwpp
16389           weights_(17)=wbond
16390           weights_(18)=scal14
16391           weights_(21)=wsccor
16392 ! FG Master broadcasts the WEIGHTS_ array
16393           call MPI_Bcast(weights_(1),n_ene,&
16394               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16395         else
16396 ! FG slaves receive the WEIGHTS array
16397           call MPI_Bcast(weights(1),n_ene,&
16398               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16399           wsc=weights(1)
16400           wscp=weights(2)
16401           welec=weights(3)
16402           wcorr=weights(4)
16403           wcorr5=weights(5)
16404           wcorr6=weights(6)
16405           wel_loc=weights(7)
16406           wturn3=weights(8)
16407           wturn4=weights(9)
16408           wturn6=weights(10)
16409           wang=weights(11)
16410           wscloc=weights(12)
16411           wtor=weights(13)
16412           wtor_d=weights(14)
16413           wstrain=weights(15)
16414           wvdwpp=weights(16)
16415           wbond=weights(17)
16416           scal14=weights(18)
16417           wsccor=weights(21)
16418         endif
16419         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16420           king,FG_COMM,IERR)
16421          time_Bcast=time_Bcast+MPI_Wtime()-time00
16422          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16423 !        call chainbuild_cart
16424 !        call int_from_cart1(.false.)
16425       endif
16426 !      write (iout,*) 'Processor',myrank,
16427 !     &  ' calling etotal_short ipot=',ipot
16428 !      call flush(iout)
16429 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16430 #endif
16431 !d    print *,'nnt=',nnt,' nct=',nct
16432 !
16433 !elwrite(iout,*)"in etotal long"
16434 ! Compute the side-chain and electrostatic interaction energy
16435 !
16436       goto (101,102,103,104,105,106) ipot
16437 ! Lennard-Jones potential.
16438   101 call elj_long(evdw)
16439 !d    print '(a)','Exit ELJ'
16440       goto 107
16441 ! Lennard-Jones-Kihara potential (shifted).
16442   102 call eljk_long(evdw)
16443       goto 107
16444 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16445   103 call ebp_long(evdw)
16446       goto 107
16447 ! Gay-Berne potential (shifted LJ, angular dependence).
16448   104 call egb_long(evdw)
16449       goto 107
16450 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16451   105 call egbv_long(evdw)
16452       goto 107
16453 ! Soft-sphere potential
16454   106 call e_softsphere(evdw)
16455 !
16456 ! Calculate electrostatic (H-bonding) energy of the main chain.
16457 !
16458   107 continue
16459       call vec_and_deriv
16460       if (ipot.lt.6) then
16461 #ifdef SPLITELE
16462          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16463              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16464              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16465              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16466 #else
16467          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16468              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16469              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16470              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16471 #endif
16472            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16473          else
16474             ees=0
16475             evdw1=0
16476             eel_loc=0
16477             eello_turn3=0
16478             eello_turn4=0
16479          endif
16480       else
16481 !        write (iout,*) "Soft-spheer ELEC potential"
16482         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16483          eello_turn4)
16484       endif
16485 !
16486 ! Calculate excluded-volume interaction energy between peptide groups
16487 ! and side chains.
16488 !
16489       if (ipot.lt.6) then
16490        if(wscp.gt.0d0) then
16491         call escp_long(evdw2,evdw2_14)
16492        else
16493         evdw2=0
16494         evdw2_14=0
16495        endif
16496       else
16497         call escp_soft_sphere(evdw2,evdw2_14)
16498       endif
16499 !
16500 ! 12/1/95 Multi-body terms
16501 !
16502       n_corr=0
16503       n_corr1=0
16504       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16505           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16506          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16507 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16508 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16509       else
16510          ecorr=0.0d0
16511          ecorr5=0.0d0
16512          ecorr6=0.0d0
16513          eturn6=0.0d0
16514       endif
16515       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16516          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16517       endif
16518 !
16519 ! If performing constraint dynamics, call the constraint energy
16520 !  after the equilibration time
16521       if(usampl.and.totT.gt.eq_time) then
16522          call EconstrQ
16523          call Econstr_back
16524       else
16525          Uconst=0.0d0
16526          Uconst_back=0.0d0
16527       endif
16528 !
16529 ! Sum the energies
16530 !
16531       do i=1,n_ene
16532         energia(i)=0.0d0
16533       enddo
16534       energia(1)=evdw
16535 #ifdef SCP14
16536       energia(2)=evdw2-evdw2_14
16537       energia(18)=evdw2_14
16538 #else
16539       energia(2)=evdw2
16540       energia(18)=0.0d0
16541 #endif
16542 #ifdef SPLITELE
16543       energia(3)=ees
16544       energia(16)=evdw1
16545 #else
16546       energia(3)=ees+evdw1
16547       energia(16)=0.0d0
16548 #endif
16549       energia(4)=ecorr
16550       energia(5)=ecorr5
16551       energia(6)=ecorr6
16552       energia(7)=eel_loc
16553       energia(8)=eello_turn3
16554       energia(9)=eello_turn4
16555       energia(10)=eturn6
16556       energia(20)=Uconst+Uconst_back
16557       call sum_energy(energia,.true.)
16558 !      write (iout,*) "Exit ETOTAL_LONG"
16559       call flush(iout)
16560       return
16561       end subroutine etotal_long
16562 !-----------------------------------------------------------------------------
16563       subroutine etotal_short(energia)
16564 !
16565 ! Compute the short-range fast-varying contributions to the energy
16566 !
16567 !      implicit real*8 (a-h,o-z)
16568 !      include 'DIMENSIONS'
16569 #ifndef ISNAN
16570       external proc_proc
16571 #ifdef WINPGI
16572 !MS$ATTRIBUTES C ::  proc_proc
16573 #endif
16574 #endif
16575 #ifdef MPI
16576       include "mpif.h"
16577       integer :: ierror,ierr
16578       real(kind=8),dimension(n_ene) :: weights_
16579       real(kind=8) :: time00
16580 #endif
16581 !      include 'COMMON.SETUP'
16582 !      include 'COMMON.IOUNITS'
16583 !      include 'COMMON.FFIELD'
16584 !      include 'COMMON.DERIV'
16585 !      include 'COMMON.INTERACT'
16586 !      include 'COMMON.SBRIDGE'
16587 !      include 'COMMON.CHAIN'
16588 !      include 'COMMON.VAR'
16589 !      include 'COMMON.LOCAL'
16590       real(kind=8),dimension(0:n_ene) :: energia
16591 !el local variables
16592       integer :: i,nres6
16593       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16594       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16595       nres6=6*nres
16596
16597 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16598 !      call flush(iout)
16599       if (modecalc.eq.12.or.modecalc.eq.14) then
16600 #ifdef MPI
16601         if (fg_rank.eq.0) call int_from_cart1(.false.)
16602 #else
16603         call int_from_cart1(.false.)
16604 #endif
16605       endif
16606 #ifdef MPI
16607 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16608 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16609 !      call flush(iout)
16610       if (nfgtasks.gt.1) then
16611         time00=MPI_Wtime()
16612 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16613         if (fg_rank.eq.0) then
16614           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16615 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16616 !          call flush(iout)
16617 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16618 ! FG slaves as WEIGHTS array.
16619           weights_(1)=wsc
16620           weights_(2)=wscp
16621           weights_(3)=welec
16622           weights_(4)=wcorr
16623           weights_(5)=wcorr5
16624           weights_(6)=wcorr6
16625           weights_(7)=wel_loc
16626           weights_(8)=wturn3
16627           weights_(9)=wturn4
16628           weights_(10)=wturn6
16629           weights_(11)=wang
16630           weights_(12)=wscloc
16631           weights_(13)=wtor
16632           weights_(14)=wtor_d
16633           weights_(15)=wstrain
16634           weights_(16)=wvdwpp
16635           weights_(17)=wbond
16636           weights_(18)=scal14
16637           weights_(21)=wsccor
16638 ! FG Master broadcasts the WEIGHTS_ array
16639           call MPI_Bcast(weights_(1),n_ene,&
16640               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16641         else
16642 ! FG slaves receive the WEIGHTS array
16643           call MPI_Bcast(weights(1),n_ene,&
16644               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16645           wsc=weights(1)
16646           wscp=weights(2)
16647           welec=weights(3)
16648           wcorr=weights(4)
16649           wcorr5=weights(5)
16650           wcorr6=weights(6)
16651           wel_loc=weights(7)
16652           wturn3=weights(8)
16653           wturn4=weights(9)
16654           wturn6=weights(10)
16655           wang=weights(11)
16656           wscloc=weights(12)
16657           wtor=weights(13)
16658           wtor_d=weights(14)
16659           wstrain=weights(15)
16660           wvdwpp=weights(16)
16661           wbond=weights(17)
16662           scal14=weights(18)
16663           wsccor=weights(21)
16664         endif
16665 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16666         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16667           king,FG_COMM,IERR)
16668 !        write (iout,*) "Processor",myrank," BROADCAST c"
16669         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16670           king,FG_COMM,IERR)
16671 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16672         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16673           king,FG_COMM,IERR)
16674 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16675         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16676           king,FG_COMM,IERR)
16677 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16678         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16679           king,FG_COMM,IERR)
16680 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16681         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16682           king,FG_COMM,IERR)
16683 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16684         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16685           king,FG_COMM,IERR)
16686 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16687         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16688           king,FG_COMM,IERR)
16689 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16690         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16691           king,FG_COMM,IERR)
16692          time_Bcast=time_Bcast+MPI_Wtime()-time00
16693 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16694       endif
16695 !      write (iout,*) 'Processor',myrank,
16696 !     &  ' calling etotal_short ipot=',ipot
16697 !      call flush(iout)
16698 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16699 #endif
16700 !      call int_from_cart1(.false.)
16701 !
16702 ! Compute the side-chain and electrostatic interaction energy
16703 !
16704       goto (101,102,103,104,105,106) ipot
16705 ! Lennard-Jones potential.
16706   101 call elj_short(evdw)
16707 !d    print '(a)','Exit ELJ'
16708       goto 107
16709 ! Lennard-Jones-Kihara potential (shifted).
16710   102 call eljk_short(evdw)
16711       goto 107
16712 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16713   103 call ebp_short(evdw)
16714       goto 107
16715 ! Gay-Berne potential (shifted LJ, angular dependence).
16716   104 call egb_short(evdw)
16717       goto 107
16718 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16719   105 call egbv_short(evdw)
16720       goto 107
16721 ! Soft-sphere potential - already dealt with in the long-range part
16722   106 evdw=0.0d0
16723 !  106 call e_softsphere_short(evdw)
16724 !
16725 ! Calculate electrostatic (H-bonding) energy of the main chain.
16726 !
16727   107 continue
16728 !
16729 ! Calculate the short-range part of Evdwpp
16730 !
16731       call evdwpp_short(evdw1)
16732 !
16733 ! Calculate the short-range part of ESCp
16734 !
16735       if (ipot.lt.6) then
16736         call escp_short(evdw2,evdw2_14)
16737       endif
16738 !
16739 ! Calculate the bond-stretching energy
16740 !
16741       call ebond(estr)
16742 !
16743 ! Calculate the disulfide-bridge and other energy and the contributions
16744 ! from other distance constraints.
16745       call edis(ehpb)
16746 !
16747 ! Calculate the virtual-bond-angle energy.
16748 !
16749 ! Calculate the SC local energy.
16750 !
16751       call vec_and_deriv
16752       call esc(escloc)
16753 !
16754       if (wang.gt.0d0) then
16755        if (tor_mode.eq.0) then
16756          call ebend(ebe)
16757        else
16758 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16759 !C energy function
16760          call ebend_kcc(ebe)
16761        endif
16762       else
16763         ebe=0.0d0
16764       endif
16765       ethetacnstr=0.0d0
16766       if (with_theta_constr) call etheta_constr(ethetacnstr)
16767
16768 !       write(iout,*) "in etotal afer ebe",ipot
16769
16770 !      print *,"Processor",myrank," computed UB"
16771 !
16772 ! Calculate the SC local energy.
16773 !
16774       call esc(escloc)
16775 !elwrite(iout,*) "in etotal afer esc",ipot
16776 !      print *,"Processor",myrank," computed USC"
16777 !
16778 ! Calculate the virtual-bond torsional energy.
16779 !
16780 !d    print *,'nterm=',nterm
16781 !      if (wtor.gt.0) then
16782 !       call etor(etors,edihcnstr)
16783 !      else
16784 !       etors=0
16785 !       edihcnstr=0
16786 !      endif
16787       if (wtor.gt.0.0d0) then
16788          if (tor_mode.eq.0) then
16789            call etor(etors)
16790          else
16791 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16792 !C energy function
16793            call etor_kcc(etors)
16794          endif
16795       else
16796         etors=0.0d0
16797       endif
16798       edihcnstr=0.0d0
16799       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16800
16801 ! Calculate the virtual-bond torsional energy.
16802 !
16803 !
16804 ! 6/23/01 Calculate double-torsional energy
16805 !
16806       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16807       call etor_d(etors_d)
16808       endif
16809 !
16810 ! 21/5/07 Calculate local sicdechain correlation energy
16811 !
16812       if (wsccor.gt.0.0d0) then
16813         call eback_sc_corr(esccor)
16814       else
16815         esccor=0.0d0
16816       endif
16817 !
16818 ! Put energy components into an array
16819 !
16820       do i=1,n_ene
16821         energia(i)=0.0d0
16822       enddo
16823       energia(1)=evdw
16824 #ifdef SCP14
16825       energia(2)=evdw2-evdw2_14
16826       energia(18)=evdw2_14
16827 #else
16828       energia(2)=evdw2
16829       energia(18)=0.0d0
16830 #endif
16831 #ifdef SPLITELE
16832       energia(16)=evdw1
16833 #else
16834       energia(3)=evdw1
16835 #endif
16836       energia(11)=ebe
16837       energia(12)=escloc
16838       energia(13)=etors
16839       energia(14)=etors_d
16840       energia(15)=ehpb
16841       energia(17)=estr
16842       energia(19)=edihcnstr
16843       energia(21)=esccor
16844 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16845       call flush(iout)
16846       call sum_energy(energia,.true.)
16847 !      write (iout,*) "Exit ETOTAL_SHORT"
16848       call flush(iout)
16849       return
16850       end subroutine etotal_short
16851 !-----------------------------------------------------------------------------
16852 ! gnmr1.f
16853 !-----------------------------------------------------------------------------
16854       real(kind=8) function gnmr1(y,ymin,ymax)
16855 !      implicit none
16856       real(kind=8) :: y,ymin,ymax
16857       real(kind=8) :: wykl=4.0d0
16858       if (y.lt.ymin) then
16859         gnmr1=(ymin-y)**wykl/wykl
16860       else if (y.gt.ymax) then
16861         gnmr1=(y-ymax)**wykl/wykl
16862       else
16863         gnmr1=0.0d0
16864       endif
16865       return
16866       end function gnmr1
16867 !-----------------------------------------------------------------------------
16868       real(kind=8) function gnmr1prim(y,ymin,ymax)
16869 !      implicit none
16870       real(kind=8) :: y,ymin,ymax
16871       real(kind=8) :: wykl=4.0d0
16872       if (y.lt.ymin) then
16873         gnmr1prim=-(ymin-y)**(wykl-1)
16874       else if (y.gt.ymax) then
16875         gnmr1prim=(y-ymax)**(wykl-1)
16876       else
16877         gnmr1prim=0.0d0
16878       endif
16879       return
16880       end function gnmr1prim
16881 !----------------------------------------------------------------------------
16882       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16883       real(kind=8) y,ymin,ymax,sigma
16884       real(kind=8) wykl /4.0d0/
16885       if (y.lt.ymin) then
16886         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16887       else if (y.gt.ymax) then
16888         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16889       else
16890         rlornmr1=0.0d0
16891       endif
16892       return
16893       end function rlornmr1
16894 !------------------------------------------------------------------------------
16895       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16896       real(kind=8) y,ymin,ymax,sigma
16897       real(kind=8) wykl /4.0d0/
16898       if (y.lt.ymin) then
16899         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16900         ((ymin-y)**wykl+sigma**wykl)**2
16901       else if (y.gt.ymax) then
16902         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16903         ((y-ymax)**wykl+sigma**wykl)**2
16904       else
16905         rlornmr1prim=0.0d0
16906       endif
16907       return
16908       end function rlornmr1prim
16909
16910       real(kind=8) function harmonic(y,ymax)
16911 !      implicit none
16912       real(kind=8) :: y,ymax
16913       real(kind=8) :: wykl=2.0d0
16914       harmonic=(y-ymax)**wykl
16915       return
16916       end function harmonic
16917 !-----------------------------------------------------------------------------
16918       real(kind=8) function harmonicprim(y,ymax)
16919       real(kind=8) :: y,ymin,ymax
16920       real(kind=8) :: wykl=2.0d0
16921       harmonicprim=(y-ymax)*wykl
16922       return
16923       end function harmonicprim
16924 !-----------------------------------------------------------------------------
16925 ! gradient_p.F
16926 !-----------------------------------------------------------------------------
16927       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16928
16929       use io_base, only:intout,briefout
16930 !      implicit real*8 (a-h,o-z)
16931 !      include 'DIMENSIONS'
16932 !      include 'COMMON.CHAIN'
16933 !      include 'COMMON.DERIV'
16934 !      include 'COMMON.VAR'
16935 !      include 'COMMON.INTERACT'
16936 !      include 'COMMON.FFIELD'
16937 !      include 'COMMON.MD'
16938 !      include 'COMMON.IOUNITS'
16939       real(kind=8),external :: ufparm
16940       integer :: uiparm(1)
16941       real(kind=8) :: urparm(1)
16942       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16943       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16944       integer :: n,nf,ind,ind1,i,k,j
16945 !
16946 ! This subroutine calculates total internal coordinate gradient.
16947 ! Depending on the number of function evaluations, either whole energy
16948 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16949 ! internal coordinates are reevaluated or only the cartesian-in-internal
16950 ! coordinate derivatives are evaluated. The subroutine was designed to work
16951 ! with SUMSL.
16952 !
16953 !
16954       icg=mod(nf,2)+1
16955
16956 !d      print *,'grad',nf,icg
16957       if (nf-nfl+1) 20,30,40
16958    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16959 !    write (iout,*) 'grad 20'
16960       if (nf.eq.0) return
16961       goto 40
16962    30 call var_to_geom(n,x)
16963       call chainbuild
16964 !    write (iout,*) 'grad 30'
16965 !
16966 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16967 !
16968    40 call cartder
16969 !     write (iout,*) 'grad 40'
16970 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16971 !
16972 ! Convert the Cartesian gradient into internal-coordinate gradient.
16973 !
16974       ind=0
16975       ind1=0
16976       do i=1,nres-2
16977       gthetai=0.0D0
16978       gphii=0.0D0
16979       do j=i+1,nres-1
16980           ind=ind+1
16981 !         ind=indmat(i,j)
16982 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16983         do k=1,3
16984             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16985           enddo
16986         do k=1,3
16987           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16988           enddo
16989         enddo
16990       do j=i+1,nres-1
16991           ind1=ind1+1
16992 !         ind1=indmat(i,j)
16993 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16994         do k=1,3
16995           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16996           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16997           enddo
16998         enddo
16999       if (i.gt.1) g(i-1)=gphii
17000       if (n.gt.nphi) g(nphi+i)=gthetai
17001       enddo
17002       if (n.le.nphi+ntheta) goto 10
17003       do i=2,nres-1
17004       if (itype(i,1).ne.10) then
17005           galphai=0.0D0
17006         gomegai=0.0D0
17007         do k=1,3
17008           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17009           enddo
17010         do k=1,3
17011           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17012           enddo
17013           g(ialph(i,1))=galphai
17014         g(ialph(i,1)+nside)=gomegai
17015         endif
17016       enddo
17017 !
17018 ! Add the components corresponding to local energy terms.
17019 !
17020    10 continue
17021       do i=1,nvar
17022 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17023         g(i)=g(i)+gloc(i,icg)
17024       enddo
17025 ! Uncomment following three lines for diagnostics.
17026 !d    call intout
17027 !elwrite(iout,*) "in gradient after calling intout"
17028 !d    call briefout(0,0.0d0)
17029 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17030       return
17031       end subroutine gradient
17032 !-----------------------------------------------------------------------------
17033       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17034
17035       use comm_chu
17036 !      implicit real*8 (a-h,o-z)
17037 !      include 'DIMENSIONS'
17038 !      include 'COMMON.DERIV'
17039 !      include 'COMMON.IOUNITS'
17040 !      include 'COMMON.GEO'
17041       integer :: n,nf
17042 !el      integer :: jjj
17043 !el      common /chuju/ jjj
17044       real(kind=8) :: energia(0:n_ene)
17045       integer :: uiparm(1)
17046       real(kind=8) :: urparm(1)
17047       real(kind=8) :: f
17048       real(kind=8),external :: ufparm
17049       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17050 !     if (jjj.gt.0) then
17051 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17052 !     endif
17053       nfl=nf
17054       icg=mod(nf,2)+1
17055 !d      print *,'func',nf,nfl,icg
17056       call var_to_geom(n,x)
17057       call zerograd
17058       call chainbuild
17059 !d    write (iout,*) 'ETOTAL called from FUNC'
17060       call etotal(energia)
17061       call sum_gradient
17062       f=energia(0)
17063 !     if (jjj.gt.0) then
17064 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17065 !       write (iout,*) 'f=',etot
17066 !       jjj=0
17067 !     endif
17068       return
17069       end subroutine func
17070 !-----------------------------------------------------------------------------
17071       subroutine cartgrad
17072 !      implicit real*8 (a-h,o-z)
17073 !      include 'DIMENSIONS'
17074       use energy_data
17075       use MD_data, only: totT,usampl,eq_time
17076 #ifdef MPI
17077       include 'mpif.h'
17078 #endif
17079 !      include 'COMMON.CHAIN'
17080 !      include 'COMMON.DERIV'
17081 !      include 'COMMON.VAR'
17082 !      include 'COMMON.INTERACT'
17083 !      include 'COMMON.FFIELD'
17084 !      include 'COMMON.MD'
17085 !      include 'COMMON.IOUNITS'
17086 !      include 'COMMON.TIME1'
17087 !
17088       integer :: i,j
17089
17090 ! This subrouting calculates total Cartesian coordinate gradient.
17091 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17092 !
17093 !#define DEBUG
17094 #ifdef TIMING
17095       time00=MPI_Wtime()
17096 #endif
17097       icg=1
17098       call sum_gradient
17099 #ifdef TIMING
17100 #endif
17101 !#define DEBUG
17102 !el      write (iout,*) "After sum_gradient"
17103 #ifdef DEBUG
17104 !el      write (iout,*) "After sum_gradient"
17105       do i=1,nres-1
17106         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17107         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17108       enddo
17109 #endif
17110 !#undef DEBUG
17111 ! If performing constraint dynamics, add the gradients of the constraint energy
17112       if(usampl.and.totT.gt.eq_time) then
17113          do i=1,nct
17114            do j=1,3
17115              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17116              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17117            enddo
17118          enddo
17119          do i=1,nres-3
17120            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17121          enddo
17122          do i=1,nres-2
17123            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17124          enddo
17125       endif
17126 !elwrite (iout,*) "After sum_gradient"
17127 #ifdef TIMING
17128       time01=MPI_Wtime()
17129 #endif
17130       call intcartderiv
17131 !elwrite (iout,*) "After sum_gradient"
17132 #ifdef TIMING
17133       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17134 #endif
17135 !     call checkintcartgrad
17136 !     write(iout,*) 'calling int_to_cart'
17137 !#define DEBUG
17138 #ifdef DEBUG
17139       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17140 #endif
17141       do i=0,nct
17142         do j=1,3
17143           gcart(j,i)=gradc(j,i,icg)
17144           gxcart(j,i)=gradx(j,i,icg)
17145 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17146         enddo
17147 #ifdef DEBUG
17148         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17149           (gxcart(j,i),j=1,3),gloc(i,icg)
17150 #endif
17151       enddo
17152 #ifdef TIMING
17153       time01=MPI_Wtime()
17154 #endif
17155 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17156       call int_to_cart
17157 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17158
17159 #ifdef TIMING
17160             time_inttocart=time_inttocart+MPI_Wtime()-time01
17161 #endif
17162 #ifdef DEBUG
17163             write (iout,*) "gcart and gxcart after int_to_cart"
17164             do i=0,nres-1
17165             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17166                 (gxcart(j,i),j=1,3)
17167             enddo
17168 #endif
17169 !#undef DEBUG
17170 #ifdef CARGRAD
17171 #ifdef DEBUG
17172             write (iout,*) "CARGRAD"
17173 #endif
17174             do i=nres,0,-1
17175             do j=1,3
17176               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17177       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17178             enddo
17179       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17180       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17181             enddo
17182       ! Correction: dummy residues
17183             if (nnt.gt.1) then
17184               do j=1,3
17185       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17186                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17187               enddo
17188             endif
17189             if (nct.lt.nres) then
17190               do j=1,3
17191       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17192                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17193               enddo
17194             endif
17195 #endif
17196 #ifdef TIMING
17197             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17198 #endif
17199 !#undef DEBUG
17200             return
17201             end subroutine cartgrad
17202       !-----------------------------------------------------------------------------
17203             subroutine zerograd
17204       !      implicit real*8 (a-h,o-z)
17205       !      include 'DIMENSIONS'
17206       !      include 'COMMON.DERIV'
17207       !      include 'COMMON.CHAIN'
17208       !      include 'COMMON.VAR'
17209       !      include 'COMMON.MD'
17210       !      include 'COMMON.SCCOR'
17211       !
17212       !el local variables
17213             integer :: i,j,intertyp,k
17214       ! Initialize Cartesian-coordinate gradient
17215       !
17216       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17217       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17218
17219       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17220       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17221       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17222       !      allocate(gradcorr_long(3,nres))
17223       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17224       !      allocate(gcorr6_turn_long(3,nres))
17225       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17226
17227       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17228
17229       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17230       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17231
17232       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17233       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17234
17235       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17236       !      allocate(gscloc(3,nres)) !(3,maxres)
17237       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17238
17239
17240
17241       !      common /deriv_scloc/
17242       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17243       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17244       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17245       !      common /mpgrad/
17246       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17247
17248
17249
17250       !          gradc(j,i,icg)=0.0d0
17251       !          gradx(j,i,icg)=0.0d0
17252
17253       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17254       !elwrite(iout,*) "icg",icg
17255             do i=-1,nres
17256             do j=1,3
17257               gvdwx(j,i)=0.0D0
17258               gradx_scp(j,i)=0.0D0
17259               gvdwc(j,i)=0.0D0
17260               gvdwc_scp(j,i)=0.0D0
17261               gvdwc_scpp(j,i)=0.0d0
17262               gelc(j,i)=0.0D0
17263               gelc_long(j,i)=0.0D0
17264               gradb(j,i)=0.0d0
17265               gradbx(j,i)=0.0d0
17266               gvdwpp(j,i)=0.0d0
17267               gel_loc(j,i)=0.0d0
17268               gel_loc_long(j,i)=0.0d0
17269               ghpbc(j,i)=0.0D0
17270               ghpbx(j,i)=0.0D0
17271               gcorr3_turn(j,i)=0.0d0
17272               gcorr4_turn(j,i)=0.0d0
17273               gradcorr(j,i)=0.0d0
17274               gradcorr_long(j,i)=0.0d0
17275               gradcorr5_long(j,i)=0.0d0
17276               gradcorr6_long(j,i)=0.0d0
17277               gcorr6_turn_long(j,i)=0.0d0
17278               gradcorr5(j,i)=0.0d0
17279               gradcorr6(j,i)=0.0d0
17280               gcorr6_turn(j,i)=0.0d0
17281               gsccorc(j,i)=0.0d0
17282               gsccorx(j,i)=0.0d0
17283               gradc(j,i,icg)=0.0d0
17284               gradx(j,i,icg)=0.0d0
17285               gscloc(j,i)=0.0d0
17286               gsclocx(j,i)=0.0d0
17287               gliptran(j,i)=0.0d0
17288               gliptranx(j,i)=0.0d0
17289               gliptranc(j,i)=0.0d0
17290               gshieldx(j,i)=0.0d0
17291               gshieldc(j,i)=0.0d0
17292               gshieldc_loc(j,i)=0.0d0
17293               gshieldx_ec(j,i)=0.0d0
17294               gshieldc_ec(j,i)=0.0d0
17295               gshieldc_loc_ec(j,i)=0.0d0
17296               gshieldx_t3(j,i)=0.0d0
17297               gshieldc_t3(j,i)=0.0d0
17298               gshieldc_loc_t3(j,i)=0.0d0
17299               gshieldx_t4(j,i)=0.0d0
17300               gshieldc_t4(j,i)=0.0d0
17301               gshieldc_loc_t4(j,i)=0.0d0
17302               gshieldx_ll(j,i)=0.0d0
17303               gshieldc_ll(j,i)=0.0d0
17304               gshieldc_loc_ll(j,i)=0.0d0
17305               gg_tube(j,i)=0.0d0
17306               gg_tube_sc(j,i)=0.0d0
17307               gradafm(j,i)=0.0d0
17308               gradb_nucl(j,i)=0.0d0
17309               gradbx_nucl(j,i)=0.0d0
17310               gvdwpp_nucl(j,i)=0.0d0
17311               gvdwpp(j,i)=0.0d0
17312               gelpp(j,i)=0.0d0
17313               gvdwpsb(j,i)=0.0d0
17314               gvdwpsb1(j,i)=0.0d0
17315               gvdwsbc(j,i)=0.0d0
17316               gvdwsbx(j,i)=0.0d0
17317               gelsbc(j,i)=0.0d0
17318               gradcorr_nucl(j,i)=0.0d0
17319               gradcorr3_nucl(j,i)=0.0d0
17320               gradxorr_nucl(j,i)=0.0d0
17321               gradxorr3_nucl(j,i)=0.0d0
17322               gelsbx(j,i)=0.0d0
17323               gsbloc(j,i)=0.0d0
17324               gsblocx(j,i)=0.0d0
17325               gradpepcat(j,i)=0.0d0
17326               gradpepcatx(j,i)=0.0d0
17327               gradcatcat(j,i)=0.0d0
17328               gvdwx_scbase(j,i)=0.0d0
17329               gvdwc_scbase(j,i)=0.0d0
17330               gvdwx_pepbase(j,i)=0.0d0
17331               gvdwc_pepbase(j,i)=0.0d0
17332               gvdwx_scpho(j,i)=0.0d0
17333               gvdwc_scpho(j,i)=0.0d0
17334               gvdwc_peppho(j,i)=0.0d0
17335             enddo
17336              enddo
17337             do i=0,nres
17338             do j=1,3
17339               do intertyp=1,3
17340                gloc_sc(intertyp,i,icg)=0.0d0
17341               enddo
17342             enddo
17343             enddo
17344             do i=1,nres
17345              do j=1,maxcontsshi
17346              shield_list(j,i)=0
17347             do k=1,3
17348       !C           print *,i,j,k
17349                grad_shield_side(k,j,i)=0.0d0
17350                grad_shield_loc(k,j,i)=0.0d0
17351              enddo
17352              enddo
17353              ishield_list(i)=0
17354             enddo
17355
17356       !
17357       ! Initialize the gradient of local energy terms.
17358       !
17359       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17360       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17361       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17362       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17363       !      allocate(gel_loc_turn3(nres))
17364       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17365       !      allocate(gsccor_loc(nres))      !(maxres)
17366
17367             do i=1,4*nres
17368             gloc(i,icg)=0.0D0
17369             enddo
17370             do i=1,nres
17371             gel_loc_loc(i)=0.0d0
17372             gcorr_loc(i)=0.0d0
17373             g_corr5_loc(i)=0.0d0
17374             g_corr6_loc(i)=0.0d0
17375             gel_loc_turn3(i)=0.0d0
17376             gel_loc_turn4(i)=0.0d0
17377             gel_loc_turn6(i)=0.0d0
17378             gsccor_loc(i)=0.0d0
17379             enddo
17380       ! initialize gcart and gxcart
17381       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17382             do i=0,nres
17383             do j=1,3
17384               gcart(j,i)=0.0d0
17385               gxcart(j,i)=0.0d0
17386             enddo
17387             enddo
17388             return
17389             end subroutine zerograd
17390       !-----------------------------------------------------------------------------
17391             real(kind=8) function fdum()
17392             fdum=0.0D0
17393             return
17394             end function fdum
17395       !-----------------------------------------------------------------------------
17396       ! intcartderiv.F
17397       !-----------------------------------------------------------------------------
17398             subroutine intcartderiv
17399       !      implicit real*8 (a-h,o-z)
17400       !      include 'DIMENSIONS'
17401 #ifdef MPI
17402             include 'mpif.h'
17403 #endif
17404       !      include 'COMMON.SETUP'
17405       !      include 'COMMON.CHAIN'
17406       !      include 'COMMON.VAR'
17407       !      include 'COMMON.GEO'
17408       !      include 'COMMON.INTERACT'
17409       !      include 'COMMON.DERIV'
17410       !      include 'COMMON.IOUNITS'
17411       !      include 'COMMON.LOCAL'
17412       !      include 'COMMON.SCCOR'
17413             real(kind=8) :: pi4,pi34
17414             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17415             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17416                       dcosomega,dsinomega !(3,3,maxres)
17417             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17418
17419             integer :: i,j,k
17420             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17421                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17422                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17423                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17424             integer :: nres2
17425             nres2=2*nres
17426
17427       !el from module energy-------------
17428       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17429       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17430       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17431
17432       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17433       !el      allocate(dsintau(3,3,3,0:nres2))
17434       !el      allocate(dtauangle(3,3,3,0:nres2))
17435       !el      allocate(domicron(3,2,2,0:nres2))
17436       !el      allocate(dcosomicron(3,2,2,0:nres2))
17437
17438
17439
17440 #if defined(MPI) && defined(PARINTDER)
17441             if (nfgtasks.gt.1 .and. me.eq.king) &
17442             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17443 #endif
17444             pi4 = 0.5d0*pipol
17445             pi34 = 3*pi4
17446
17447       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17448       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17449
17450       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17451             do i=1,nres
17452             do j=1,3
17453               dtheta(j,1,i)=0.0d0
17454               dtheta(j,2,i)=0.0d0
17455               dphi(j,1,i)=0.0d0
17456               dphi(j,2,i)=0.0d0
17457               dphi(j,3,i)=0.0d0
17458             enddo
17459             enddo
17460       ! Derivatives of theta's
17461 #if defined(MPI) && defined(PARINTDER)
17462       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17463             do i=max0(ithet_start-1,3),ithet_end
17464 #else
17465             do i=3,nres
17466 #endif
17467             cost=dcos(theta(i))
17468             sint=sqrt(1-cost*cost)
17469             do j=1,3
17470               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17471               vbld(i-1)
17472               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17473               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17474               vbld(i)
17475               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17476             enddo
17477             enddo
17478 #if defined(MPI) && defined(PARINTDER)
17479       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17480             do i=max0(ithet_start-1,3),ithet_end
17481 #else
17482             do i=3,nres
17483 #endif
17484             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17485             cost1=dcos(omicron(1,i))
17486             sint1=sqrt(1-cost1*cost1)
17487             cost2=dcos(omicron(2,i))
17488             sint2=sqrt(1-cost2*cost2)
17489              do j=1,3
17490       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17491               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17492               cost1*dc_norm(j,i-2))/ &
17493               vbld(i-1)
17494               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17495               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17496               +cost1*(dc_norm(j,i-1+nres)))/ &
17497               vbld(i-1+nres)
17498               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17499       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17500       !C Looks messy but better than if in loop
17501               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17502               +cost2*dc_norm(j,i-1))/ &
17503               vbld(i)
17504               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17505               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17506                +cost2*(-dc_norm(j,i-1+nres)))/ &
17507               vbld(i-1+nres)
17508       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17509               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17510             enddo
17511              endif
17512             enddo
17513       !elwrite(iout,*) "after vbld write"
17514       ! Derivatives of phi:
17515       ! If phi is 0 or 180 degrees, then the formulas
17516       ! have to be derived by power series expansion of the
17517       ! conventional formulas around 0 and 180.
17518 #ifdef PARINTDER
17519             do i=iphi1_start,iphi1_end
17520 #else
17521             do i=4,nres
17522 #endif
17523       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17524       ! the conventional case
17525             sint=dsin(theta(i))
17526             sint1=dsin(theta(i-1))
17527             sing=dsin(phi(i))
17528             cost=dcos(theta(i))
17529             cost1=dcos(theta(i-1))
17530             cosg=dcos(phi(i))
17531             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17532             fac0=1.0d0/(sint1*sint)
17533             fac1=cost*fac0
17534             fac2=cost1*fac0
17535             fac3=cosg*cost1/(sint1*sint1)
17536             fac4=cosg*cost/(sint*sint)
17537       !    Obtaining the gamma derivatives from sine derivative
17538              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17539                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17540                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17541              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17542              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17543              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17544              do j=1,3
17545                 ctgt=cost/sint
17546                 ctgt1=cost1/sint1
17547                 cosg_inv=1.0d0/cosg
17548                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17549                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17550                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17551                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17552                 dsinphi(j,2,i)= &
17553                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17554                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17555                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17556                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17557                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17558       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17559                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17560                 endif
17561       ! Bug fixed 3/24/05 (AL)
17562              enddo
17563       !   Obtaining the gamma derivatives from cosine derivative
17564             else
17565                do j=1,3
17566                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17567                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17568                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17569                dc_norm(j,i-3))/vbld(i-2)
17570                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17571                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17572                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17573                dcostheta(j,1,i)
17574                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17575                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17576                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17577                dc_norm(j,i-1))/vbld(i)
17578                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17579 !#define DEBUG
17580 #ifdef DEBUG
17581                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17582 #endif
17583 !#undef DEBUG
17584                endif
17585              enddo
17586             endif
17587             enddo
17588       !alculate derivative of Tauangle
17589 #ifdef PARINTDER
17590             do i=itau_start,itau_end
17591 #else
17592             do i=3,nres
17593       !elwrite(iout,*) " vecpr",i,nres
17594 #endif
17595              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17596       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17597       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17598       !c dtauangle(j,intertyp,dervityp,residue number)
17599       !c INTERTYP=1 SC...Ca...Ca..Ca
17600       ! the conventional case
17601             sint=dsin(theta(i))
17602             sint1=dsin(omicron(2,i-1))
17603             sing=dsin(tauangle(1,i))
17604             cost=dcos(theta(i))
17605             cost1=dcos(omicron(2,i-1))
17606             cosg=dcos(tauangle(1,i))
17607       !elwrite(iout,*) " vecpr5",i,nres
17608             do j=1,3
17609       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17610       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17611             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17612       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17613             enddo
17614             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17615             fac0=1.0d0/(sint1*sint)
17616             fac1=cost*fac0
17617             fac2=cost1*fac0
17618             fac3=cosg*cost1/(sint1*sint1)
17619             fac4=cosg*cost/(sint*sint)
17620       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17621       !    Obtaining the gamma derivatives from sine derivative
17622              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17623                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17624                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17625              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17626              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17627              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17628             do j=1,3
17629                 ctgt=cost/sint
17630                 ctgt1=cost1/sint1
17631                 cosg_inv=1.0d0/cosg
17632                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17633              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17634              *vbld_inv(i-2+nres)
17635                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17636                 dsintau(j,1,2,i)= &
17637                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17638                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17639       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17640                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17641       ! Bug fixed 3/24/05 (AL)
17642                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17643                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17644       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17645                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17646              enddo
17647       !   Obtaining the gamma derivatives from cosine derivative
17648             else
17649                do j=1,3
17650                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17651                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17652                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17653                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17654                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17655                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17656                dcostheta(j,1,i)
17657                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17658                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17659                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17660                dc_norm(j,i-1))/vbld(i)
17661                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17662       !         write (iout,*) "else",i
17663              enddo
17664             endif
17665       !        do k=1,3
17666       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17667       !        enddo
17668             enddo
17669       !C Second case Ca...Ca...Ca...SC
17670 #ifdef PARINTDER
17671             do i=itau_start,itau_end
17672 #else
17673             do i=4,nres
17674 #endif
17675              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17676               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17677       ! the conventional case
17678             sint=dsin(omicron(1,i))
17679             sint1=dsin(theta(i-1))
17680             sing=dsin(tauangle(2,i))
17681             cost=dcos(omicron(1,i))
17682             cost1=dcos(theta(i-1))
17683             cosg=dcos(tauangle(2,i))
17684       !        do j=1,3
17685       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17686       !        enddo
17687             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17688             fac0=1.0d0/(sint1*sint)
17689             fac1=cost*fac0
17690             fac2=cost1*fac0
17691             fac3=cosg*cost1/(sint1*sint1)
17692             fac4=cosg*cost/(sint*sint)
17693       !    Obtaining the gamma derivatives from sine derivative
17694              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17695                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17696                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17697              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17698              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17699              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17700             do j=1,3
17701                 ctgt=cost/sint
17702                 ctgt1=cost1/sint1
17703                 cosg_inv=1.0d0/cosg
17704                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17705                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17706       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17707       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17708                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17709                 dsintau(j,2,2,i)= &
17710                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17711                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17712       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17713       !     & sing*ctgt*domicron(j,1,2,i),
17714       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17715                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17716       ! Bug fixed 3/24/05 (AL)
17717                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17718                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17719       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17720                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17721              enddo
17722       !   Obtaining the gamma derivatives from cosine derivative
17723             else
17724                do j=1,3
17725                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17726                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17727                dc_norm(j,i-3))/vbld(i-2)
17728                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17729                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17730                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17731                dcosomicron(j,1,1,i)
17732                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17733                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17734                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17735                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17736                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17737       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17738              enddo
17739             endif
17740             enddo
17741
17742       !CC third case SC...Ca...Ca...SC
17743 #ifdef PARINTDER
17744
17745             do i=itau_start,itau_end
17746 #else
17747             do i=3,nres
17748 #endif
17749       ! the conventional case
17750             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17751             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17752             sint=dsin(omicron(1,i))
17753             sint1=dsin(omicron(2,i-1))
17754             sing=dsin(tauangle(3,i))
17755             cost=dcos(omicron(1,i))
17756             cost1=dcos(omicron(2,i-1))
17757             cosg=dcos(tauangle(3,i))
17758             do j=1,3
17759             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17760       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17761             enddo
17762             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17763             fac0=1.0d0/(sint1*sint)
17764             fac1=cost*fac0
17765             fac2=cost1*fac0
17766             fac3=cosg*cost1/(sint1*sint1)
17767             fac4=cosg*cost/(sint*sint)
17768       !    Obtaining the gamma derivatives from sine derivative
17769              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17770                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17771                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17772              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17773              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17774              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17775             do j=1,3
17776                 ctgt=cost/sint
17777                 ctgt1=cost1/sint1
17778                 cosg_inv=1.0d0/cosg
17779                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17780                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17781                   *vbld_inv(i-2+nres)
17782                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17783                 dsintau(j,3,2,i)= &
17784                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17785                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17786                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17787       ! Bug fixed 3/24/05 (AL)
17788                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17789                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17790                   *vbld_inv(i-1+nres)
17791       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17792                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17793              enddo
17794       !   Obtaining the gamma derivatives from cosine derivative
17795             else
17796                do j=1,3
17797                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17798                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17799                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17800                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17801                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17802                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17803                dcosomicron(j,1,1,i)
17804                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17805                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17806                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17807                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17808                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17809       !          write(iout,*) "else",i
17810              enddo
17811             endif
17812             enddo
17813
17814 #ifdef CRYST_SC
17815       !   Derivatives of side-chain angles alpha and omega
17816 #if defined(MPI) && defined(PARINTDER)
17817             do i=ibond_start,ibond_end
17818 #else
17819             do i=2,nres-1
17820 #endif
17821               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17822                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17823                  fac6=fac5/vbld(i)
17824                  fac7=fac5*fac5
17825                  fac8=fac5/vbld(i+1)
17826                  fac9=fac5/vbld(i+nres)
17827                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17828                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17829                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17830                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17831                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17832                  sina=sqrt(1-cosa*cosa)
17833                  sino=dsin(omeg(i))
17834       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17835                  do j=1,3
17836                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17837                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17838                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17839                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17840                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17841                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17842                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17843                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17844                   vbld(i+nres))
17845                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17846                 enddo
17847       ! obtaining the derivatives of omega from sines
17848                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17849                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17850                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17851                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17852                    dsin(theta(i+1)))
17853                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17854                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17855                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17856                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17857                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17858                    coso_inv=1.0d0/dcos(omeg(i))
17859                    do j=1,3
17860                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17861                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17862                    (sino*dc_norm(j,i-1))/vbld(i)
17863                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17864                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17865                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17866                    -sino*dc_norm(j,i)/vbld(i+1)
17867                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17868                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17869                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17870                    vbld(i+nres)
17871                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17872                   enddo
17873                else
17874       !   obtaining the derivatives of omega from cosines
17875                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17876                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17877                  fac12=fac10*sina
17878                  fac13=fac12*fac12
17879                  fac14=sina*sina
17880                  do j=1,3
17881                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17882                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17883                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17884                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17885                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17886                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17887                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17888                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17889                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17890                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17891                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17892                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17893                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17894                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17895                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17896                 enddo
17897               endif
17898              else
17899                do j=1,3
17900                  do k=1,3
17901                    dalpha(k,j,i)=0.0d0
17902                    domega(k,j,i)=0.0d0
17903                  enddo
17904                enddo
17905              endif
17906              enddo
17907 #endif
17908 #if defined(MPI) && defined(PARINTDER)
17909             if (nfgtasks.gt.1) then
17910 #ifdef DEBUG
17911       !d      write (iout,*) "Gather dtheta"
17912       !d      call flush(iout)
17913             write (iout,*) "dtheta before gather"
17914             do i=1,nres
17915             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17916             enddo
17917 #endif
17918             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17919             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17920             king,FG_COMM,IERROR)
17921 !#define DEBUG
17922 #ifdef DEBUG
17923       !d      write (iout,*) "Gather dphi"
17924       !d      call flush(iout)
17925             write (iout,*) "dphi before gather"
17926             do i=1,nres
17927             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17928             enddo
17929 #endif
17930 !#undef DEBUG
17931             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17932             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17933             king,FG_COMM,IERROR)
17934       !d      write (iout,*) "Gather dalpha"
17935       !d      call flush(iout)
17936 #ifdef CRYST_SC
17937             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17938             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17939             king,FG_COMM,IERROR)
17940       !d      write (iout,*) "Gather domega"
17941       !d      call flush(iout)
17942             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17943             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17944             king,FG_COMM,IERROR)
17945 #endif
17946             endif
17947 #endif
17948 !#define DEBUG
17949 #ifdef DEBUG
17950             write (iout,*) "dtheta after gather"
17951             do i=1,nres
17952             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17953             enddo
17954             write (iout,*) "dphi after gather"
17955             do i=1,nres
17956             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17957             enddo
17958             write (iout,*) "dalpha after gather"
17959             do i=1,nres
17960             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17961             enddo
17962             write (iout,*) "domega after gather"
17963             do i=1,nres
17964             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17965             enddo
17966 #endif
17967 !#undef DEBUG
17968             return
17969             end subroutine intcartderiv
17970       !-----------------------------------------------------------------------------
17971             subroutine checkintcartgrad
17972       !      implicit real*8 (a-h,o-z)
17973       !      include 'DIMENSIONS'
17974 #ifdef MPI
17975             include 'mpif.h'
17976 #endif
17977       !      include 'COMMON.CHAIN'
17978       !      include 'COMMON.VAR'
17979       !      include 'COMMON.GEO'
17980       !      include 'COMMON.INTERACT'
17981       !      include 'COMMON.DERIV'
17982       !      include 'COMMON.IOUNITS'
17983       !      include 'COMMON.SETUP'
17984             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17985             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17986             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17987             real(kind=8),dimension(3) :: dc_norm_s
17988             real(kind=8) :: aincr=1.0d-5
17989             integer :: i,j
17990             real(kind=8) :: dcji
17991             do i=1,nres
17992             phi_s(i)=phi(i)
17993             theta_s(i)=theta(i)
17994             alph_s(i)=alph(i)
17995             omeg_s(i)=omeg(i)
17996             enddo
17997       ! Check theta gradient
17998             write (iout,*) &
17999              "Analytical (upper) and numerical (lower) gradient of theta"
18000             write (iout,*)
18001             do i=3,nres
18002             do j=1,3
18003               dcji=dc(j,i-2)
18004               dc(j,i-2)=dcji+aincr
18005               call chainbuild_cart
18006               call int_from_cart1(.false.)
18007           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18008           dc(j,i-2)=dcji
18009           dcji=dc(j,i-1)
18010           dc(j,i-1)=dc(j,i-1)+aincr
18011           call chainbuild_cart
18012           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18013           dc(j,i-1)=dcji
18014         enddo
18015 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18016 !el          (dtheta(j,2,i),j=1,3)
18017 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18018 !el          (dthetanum(j,2,i),j=1,3)
18019 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18020 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18021 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18022 !el        write (iout,*)
18023       enddo
18024 ! Check gamma gradient
18025       write (iout,*) &
18026        "Analytical (upper) and numerical (lower) gradient of gamma"
18027       do i=4,nres
18028         do j=1,3
18029           dcji=dc(j,i-3)
18030           dc(j,i-3)=dcji+aincr
18031           call chainbuild_cart
18032           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18033               dc(j,i-3)=dcji
18034           dcji=dc(j,i-2)
18035           dc(j,i-2)=dcji+aincr
18036           call chainbuild_cart
18037           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18038           dc(j,i-2)=dcji
18039           dcji=dc(j,i-1)
18040           dc(j,i-1)=dc(j,i-1)+aincr
18041           call chainbuild_cart
18042           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18043           dc(j,i-1)=dcji
18044         enddo
18045 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18046 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18047 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18048 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18049 !el        write (iout,'(5x,3(3f10.5,5x))') &
18050 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18051 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18052 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18053 !el        write (iout,*)
18054       enddo
18055 ! Check alpha gradient
18056       write (iout,*) &
18057        "Analytical (upper) and numerical (lower) gradient of alpha"
18058       do i=2,nres-1
18059        if(itype(i,1).ne.10) then
18060                  do j=1,3
18061                   dcji=dc(j,i-1)
18062                    dc(j,i-1)=dcji+aincr
18063               call chainbuild_cart
18064               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18065                  /aincr
18066                   dc(j,i-1)=dcji
18067               dcji=dc(j,i)
18068               dc(j,i)=dcji+aincr
18069               call chainbuild_cart
18070               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18071                  /aincr
18072               dc(j,i)=dcji
18073               dcji=dc(j,i+nres)
18074               dc(j,i+nres)=dc(j,i+nres)+aincr
18075               call chainbuild_cart
18076               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18077                  /aincr
18078              dc(j,i+nres)=dcji
18079             enddo
18080           endif
18081 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18082 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18083 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18084 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18085 !el        write (iout,'(5x,3(3f10.5,5x))') &
18086 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18087 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18088 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18089 !el        write (iout,*)
18090       enddo
18091 !     Check omega gradient
18092       write (iout,*) &
18093        "Analytical (upper) and numerical (lower) gradient of omega"
18094       do i=2,nres-1
18095        if(itype(i,1).ne.10) then
18096                  do j=1,3
18097                   dcji=dc(j,i-1)
18098                    dc(j,i-1)=dcji+aincr
18099               call chainbuild_cart
18100               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18101                  /aincr
18102                   dc(j,i-1)=dcji
18103               dcji=dc(j,i)
18104               dc(j,i)=dcji+aincr
18105               call chainbuild_cart
18106               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18107                  /aincr
18108               dc(j,i)=dcji
18109               dcji=dc(j,i+nres)
18110               dc(j,i+nres)=dc(j,i+nres)+aincr
18111               call chainbuild_cart
18112               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18113                  /aincr
18114              dc(j,i+nres)=dcji
18115             enddo
18116           endif
18117 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18118 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18119 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18120 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18121 !el        write (iout,'(5x,3(3f10.5,5x))') &
18122 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18123 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18124 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18125 !el        write (iout,*)
18126       enddo
18127       return
18128       end subroutine checkintcartgrad
18129 !-----------------------------------------------------------------------------
18130 ! q_measure.F
18131 !-----------------------------------------------------------------------------
18132       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18133 !      implicit real*8 (a-h,o-z)
18134 !      include 'DIMENSIONS'
18135 !      include 'COMMON.IOUNITS'
18136 !      include 'COMMON.CHAIN'
18137 !      include 'COMMON.INTERACT'
18138 !      include 'COMMON.VAR'
18139       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18140       integer :: kkk,nsep=3
18141       real(kind=8) :: qm      !dist,
18142       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18143       logical :: lprn=.false.
18144       logical :: flag
18145 !      real(kind=8) :: sigm,x
18146
18147 !el      sigm(x)=0.25d0*x     ! local function
18148       qqmax=1.0d10
18149       do kkk=1,nperm
18150       qq = 0.0d0
18151       nl=0
18152        if(flag) then
18153         do il=seg1+nsep,seg2
18154           do jl=seg1,il-nsep
18155             nl=nl+1
18156             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18157                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18158                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18159             dij=dist(il,jl)
18160             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18161             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18162               nl=nl+1
18163               d0ijCM=dsqrt( &
18164                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18165                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18166                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18167               dijCM=dist(il+nres,jl+nres)
18168               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18169             endif
18170             qq = qq+qqij+qqijCM
18171           enddo
18172         enddo
18173         qq = qq/nl
18174       else
18175       do il=seg1,seg2
18176         if((seg3-il).lt.3) then
18177              secseg=il+3
18178         else
18179              secseg=seg3
18180         endif
18181           do jl=secseg,seg4
18182             nl=nl+1
18183             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18184                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18185                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18186             dij=dist(il,jl)
18187             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18188             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18189               nl=nl+1
18190               d0ijCM=dsqrt( &
18191                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18192                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18193                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18194               dijCM=dist(il+nres,jl+nres)
18195               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18196             endif
18197             qq = qq+qqij+qqijCM
18198           enddo
18199         enddo
18200       qq = qq/nl
18201       endif
18202       if (qqmax.le.qq) qqmax=qq
18203       enddo
18204       qwolynes=1.0d0-qqmax
18205       return
18206       end function qwolynes
18207 !-----------------------------------------------------------------------------
18208       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18209 !      implicit real*8 (a-h,o-z)
18210 !      include 'DIMENSIONS'
18211 !      include 'COMMON.IOUNITS'
18212 !      include 'COMMON.CHAIN'
18213 !      include 'COMMON.INTERACT'
18214 !      include 'COMMON.VAR'
18215 !      include 'COMMON.MD'
18216       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18217       integer :: nsep=3, kkk
18218 !el      real(kind=8) :: dist
18219       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18220       logical :: lprn=.false.
18221       logical :: flag
18222       real(kind=8) :: sim,dd0,fac,ddqij
18223 !el      sigm(x)=0.25d0*x           ! local function
18224       do kkk=1,nperm
18225       do i=0,nres
18226         do j=1,3
18227           dqwol(j,i)=0.0d0
18228           dxqwol(j,i)=0.0d0
18229         enddo
18230       enddo
18231       nl=0
18232        if(flag) then
18233         do il=seg1+nsep,seg2
18234           do jl=seg1,il-nsep
18235             nl=nl+1
18236             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18237                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18238                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18239             dij=dist(il,jl)
18240             sim = 1.0d0/sigm(d0ij)
18241             sim = sim*sim
18242             dd0 = dij-d0ij
18243             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18244           do k=1,3
18245               ddqij = (c(k,il)-c(k,jl))*fac
18246               dqwol(k,il)=dqwol(k,il)+ddqij
18247               dqwol(k,jl)=dqwol(k,jl)-ddqij
18248             enddo
18249
18250             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18251               nl=nl+1
18252               d0ijCM=dsqrt( &
18253                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18254                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18255                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18256               dijCM=dist(il+nres,jl+nres)
18257               sim = 1.0d0/sigm(d0ijCM)
18258               sim = sim*sim
18259               dd0=dijCM-d0ijCM
18260               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18261               do k=1,3
18262                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18263                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18264                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18265               enddo
18266             endif
18267           enddo
18268         enddo
18269        else
18270         do il=seg1,seg2
18271         if((seg3-il).lt.3) then
18272              secseg=il+3
18273         else
18274              secseg=seg3
18275         endif
18276           do jl=secseg,seg4
18277             nl=nl+1
18278             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18279                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18280                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18281             dij=dist(il,jl)
18282             sim = 1.0d0/sigm(d0ij)
18283             sim = sim*sim
18284             dd0 = dij-d0ij
18285             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18286             do k=1,3
18287               ddqij = (c(k,il)-c(k,jl))*fac
18288               dqwol(k,il)=dqwol(k,il)+ddqij
18289               dqwol(k,jl)=dqwol(k,jl)-ddqij
18290             enddo
18291             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18292               nl=nl+1
18293               d0ijCM=dsqrt( &
18294                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18295                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18296                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18297               dijCM=dist(il+nres,jl+nres)
18298               sim = 1.0d0/sigm(d0ijCM)
18299               sim=sim*sim
18300               dd0 = dijCM-d0ijCM
18301               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18302               do k=1,3
18303                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18304                dxqwol(k,il)=dxqwol(k,il)+ddqij
18305                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18306               enddo
18307             endif
18308           enddo
18309         enddo
18310       endif
18311       enddo
18312        do i=0,nres
18313          do j=1,3
18314            dqwol(j,i)=dqwol(j,i)/nl
18315            dxqwol(j,i)=dxqwol(j,i)/nl
18316          enddo
18317        enddo
18318       return
18319       end subroutine qwolynes_prim
18320 !-----------------------------------------------------------------------------
18321       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18322 !      implicit real*8 (a-h,o-z)
18323 !      include 'DIMENSIONS'
18324 !      include 'COMMON.IOUNITS'
18325 !      include 'COMMON.CHAIN'
18326 !      include 'COMMON.INTERACT'
18327 !      include 'COMMON.VAR'
18328       integer :: seg1,seg2,seg3,seg4
18329       logical :: flag
18330       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18331       real(kind=8),dimension(3,0:2*nres) :: cdummy
18332       real(kind=8) :: q1,q2
18333       real(kind=8) :: delta=1.0d-10
18334       integer :: i,j
18335
18336       do i=0,nres
18337         do j=1,3
18338           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18339           cdummy(j,i)=c(j,i)
18340           c(j,i)=c(j,i)+delta
18341           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18342           qwolan(j,i)=(q2-q1)/delta
18343           c(j,i)=cdummy(j,i)
18344         enddo
18345       enddo
18346       do i=0,nres
18347         do j=1,3
18348           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18349           cdummy(j,i+nres)=c(j,i+nres)
18350           c(j,i+nres)=c(j,i+nres)+delta
18351           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18352           qwolxan(j,i)=(q2-q1)/delta
18353           c(j,i+nres)=cdummy(j,i+nres)
18354         enddo
18355       enddo
18356 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18357 !      do i=0,nct
18358 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18359 !      enddo
18360 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18361 !      do i=0,nct
18362 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18363 !      enddo
18364       return
18365       end subroutine qwol_num
18366 !-----------------------------------------------------------------------------
18367       subroutine EconstrQ
18368 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18369 !      implicit real*8 (a-h,o-z)
18370 !      include 'DIMENSIONS'
18371 !      include 'COMMON.CONTROL'
18372 !      include 'COMMON.VAR'
18373 !      include 'COMMON.MD'
18374       use MD_data
18375 !#ifndef LANG0
18376 !      include 'COMMON.LANGEVIN'
18377 !#else
18378 !      include 'COMMON.LANGEVIN.lang0'
18379 !#endif
18380 !      include 'COMMON.CHAIN'
18381 !      include 'COMMON.DERIV'
18382 !      include 'COMMON.GEO'
18383 !      include 'COMMON.LOCAL'
18384 !      include 'COMMON.INTERACT'
18385 !      include 'COMMON.IOUNITS'
18386 !      include 'COMMON.NAMES'
18387 !      include 'COMMON.TIME1'
18388       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18389       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18390                    duconst,duxconst
18391       integer :: kstart,kend,lstart,lend,idummy
18392       real(kind=8) :: delta=1.0d-7
18393       integer :: i,j,k,ii
18394       do i=0,nres
18395          do j=1,3
18396             duconst(j,i)=0.0d0
18397             dudconst(j,i)=0.0d0
18398             duxconst(j,i)=0.0d0
18399             dudxconst(j,i)=0.0d0
18400          enddo
18401       enddo
18402       Uconst=0.0d0
18403       do i=1,nfrag
18404          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18405            idummy,idummy)
18406          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18407 ! Calculating the derivatives of Constraint energy with respect to Q
18408          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18409            qinfrag(i,iset))
18410 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18411 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18412 !         hmnum=(hm2-hm1)/delta
18413 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18414 !     &   qinfrag(i,iset))
18415 !         write(iout,*) "harmonicnum frag", hmnum
18416 ! Calculating the derivatives of Q with respect to cartesian coordinates
18417          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18418           idummy,idummy)
18419 !         write(iout,*) "dqwol "
18420 !         do ii=1,nres
18421 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18422 !         enddo
18423 !         write(iout,*) "dxqwol "
18424 !         do ii=1,nres
18425 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18426 !         enddo
18427 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18428 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18429 !     &  ,idummy,idummy)
18430 !  The gradients of Uconst in Cs
18431          do ii=0,nres
18432             do j=1,3
18433                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18434                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18435             enddo
18436          enddo
18437       enddo
18438       do i=1,npair
18439          kstart=ifrag(1,ipair(1,i,iset),iset)
18440          kend=ifrag(2,ipair(1,i,iset),iset)
18441          lstart=ifrag(1,ipair(2,i,iset),iset)
18442          lend=ifrag(2,ipair(2,i,iset),iset)
18443          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18444          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18445 !  Calculating dU/dQ
18446          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18447 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18448 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18449 !         hmnum=(hm2-hm1)/delta
18450 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18451 !     &   qinpair(i,iset))
18452 !         write(iout,*) "harmonicnum pair ", hmnum
18453 ! Calculating dQ/dXi
18454          call qwolynes_prim(kstart,kend,.false.,&
18455           lstart,lend)
18456 !         write(iout,*) "dqwol "
18457 !         do ii=1,nres
18458 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18459 !         enddo
18460 !         write(iout,*) "dxqwol "
18461 !         do ii=1,nres
18462 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18463 !        enddo
18464 ! Calculating numerical gradients
18465 !        call qwol_num(kstart,kend,.false.
18466 !     &  ,lstart,lend)
18467 ! The gradients of Uconst in Cs
18468          do ii=0,nres
18469             do j=1,3
18470                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18471                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18472             enddo
18473          enddo
18474       enddo
18475 !      write(iout,*) "Uconst inside subroutine ", Uconst
18476 ! Transforming the gradients from Cs to dCs for the backbone
18477       do i=0,nres
18478          do j=i+1,nres
18479            do k=1,3
18480              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18481            enddo
18482          enddo
18483       enddo
18484 !  Transforming the gradients from Cs to dCs for the side chains
18485       do i=1,nres
18486          do j=1,3
18487            dudxconst(j,i)=duxconst(j,i)
18488          enddo
18489       enddo
18490 !      write(iout,*) "dU/ddc backbone "
18491 !       do ii=0,nres
18492 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18493 !      enddo
18494 !      write(iout,*) "dU/ddX side chain "
18495 !      do ii=1,nres
18496 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18497 !      enddo
18498 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18499 !      call dEconstrQ_num
18500       return
18501       end subroutine EconstrQ
18502 !-----------------------------------------------------------------------------
18503       subroutine dEconstrQ_num
18504 ! Calculating numerical dUconst/ddc and dUconst/ddx
18505 !      implicit real*8 (a-h,o-z)
18506 !      include 'DIMENSIONS'
18507 !      include 'COMMON.CONTROL'
18508 !      include 'COMMON.VAR'
18509 !      include 'COMMON.MD'
18510       use MD_data
18511 !#ifndef LANG0
18512 !      include 'COMMON.LANGEVIN'
18513 !#else
18514 !      include 'COMMON.LANGEVIN.lang0'
18515 !#endif
18516 !      include 'COMMON.CHAIN'
18517 !      include 'COMMON.DERIV'
18518 !      include 'COMMON.GEO'
18519 !      include 'COMMON.LOCAL'
18520 !      include 'COMMON.INTERACT'
18521 !      include 'COMMON.IOUNITS'
18522 !      include 'COMMON.NAMES'
18523 !      include 'COMMON.TIME1'
18524       real(kind=8) :: uzap1,uzap2
18525       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18526       integer :: kstart,kend,lstart,lend,idummy
18527       real(kind=8) :: delta=1.0d-7
18528 !el local variables
18529       integer :: i,ii,j
18530 !     real(kind=8) ::
18531 !     For the backbone
18532       do i=0,nres-1
18533          do j=1,3
18534             dUcartan(j,i)=0.0d0
18535             cdummy(j,i)=dc(j,i)
18536             dc(j,i)=dc(j,i)+delta
18537             call chainbuild_cart
18538           uzap2=0.0d0
18539             do ii=1,nfrag
18540              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18541                 idummy,idummy)
18542                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18543                 qinfrag(ii,iset))
18544             enddo
18545             do ii=1,npair
18546                kstart=ifrag(1,ipair(1,ii,iset),iset)
18547                kend=ifrag(2,ipair(1,ii,iset),iset)
18548                lstart=ifrag(1,ipair(2,ii,iset),iset)
18549                lend=ifrag(2,ipair(2,ii,iset),iset)
18550                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18551                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18552                  qinpair(ii,iset))
18553             enddo
18554             dc(j,i)=cdummy(j,i)
18555             call chainbuild_cart
18556             uzap1=0.0d0
18557              do ii=1,nfrag
18558              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18559                 idummy,idummy)
18560                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18561                 qinfrag(ii,iset))
18562             enddo
18563             do ii=1,npair
18564                kstart=ifrag(1,ipair(1,ii,iset),iset)
18565                kend=ifrag(2,ipair(1,ii,iset),iset)
18566                lstart=ifrag(1,ipair(2,ii,iset),iset)
18567                lend=ifrag(2,ipair(2,ii,iset),iset)
18568                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18569                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18570                 qinpair(ii,iset))
18571             enddo
18572             ducartan(j,i)=(uzap2-uzap1)/(delta)
18573          enddo
18574       enddo
18575 ! Calculating numerical gradients for dU/ddx
18576       do i=0,nres-1
18577          duxcartan(j,i)=0.0d0
18578          do j=1,3
18579             cdummy(j,i)=dc(j,i+nres)
18580             dc(j,i+nres)=dc(j,i+nres)+delta
18581             call chainbuild_cart
18582           uzap2=0.0d0
18583             do ii=1,nfrag
18584              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18585                 idummy,idummy)
18586                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18587                 qinfrag(ii,iset))
18588             enddo
18589             do ii=1,npair
18590                kstart=ifrag(1,ipair(1,ii,iset),iset)
18591                kend=ifrag(2,ipair(1,ii,iset),iset)
18592                lstart=ifrag(1,ipair(2,ii,iset),iset)
18593                lend=ifrag(2,ipair(2,ii,iset),iset)
18594                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18595                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18596                 qinpair(ii,iset))
18597             enddo
18598             dc(j,i+nres)=cdummy(j,i)
18599             call chainbuild_cart
18600             uzap1=0.0d0
18601              do ii=1,nfrag
18602                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18603                 ifrag(2,ii,iset),.true.,idummy,idummy)
18604                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18605                 qinfrag(ii,iset))
18606             enddo
18607             do ii=1,npair
18608                kstart=ifrag(1,ipair(1,ii,iset),iset)
18609                kend=ifrag(2,ipair(1,ii,iset),iset)
18610                lstart=ifrag(1,ipair(2,ii,iset),iset)
18611                lend=ifrag(2,ipair(2,ii,iset),iset)
18612                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18613                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18614                 qinpair(ii,iset))
18615             enddo
18616             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18617          enddo
18618       enddo
18619       write(iout,*) "Numerical dUconst/ddc backbone "
18620       do ii=0,nres
18621         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18622       enddo
18623 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18624 !      do ii=1,nres
18625 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18626 !      enddo
18627       return
18628       end subroutine dEconstrQ_num
18629 !-----------------------------------------------------------------------------
18630 ! ssMD.F
18631 !-----------------------------------------------------------------------------
18632       subroutine check_energies
18633
18634 !      use random, only: ran_number
18635
18636 !      implicit none
18637 !     Includes
18638 !      include 'DIMENSIONS'
18639 !      include 'COMMON.CHAIN'
18640 !      include 'COMMON.VAR'
18641 !      include 'COMMON.IOUNITS'
18642 !      include 'COMMON.SBRIDGE'
18643 !      include 'COMMON.LOCAL'
18644 !      include 'COMMON.GEO'
18645
18646 !     External functions
18647 !EL      double precision ran_number
18648 !EL      external ran_number
18649
18650 !     Local variables
18651       integer :: i,j,k,l,lmax,p,pmax
18652       real(kind=8) :: rmin,rmax
18653       real(kind=8) :: eij
18654
18655       real(kind=8) :: d
18656       real(kind=8) :: wi,rij,tj,pj
18657 !      return
18658
18659       i=5
18660       j=14
18661
18662       d=dsc(1)
18663       rmin=2.0D0
18664       rmax=12.0D0
18665
18666       lmax=10000
18667       pmax=1
18668
18669       do k=1,3
18670         c(k,i)=0.0D0
18671         c(k,j)=0.0D0
18672         c(k,nres+i)=0.0D0
18673         c(k,nres+j)=0.0D0
18674       enddo
18675
18676       do l=1,lmax
18677
18678 !t        wi=ran_number(0.0D0,pi)
18679 !        wi=ran_number(0.0D0,pi/6.0D0)
18680 !        wi=0.0D0
18681 !t        tj=ran_number(0.0D0,pi)
18682 !t        pj=ran_number(0.0D0,pi)
18683 !        pj=ran_number(0.0D0,pi/6.0D0)
18684 !        pj=0.0D0
18685
18686         do p=1,pmax
18687 !t           rij=ran_number(rmin,rmax)
18688
18689            c(1,j)=d*sin(pj)*cos(tj)
18690            c(2,j)=d*sin(pj)*sin(tj)
18691            c(3,j)=d*cos(pj)
18692
18693            c(3,nres+i)=-rij
18694
18695            c(1,i)=d*sin(wi)
18696            c(3,i)=-rij-d*cos(wi)
18697
18698            do k=1,3
18699               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18700               dc_norm(k,nres+i)=dc(k,nres+i)/d
18701               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18702               dc_norm(k,nres+j)=dc(k,nres+j)/d
18703            enddo
18704
18705            call dyn_ssbond_ene(i,j,eij)
18706         enddo
18707       enddo
18708       call exit(1)
18709       return
18710       end subroutine check_energies
18711 !-----------------------------------------------------------------------------
18712       subroutine dyn_ssbond_ene(resi,resj,eij)
18713 !      implicit none
18714 !      Includes
18715       use calc_data
18716       use comm_sschecks
18717 !      include 'DIMENSIONS'
18718 !      include 'COMMON.SBRIDGE'
18719 !      include 'COMMON.CHAIN'
18720 !      include 'COMMON.DERIV'
18721 !      include 'COMMON.LOCAL'
18722 !      include 'COMMON.INTERACT'
18723 !      include 'COMMON.VAR'
18724 !      include 'COMMON.IOUNITS'
18725 !      include 'COMMON.CALC'
18726 #ifndef CLUST
18727 #ifndef WHAM
18728        use MD_data
18729 !      include 'COMMON.MD'
18730 !      use MD, only: totT,t_bath
18731 #endif
18732 #endif
18733 !     External functions
18734 !EL      double precision h_base
18735 !EL      external h_base
18736
18737 !     Input arguments
18738       integer :: resi,resj
18739
18740 !     Output arguments
18741       real(kind=8) :: eij
18742
18743 !     Local variables
18744       logical :: havebond
18745       integer itypi,itypj
18746       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18747       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18748       real(kind=8),dimension(3) :: dcosom1,dcosom2
18749       real(kind=8) :: ed
18750       real(kind=8) :: pom1,pom2
18751       real(kind=8) :: ljA,ljB,ljXs
18752       real(kind=8),dimension(1:3) :: d_ljB
18753       real(kind=8) :: ssA,ssB,ssC,ssXs
18754       real(kind=8) :: ssxm,ljxm,ssm,ljm
18755       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18756       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18757       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18758 !-------FIRST METHOD
18759       real(kind=8) :: xm
18760       real(kind=8),dimension(1:3) :: d_xm
18761 !-------END FIRST METHOD
18762 !-------SECOND METHOD
18763 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18764 !-------END SECOND METHOD
18765
18766 !-------TESTING CODE
18767 !el      logical :: checkstop,transgrad
18768 !el      common /sschecks/ checkstop,transgrad
18769
18770       integer :: icheck,nicheck,jcheck,njcheck
18771       real(kind=8),dimension(-1:1) :: echeck
18772       real(kind=8) :: deps,ssx0,ljx0
18773 !-------END TESTING CODE
18774
18775       eij=0.0d0
18776       i=resi
18777       j=resj
18778
18779 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18780 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18781
18782       itypi=itype(i,1)
18783       dxi=dc_norm(1,nres+i)
18784       dyi=dc_norm(2,nres+i)
18785       dzi=dc_norm(3,nres+i)
18786       dsci_inv=vbld_inv(i+nres)
18787
18788       itypj=itype(j,1)
18789       xj=c(1,nres+j)-c(1,nres+i)
18790       yj=c(2,nres+j)-c(2,nres+i)
18791       zj=c(3,nres+j)-c(3,nres+i)
18792       dxj=dc_norm(1,nres+j)
18793       dyj=dc_norm(2,nres+j)
18794       dzj=dc_norm(3,nres+j)
18795       dscj_inv=vbld_inv(j+nres)
18796
18797       chi1=chi(itypi,itypj)
18798       chi2=chi(itypj,itypi)
18799       chi12=chi1*chi2
18800       chip1=chip(itypi)
18801       chip2=chip(itypj)
18802       chip12=chip1*chip2
18803       alf1=alp(itypi)
18804       alf2=alp(itypj)
18805       alf12=0.5D0*(alf1+alf2)
18806
18807       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18808       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18809 !     The following are set in sc_angular
18810 !      erij(1)=xj*rij
18811 !      erij(2)=yj*rij
18812 !      erij(3)=zj*rij
18813 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18814 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18815 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18816       call sc_angular
18817       rij=1.0D0/rij  ! Reset this so it makes sense
18818
18819       sig0ij=sigma(itypi,itypj)
18820       sig=sig0ij*dsqrt(1.0D0/sigsq)
18821
18822       ljXs=sig-sig0ij
18823       ljA=eps1*eps2rt**2*eps3rt**2
18824       ljB=ljA*bb_aq(itypi,itypj)
18825       ljA=ljA*aa_aq(itypi,itypj)
18826       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18827
18828       ssXs=d0cm
18829       deltat1=1.0d0-om1
18830       deltat2=1.0d0+om2
18831       deltat12=om2-om1+2.0d0
18832       cosphi=om12-om1*om2
18833       ssA=akcm
18834       ssB=akct*deltat12
18835       ssC=ss_depth &
18836            +akth*(deltat1*deltat1+deltat2*deltat2) &
18837            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18838       ssxm=ssXs-0.5D0*ssB/ssA
18839
18840 !-------TESTING CODE
18841 !$$$c     Some extra output
18842 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18843 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18844 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18845 !$$$      if (ssx0.gt.0.0d0) then
18846 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18847 !$$$      else
18848 !$$$        ssx0=ssxm
18849 !$$$      endif
18850 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18851 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18852 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18853 !$$$      return
18854 !-------END TESTING CODE
18855
18856 !-------TESTING CODE
18857 !     Stop and plot energy and derivative as a function of distance
18858       if (checkstop) then
18859         ssm=ssC-0.25D0*ssB*ssB/ssA
18860         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18861         if (ssm.lt.ljm .and. &
18862              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18863           nicheck=1000
18864           njcheck=1
18865           deps=0.5d-7
18866         else
18867           checkstop=.false.
18868         endif
18869       endif
18870       if (.not.checkstop) then
18871         nicheck=0
18872         njcheck=-1
18873       endif
18874
18875       do icheck=0,nicheck
18876       do jcheck=-1,njcheck
18877       if (checkstop) rij=(ssxm-1.0d0)+ &
18878              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18879 !-------END TESTING CODE
18880
18881       if (rij.gt.ljxm) then
18882         havebond=.false.
18883         ljd=rij-ljXs
18884         fac=(1.0D0/ljd)**expon
18885         e1=fac*fac*aa_aq(itypi,itypj)
18886         e2=fac*bb_aq(itypi,itypj)
18887         eij=eps1*eps2rt*eps3rt*(e1+e2)
18888         eps2der=eij*eps3rt
18889         eps3der=eij*eps2rt
18890         eij=eij*eps2rt*eps3rt
18891
18892         sigder=-sig/sigsq
18893         e1=e1*eps1*eps2rt**2*eps3rt**2
18894         ed=-expon*(e1+eij)/ljd
18895         sigder=ed*sigder
18896         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18897         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18898         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18899              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18900       else if (rij.lt.ssxm) then
18901         havebond=.true.
18902         ssd=rij-ssXs
18903         eij=ssA*ssd*ssd+ssB*ssd+ssC
18904
18905         ed=2*akcm*ssd+akct*deltat12
18906         pom1=akct*ssd
18907         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18908         eom1=-2*akth*deltat1-pom1-om2*pom2
18909         eom2= 2*akth*deltat2+pom1-om1*pom2
18910         eom12=pom2
18911       else
18912         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18913
18914         d_ssxm(1)=0.5D0*akct/ssA
18915         d_ssxm(2)=-d_ssxm(1)
18916         d_ssxm(3)=0.0D0
18917
18918         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18919         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18920         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18921         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18922
18923 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18924         xm=0.5d0*(ssxm+ljxm)
18925         do k=1,3
18926           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18927         enddo
18928         if (rij.lt.xm) then
18929           havebond=.true.
18930           ssm=ssC-0.25D0*ssB*ssB/ssA
18931           d_ssm(1)=0.5D0*akct*ssB/ssA
18932           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18933           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18934           d_ssm(3)=omega
18935           f1=(rij-xm)/(ssxm-xm)
18936           f2=(rij-ssxm)/(xm-ssxm)
18937           h1=h_base(f1,hd1)
18938           h2=h_base(f2,hd2)
18939           eij=ssm*h1+Ht*h2
18940           delta_inv=1.0d0/(xm-ssxm)
18941           deltasq_inv=delta_inv*delta_inv
18942           fac=ssm*hd1-Ht*hd2
18943           fac1=deltasq_inv*fac*(xm-rij)
18944           fac2=deltasq_inv*fac*(rij-ssxm)
18945           ed=delta_inv*(Ht*hd2-ssm*hd1)
18946           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18947           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18948           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18949         else
18950           havebond=.false.
18951           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18952           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18953           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18954           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18955                alf12/eps3rt)
18956           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18957           f1=(rij-ljxm)/(xm-ljxm)
18958           f2=(rij-xm)/(ljxm-xm)
18959           h1=h_base(f1,hd1)
18960           h2=h_base(f2,hd2)
18961           eij=Ht*h1+ljm*h2
18962           delta_inv=1.0d0/(ljxm-xm)
18963           deltasq_inv=delta_inv*delta_inv
18964           fac=Ht*hd1-ljm*hd2
18965           fac1=deltasq_inv*fac*(ljxm-rij)
18966           fac2=deltasq_inv*fac*(rij-xm)
18967           ed=delta_inv*(ljm*hd2-Ht*hd1)
18968           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18969           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18970           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18971         endif
18972 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18973
18974 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18975 !$$$        ssd=rij-ssXs
18976 !$$$        ljd=rij-ljXs
18977 !$$$        fac1=rij-ljxm
18978 !$$$        fac2=rij-ssxm
18979 !$$$
18980 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18981 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18982 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18983 !$$$
18984 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18985 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18986 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18987 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18988 !$$$        d_ssm(3)=omega
18989 !$$$
18990 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18991 !$$$        do k=1,3
18992 !$$$          d_ljm(k)=ljm*d_ljB(k)
18993 !$$$        enddo
18994 !$$$        ljm=ljm*ljB
18995 !$$$
18996 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18997 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18998 !$$$        d_ss(2)=akct*ssd
18999 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19000 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19001 !$$$        d_ss(3)=omega
19002 !$$$
19003 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19004 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19005 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19006 !$$$        do k=1,3
19007 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19008 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19009 !$$$        enddo
19010 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19011 !$$$
19012 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19013 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19014 !$$$        h1=h_base(f1,hd1)
19015 !$$$        h2=h_base(f2,hd2)
19016 !$$$        eij=ss*h1+ljf*h2
19017 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19018 !$$$        deltasq_inv=delta_inv*delta_inv
19019 !$$$        fac=ljf*hd2-ss*hd1
19020 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19021 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19022 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19023 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19024 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19025 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19026 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19027 !$$$
19028 !$$$        havebond=.false.
19029 !$$$        if (ed.gt.0.0d0) havebond=.true.
19030 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19031
19032       endif
19033
19034       if (havebond) then
19035 !#ifndef CLUST
19036 !#ifndef WHAM
19037 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19038 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19039 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19040 !        endif
19041 !#endif
19042 !#endif
19043         dyn_ssbond_ij(i,j)=eij
19044       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19045         dyn_ssbond_ij(i,j)=1.0d300
19046 !#ifndef CLUST
19047 !#ifndef WHAM
19048 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19049 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19050 !#endif
19051 !#endif
19052       endif
19053
19054 !-------TESTING CODE
19055 !el      if (checkstop) then
19056         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19057              "CHECKSTOP",rij,eij,ed
19058         echeck(jcheck)=eij
19059 !el      endif
19060       enddo
19061       if (checkstop) then
19062         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19063       endif
19064       enddo
19065       if (checkstop) then
19066         transgrad=.true.
19067         checkstop=.false.
19068       endif
19069 !-------END TESTING CODE
19070
19071       do k=1,3
19072         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19073         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19074       enddo
19075       do k=1,3
19076         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19077       enddo
19078       do k=1,3
19079         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19080              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19081              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19082         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19083              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19084              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19085       enddo
19086 !grad      do k=i,j-1
19087 !grad        do l=1,3
19088 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19089 !grad        enddo
19090 !grad      enddo
19091
19092       do l=1,3
19093         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19094         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19095       enddo
19096
19097       return
19098       end subroutine dyn_ssbond_ene
19099 !--------------------------------------------------------------------------
19100          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19101 !      implicit none
19102 !      Includes
19103       use calc_data
19104       use comm_sschecks
19105 !      include 'DIMENSIONS'
19106 !      include 'COMMON.SBRIDGE'
19107 !      include 'COMMON.CHAIN'
19108 !      include 'COMMON.DERIV'
19109 !      include 'COMMON.LOCAL'
19110 !      include 'COMMON.INTERACT'
19111 !      include 'COMMON.VAR'
19112 !      include 'COMMON.IOUNITS'
19113 !      include 'COMMON.CALC'
19114 #ifndef CLUST
19115 #ifndef WHAM
19116        use MD_data
19117 !      include 'COMMON.MD'
19118 !      use MD, only: totT,t_bath
19119 #endif
19120 #endif
19121       double precision h_base
19122       external h_base
19123
19124 !c     Input arguments
19125       integer resi,resj,resk,m,itypi,itypj,itypk
19126
19127 !c     Output arguments
19128       double precision eij,eij1,eij2,eij3
19129
19130 !c     Local variables
19131       logical havebond
19132 !c      integer itypi,itypj,k,l
19133       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19134       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19135       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19136       double precision sig0ij,ljd,sig,fac,e1,e2
19137       double precision dcosom1(3),dcosom2(3),ed
19138       double precision pom1,pom2
19139       double precision ljA,ljB,ljXs
19140       double precision d_ljB(1:3)
19141       double precision ssA,ssB,ssC,ssXs
19142       double precision ssxm,ljxm,ssm,ljm
19143       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19144       eij=0.0
19145       if (dtriss.eq.0) return
19146       i=resi
19147       j=resj
19148       k=resk
19149 !C      write(iout,*) resi,resj,resk
19150       itypi=itype(i,1)
19151       dxi=dc_norm(1,nres+i)
19152       dyi=dc_norm(2,nres+i)
19153       dzi=dc_norm(3,nres+i)
19154       dsci_inv=vbld_inv(i+nres)
19155       xi=c(1,nres+i)
19156       yi=c(2,nres+i)
19157       zi=c(3,nres+i)
19158       itypj=itype(j,1)
19159       xj=c(1,nres+j)
19160       yj=c(2,nres+j)
19161       zj=c(3,nres+j)
19162
19163       dxj=dc_norm(1,nres+j)
19164       dyj=dc_norm(2,nres+j)
19165       dzj=dc_norm(3,nres+j)
19166       dscj_inv=vbld_inv(j+nres)
19167       itypk=itype(k,1)
19168       xk=c(1,nres+k)
19169       yk=c(2,nres+k)
19170       zk=c(3,nres+k)
19171
19172       dxk=dc_norm(1,nres+k)
19173       dyk=dc_norm(2,nres+k)
19174       dzk=dc_norm(3,nres+k)
19175       dscj_inv=vbld_inv(k+nres)
19176       xij=xj-xi
19177       xik=xk-xi
19178       xjk=xk-xj
19179       yij=yj-yi
19180       yik=yk-yi
19181       yjk=yk-yj
19182       zij=zj-zi
19183       zik=zk-zi
19184       zjk=zk-zj
19185       rrij=(xij*xij+yij*yij+zij*zij)
19186       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19187       rrik=(xik*xik+yik*yik+zik*zik)
19188       rik=dsqrt(rrik)
19189       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19190       rjk=dsqrt(rrjk)
19191 !C there are three combination of distances for each trisulfide bonds
19192 !C The first case the ith atom is the center
19193 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19194 !C distance y is second distance the a,b,c,d are parameters derived for
19195 !C this problem d parameter was set as a penalty currenlty set to 1.
19196       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19197       eij1=0.0d0
19198       else
19199       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19200       endif
19201 !C second case jth atom is center
19202       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19203       eij2=0.0d0
19204       else
19205       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19206       endif
19207 !C the third case kth atom is the center
19208       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19209       eij3=0.0d0
19210       else
19211       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19212       endif
19213 !C      eij2=0.0
19214 !C      eij3=0.0
19215 !C      eij1=0.0
19216       eij=eij1+eij2+eij3
19217 !C      write(iout,*)i,j,k,eij
19218 !C The energy penalty calculated now time for the gradient part
19219 !C derivative over rij
19220       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19221       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19222             gg(1)=xij*fac/rij
19223             gg(2)=yij*fac/rij
19224             gg(3)=zij*fac/rij
19225       do m=1,3
19226         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19227         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19228       enddo
19229
19230       do l=1,3
19231         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19232         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19233       enddo
19234 !C now derivative over rik
19235       fac=-eij1**2/dtriss* &
19236       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19237       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19238             gg(1)=xik*fac/rik
19239             gg(2)=yik*fac/rik
19240             gg(3)=zik*fac/rik
19241       do m=1,3
19242         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19243         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19244       enddo
19245       do l=1,3
19246         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19247         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19248       enddo
19249 !C now derivative over rjk
19250       fac=-eij2**2/dtriss* &
19251       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19252       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19253             gg(1)=xjk*fac/rjk
19254             gg(2)=yjk*fac/rjk
19255             gg(3)=zjk*fac/rjk
19256       do m=1,3
19257         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19258         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19259       enddo
19260       do l=1,3
19261         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19262         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19263       enddo
19264       return
19265       end subroutine triple_ssbond_ene
19266
19267
19268
19269 !-----------------------------------------------------------------------------
19270       real(kind=8) function h_base(x,deriv)
19271 !     A smooth function going 0->1 in range [0,1]
19272 !     It should NOT be called outside range [0,1], it will not work there.
19273       implicit none
19274
19275 !     Input arguments
19276       real(kind=8) :: x
19277
19278 !     Output arguments
19279       real(kind=8) :: deriv
19280
19281 !     Local variables
19282       real(kind=8) :: xsq
19283
19284
19285 !     Two parabolas put together.  First derivative zero at extrema
19286 !$$$      if (x.lt.0.5D0) then
19287 !$$$        h_base=2.0D0*x*x
19288 !$$$        deriv=4.0D0*x
19289 !$$$      else
19290 !$$$        deriv=1.0D0-x
19291 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19292 !$$$        deriv=4.0D0*deriv
19293 !$$$      endif
19294
19295 !     Third degree polynomial.  First derivative zero at extrema
19296       h_base=x*x*(3.0d0-2.0d0*x)
19297       deriv=6.0d0*x*(1.0d0-x)
19298
19299 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19300 !$$$      xsq=x*x
19301 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19302 !$$$      deriv=x-1.0d0
19303 !$$$      deriv=deriv*deriv
19304 !$$$      deriv=30.0d0*xsq*deriv
19305
19306       return
19307       end function h_base
19308 !-----------------------------------------------------------------------------
19309       subroutine dyn_set_nss
19310 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19311 !      implicit none
19312       use MD_data, only: totT,t_bath
19313 !     Includes
19314 !      include 'DIMENSIONS'
19315 #ifdef MPI
19316       include "mpif.h"
19317 #endif
19318 !      include 'COMMON.SBRIDGE'
19319 !      include 'COMMON.CHAIN'
19320 !      include 'COMMON.IOUNITS'
19321 !      include 'COMMON.SETUP'
19322 !      include 'COMMON.MD'
19323 !     Local variables
19324       real(kind=8) :: emin
19325       integer :: i,j,imin,ierr
19326       integer :: diff,allnss,newnss
19327       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19328                 newihpb,newjhpb
19329       logical :: found
19330       integer,dimension(0:nfgtasks) :: i_newnss
19331       integer,dimension(0:nfgtasks) :: displ
19332       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19333       integer :: g_newnss
19334
19335       allnss=0
19336       do i=1,nres-1
19337         do j=i+1,nres
19338           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19339             allnss=allnss+1
19340             allflag(allnss)=0
19341             allihpb(allnss)=i
19342             alljhpb(allnss)=j
19343           endif
19344         enddo
19345       enddo
19346
19347 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19348
19349  1    emin=1.0d300
19350       do i=1,allnss
19351         if (allflag(i).eq.0 .and. &
19352              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19353           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19354           imin=i
19355         endif
19356       enddo
19357       if (emin.lt.1.0d300) then
19358         allflag(imin)=1
19359         do i=1,allnss
19360           if (allflag(i).eq.0 .and. &
19361                (allihpb(i).eq.allihpb(imin) .or. &
19362                alljhpb(i).eq.allihpb(imin) .or. &
19363                allihpb(i).eq.alljhpb(imin) .or. &
19364                alljhpb(i).eq.alljhpb(imin))) then
19365             allflag(i)=-1
19366           endif
19367         enddo
19368         goto 1
19369       endif
19370
19371 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19372
19373       newnss=0
19374       do i=1,allnss
19375         if (allflag(i).eq.1) then
19376           newnss=newnss+1
19377           newihpb(newnss)=allihpb(i)
19378           newjhpb(newnss)=alljhpb(i)
19379         endif
19380       enddo
19381
19382 #ifdef MPI
19383       if (nfgtasks.gt.1)then
19384
19385         call MPI_Reduce(newnss,g_newnss,1,&
19386           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19387         call MPI_Gather(newnss,1,MPI_INTEGER,&
19388                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19389         displ(0)=0
19390         do i=1,nfgtasks-1,1
19391           displ(i)=i_newnss(i-1)+displ(i-1)
19392         enddo
19393         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19394                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19395                          king,FG_COMM,IERR)
19396         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19397                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19398                          king,FG_COMM,IERR)
19399         if(fg_rank.eq.0) then
19400 !         print *,'g_newnss',g_newnss
19401 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19402 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19403          newnss=g_newnss
19404          do i=1,newnss
19405           newihpb(i)=g_newihpb(i)
19406           newjhpb(i)=g_newjhpb(i)
19407          enddo
19408         endif
19409       endif
19410 #endif
19411
19412       diff=newnss-nss
19413
19414 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19415 !       print *,newnss,nss,maxdim
19416       do i=1,nss
19417         found=.false.
19418 !        print *,newnss
19419         do j=1,newnss
19420 !!          print *,j
19421           if (idssb(i).eq.newihpb(j) .and. &
19422                jdssb(i).eq.newjhpb(j)) found=.true.
19423         enddo
19424 #ifndef CLUST
19425 #ifndef WHAM
19426 !        write(iout,*) "found",found,i,j
19427         if (.not.found.and.fg_rank.eq.0) &
19428             write(iout,'(a15,f12.2,f8.1,2i5)') &
19429              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19430 #endif
19431 #endif
19432       enddo
19433
19434       do i=1,newnss
19435         found=.false.
19436         do j=1,nss
19437 !          print *,i,j
19438           if (newihpb(i).eq.idssb(j) .and. &
19439                newjhpb(i).eq.jdssb(j)) found=.true.
19440         enddo
19441 #ifndef CLUST
19442 #ifndef WHAM
19443 !        write(iout,*) "found",found,i,j
19444         if (.not.found.and.fg_rank.eq.0) &
19445             write(iout,'(a15,f12.2,f8.1,2i5)') &
19446              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19447 #endif
19448 #endif
19449       enddo
19450
19451       nss=newnss
19452       do i=1,nss
19453         idssb(i)=newihpb(i)
19454         jdssb(i)=newjhpb(i)
19455       enddo
19456
19457       return
19458       end subroutine dyn_set_nss
19459 ! Lipid transfer energy function
19460       subroutine Eliptransfer(eliptran)
19461 !C this is done by Adasko
19462 !C      print *,"wchodze"
19463 !C structure of box:
19464 !C      water
19465 !C--bordliptop-- buffore starts
19466 !C--bufliptop--- here true lipid starts
19467 !C      lipid
19468 !C--buflipbot--- lipid ends buffore starts
19469 !C--bordlipbot--buffore ends
19470       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19471       integer :: i
19472       eliptran=0.0
19473 !      print *, "I am in eliptran"
19474       do i=ilip_start,ilip_end
19475 !C       do i=1,1
19476         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19477          cycle
19478
19479         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19480         if (positi.le.0.0) positi=positi+boxzsize
19481 !C        print *,i
19482 !C first for peptide groups
19483 !c for each residue check if it is in lipid or lipid water border area
19484        if ((positi.gt.bordlipbot)  &
19485       .and.(positi.lt.bordliptop)) then
19486 !C the energy transfer exist
19487         if (positi.lt.buflipbot) then
19488 !C what fraction I am in
19489          fracinbuf=1.0d0-      &
19490              ((positi-bordlipbot)/lipbufthick)
19491 !C lipbufthick is thickenes of lipid buffore
19492          sslip=sscalelip(fracinbuf)
19493          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19494          eliptran=eliptran+sslip*pepliptran
19495          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19496          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19497 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19498
19499 !C        print *,"doing sccale for lower part"
19500 !C         print *,i,sslip,fracinbuf,ssgradlip
19501         elseif (positi.gt.bufliptop) then
19502          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19503          sslip=sscalelip(fracinbuf)
19504          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19505          eliptran=eliptran+sslip*pepliptran
19506          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19507          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19508 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19509 !C          print *, "doing sscalefor top part"
19510 !C         print *,i,sslip,fracinbuf,ssgradlip
19511         else
19512          eliptran=eliptran+pepliptran
19513 !C         print *,"I am in true lipid"
19514         endif
19515 !C       else
19516 !C       eliptran=elpitran+0.0 ! I am in water
19517        endif
19518        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19519        enddo
19520 ! here starts the side chain transfer
19521        do i=ilip_start,ilip_end
19522         if (itype(i,1).eq.ntyp1) cycle
19523         positi=(mod(c(3,i+nres),boxzsize))
19524         if (positi.le.0) positi=positi+boxzsize
19525 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19526 !c for each residue check if it is in lipid or lipid water border area
19527 !C       respos=mod(c(3,i+nres),boxzsize)
19528 !C       print *,positi,bordlipbot,buflipbot
19529        if ((positi.gt.bordlipbot) &
19530        .and.(positi.lt.bordliptop)) then
19531 !C the energy transfer exist
19532         if (positi.lt.buflipbot) then
19533          fracinbuf=1.0d0-   &
19534            ((positi-bordlipbot)/lipbufthick)
19535 !C lipbufthick is thickenes of lipid buffore
19536          sslip=sscalelip(fracinbuf)
19537          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19538          eliptran=eliptran+sslip*liptranene(itype(i,1))
19539          gliptranx(3,i)=gliptranx(3,i) &
19540       +ssgradlip*liptranene(itype(i,1))
19541          gliptranc(3,i-1)= gliptranc(3,i-1) &
19542       +ssgradlip*liptranene(itype(i,1))
19543 !C         print *,"doing sccale for lower part"
19544         elseif (positi.gt.bufliptop) then
19545          fracinbuf=1.0d0-  &
19546       ((bordliptop-positi)/lipbufthick)
19547          sslip=sscalelip(fracinbuf)
19548          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19549          eliptran=eliptran+sslip*liptranene(itype(i,1))
19550          gliptranx(3,i)=gliptranx(3,i)  &
19551        +ssgradlip*liptranene(itype(i,1))
19552          gliptranc(3,i-1)= gliptranc(3,i-1) &
19553       +ssgradlip*liptranene(itype(i,1))
19554 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19555         else
19556          eliptran=eliptran+liptranene(itype(i,1))
19557 !C         print *,"I am in true lipid"
19558         endif
19559         endif ! if in lipid or buffor
19560 !C       else
19561 !C       eliptran=elpitran+0.0 ! I am in water
19562         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19563        enddo
19564        return
19565        end  subroutine Eliptransfer
19566 !----------------------------------NANO FUNCTIONS
19567 !C-----------------------------------------------------------------------
19568 !C-----------------------------------------------------------
19569 !C This subroutine is to mimic the histone like structure but as well can be
19570 !C utilizet to nanostructures (infinit) small modification has to be used to
19571 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19572 !C gradient has to be modified at the ends
19573 !C The energy function is Kihara potential
19574 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19575 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19576 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19577 !C simple Kihara potential
19578       subroutine calctube(Etube)
19579       real(kind=8),dimension(3) :: vectube
19580       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19581        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19582        sc_aa_tube,sc_bb_tube
19583       integer :: i,j,iti
19584       Etube=0.0d0
19585       do i=itube_start,itube_end
19586         enetube(i)=0.0d0
19587         enetube(i+nres)=0.0d0
19588       enddo
19589 !C first we calculate the distance from tube center
19590 !C for UNRES
19591        do i=itube_start,itube_end
19592 !C lets ommit dummy atoms for now
19593        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19594 !C now calculate distance from center of tube and direction vectors
19595       xmin=boxxsize
19596       ymin=boxysize
19597 ! Find minimum distance in periodic box
19598         do j=-1,1
19599          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19600          vectube(1)=vectube(1)+boxxsize*j
19601          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19602          vectube(2)=vectube(2)+boxysize*j
19603          xminact=abs(vectube(1)-tubecenter(1))
19604          yminact=abs(vectube(2)-tubecenter(2))
19605            if (xmin.gt.xminact) then
19606             xmin=xminact
19607             xtemp=vectube(1)
19608            endif
19609            if (ymin.gt.yminact) then
19610              ymin=yminact
19611              ytemp=vectube(2)
19612             endif
19613          enddo
19614       vectube(1)=xtemp
19615       vectube(2)=ytemp
19616       vectube(1)=vectube(1)-tubecenter(1)
19617       vectube(2)=vectube(2)-tubecenter(2)
19618
19619 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19620 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19621
19622 !C as the tube is infinity we do not calculate the Z-vector use of Z
19623 !C as chosen axis
19624       vectube(3)=0.0d0
19625 !C now calculte the distance
19626        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19627 !C now normalize vector
19628       vectube(1)=vectube(1)/tub_r
19629       vectube(2)=vectube(2)/tub_r
19630 !C calculte rdiffrence between r and r0
19631       rdiff=tub_r-tubeR0
19632 !C and its 6 power
19633       rdiff6=rdiff**6.0d0
19634 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19635        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19636 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19637 !C       print *,rdiff,rdiff6,pep_aa_tube
19638 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19639 !C now we calculate gradient
19640        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19641             6.0d0*pep_bb_tube)/rdiff6/rdiff
19642 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19643 !C     &rdiff,fac
19644 !C now direction of gg_tube vector
19645         do j=1,3
19646         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19647         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19648         enddo
19649         enddo
19650 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19651 !C        print *,gg_tube(1,0),"TU"
19652
19653
19654        do i=itube_start,itube_end
19655 !C Lets not jump over memory as we use many times iti
19656          iti=itype(i,1)
19657 !C lets ommit dummy atoms for now
19658          if ((iti.eq.ntyp1)  &
19659 !C in UNRES uncomment the line below as GLY has no side-chain...
19660 !C      .or.(iti.eq.10)
19661         ) cycle
19662       xmin=boxxsize
19663       ymin=boxysize
19664         do j=-1,1
19665          vectube(1)=mod((c(1,i+nres)),boxxsize)
19666          vectube(1)=vectube(1)+boxxsize*j
19667          vectube(2)=mod((c(2,i+nres)),boxysize)
19668          vectube(2)=vectube(2)+boxysize*j
19669
19670          xminact=abs(vectube(1)-tubecenter(1))
19671          yminact=abs(vectube(2)-tubecenter(2))
19672            if (xmin.gt.xminact) then
19673             xmin=xminact
19674             xtemp=vectube(1)
19675            endif
19676            if (ymin.gt.yminact) then
19677              ymin=yminact
19678              ytemp=vectube(2)
19679             endif
19680          enddo
19681       vectube(1)=xtemp
19682       vectube(2)=ytemp
19683 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19684 !C     &     tubecenter(2)
19685       vectube(1)=vectube(1)-tubecenter(1)
19686       vectube(2)=vectube(2)-tubecenter(2)
19687
19688 !C as the tube is infinity we do not calculate the Z-vector use of Z
19689 !C as chosen axis
19690       vectube(3)=0.0d0
19691 !C now calculte the distance
19692        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19693 !C now normalize vector
19694       vectube(1)=vectube(1)/tub_r
19695       vectube(2)=vectube(2)/tub_r
19696
19697 !C calculte rdiffrence between r and r0
19698       rdiff=tub_r-tubeR0
19699 !C and its 6 power
19700       rdiff6=rdiff**6.0d0
19701 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19702        sc_aa_tube=sc_aa_tube_par(iti)
19703        sc_bb_tube=sc_bb_tube_par(iti)
19704        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19705        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19706              6.0d0*sc_bb_tube/rdiff6/rdiff
19707 !C now direction of gg_tube vector
19708          do j=1,3
19709           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19710           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19711          enddo
19712         enddo
19713         do i=itube_start,itube_end
19714           Etube=Etube+enetube(i)+enetube(i+nres)
19715         enddo
19716 !C        print *,"ETUBE", etube
19717         return
19718         end subroutine calctube
19719 !C TO DO 1) add to total energy
19720 !C       2) add to gradient summation
19721 !C       3) add reading parameters (AND of course oppening of PARAM file)
19722 !C       4) add reading the center of tube
19723 !C       5) add COMMONs
19724 !C       6) add to zerograd
19725 !C       7) allocate matrices
19726
19727
19728 !C-----------------------------------------------------------------------
19729 !C-----------------------------------------------------------
19730 !C This subroutine is to mimic the histone like structure but as well can be
19731 !C utilizet to nanostructures (infinit) small modification has to be used to
19732 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19733 !C gradient has to be modified at the ends
19734 !C The energy function is Kihara potential
19735 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19736 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19737 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19738 !C simple Kihara potential
19739       subroutine calctube2(Etube)
19740             real(kind=8),dimension(3) :: vectube
19741       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19742        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19743        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19744       integer:: i,j,iti
19745       Etube=0.0d0
19746       do i=itube_start,itube_end
19747         enetube(i)=0.0d0
19748         enetube(i+nres)=0.0d0
19749       enddo
19750 !C first we calculate the distance from tube center
19751 !C first sugare-phosphate group for NARES this would be peptide group
19752 !C for UNRES
19753        do i=itube_start,itube_end
19754 !C lets ommit dummy atoms for now
19755
19756        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19757 !C now calculate distance from center of tube and direction vectors
19758 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19759 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19760 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19761 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19762       xmin=boxxsize
19763       ymin=boxysize
19764         do j=-1,1
19765          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19766          vectube(1)=vectube(1)+boxxsize*j
19767          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19768          vectube(2)=vectube(2)+boxysize*j
19769
19770          xminact=abs(vectube(1)-tubecenter(1))
19771          yminact=abs(vectube(2)-tubecenter(2))
19772            if (xmin.gt.xminact) then
19773             xmin=xminact
19774             xtemp=vectube(1)
19775            endif
19776            if (ymin.gt.yminact) then
19777              ymin=yminact
19778              ytemp=vectube(2)
19779             endif
19780          enddo
19781       vectube(1)=xtemp
19782       vectube(2)=ytemp
19783       vectube(1)=vectube(1)-tubecenter(1)
19784       vectube(2)=vectube(2)-tubecenter(2)
19785
19786 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19787 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19788
19789 !C as the tube is infinity we do not calculate the Z-vector use of Z
19790 !C as chosen axis
19791       vectube(3)=0.0d0
19792 !C now calculte the distance
19793        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19794 !C now normalize vector
19795       vectube(1)=vectube(1)/tub_r
19796       vectube(2)=vectube(2)/tub_r
19797 !C calculte rdiffrence between r and r0
19798       rdiff=tub_r-tubeR0
19799 !C and its 6 power
19800       rdiff6=rdiff**6.0d0
19801 !C THIS FRAGMENT MAKES TUBE FINITE
19802         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19803         if (positi.le.0) positi=positi+boxzsize
19804 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19805 !c for each residue check if it is in lipid or lipid water border area
19806 !C       respos=mod(c(3,i+nres),boxzsize)
19807 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19808        if ((positi.gt.bordtubebot)  &
19809         .and.(positi.lt.bordtubetop)) then
19810 !C the energy transfer exist
19811         if (positi.lt.buftubebot) then
19812          fracinbuf=1.0d0-  &
19813            ((positi-bordtubebot)/tubebufthick)
19814 !C lipbufthick is thickenes of lipid buffore
19815          sstube=sscalelip(fracinbuf)
19816          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19817 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19818          enetube(i)=enetube(i)+sstube*tubetranenepep
19819 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19820 !C     &+ssgradtube*tubetranene(itype(i,1))
19821 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19822 !C     &+ssgradtube*tubetranene(itype(i,1))
19823 !C         print *,"doing sccale for lower part"
19824         elseif (positi.gt.buftubetop) then
19825          fracinbuf=1.0d0-  &
19826         ((bordtubetop-positi)/tubebufthick)
19827          sstube=sscalelip(fracinbuf)
19828          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19829          enetube(i)=enetube(i)+sstube*tubetranenepep
19830 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19831 !C     &+ssgradtube*tubetranene(itype(i,1))
19832 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19833 !C     &+ssgradtube*tubetranene(itype(i,1))
19834 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19835         else
19836          sstube=1.0d0
19837          ssgradtube=0.0d0
19838          enetube(i)=enetube(i)+sstube*tubetranenepep
19839 !C         print *,"I am in true lipid"
19840         endif
19841         else
19842 !C          sstube=0.0d0
19843 !C          ssgradtube=0.0d0
19844         cycle
19845         endif ! if in lipid or buffor
19846
19847 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19848        enetube(i)=enetube(i)+sstube* &
19849         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19850 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19851 !C       print *,rdiff,rdiff6,pep_aa_tube
19852 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19853 !C now we calculate gradient
19854        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19855              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19856 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19857 !C     &rdiff,fac
19858
19859 !C now direction of gg_tube vector
19860        do j=1,3
19861         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19862         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19863         enddo
19864          gg_tube(3,i)=gg_tube(3,i)  &
19865        +ssgradtube*enetube(i)/sstube/2.0d0
19866          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19867        +ssgradtube*enetube(i)/sstube/2.0d0
19868
19869         enddo
19870 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19871 !C        print *,gg_tube(1,0),"TU"
19872         do i=itube_start,itube_end
19873 !C Lets not jump over memory as we use many times iti
19874          iti=itype(i,1)
19875 !C lets ommit dummy atoms for now
19876          if ((iti.eq.ntyp1) &
19877 !!C in UNRES uncomment the line below as GLY has no side-chain...
19878            .or.(iti.eq.10) &
19879           ) cycle
19880           vectube(1)=c(1,i+nres)
19881           vectube(1)=mod(vectube(1),boxxsize)
19882           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19883           vectube(2)=c(2,i+nres)
19884           vectube(2)=mod(vectube(2),boxysize)
19885           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19886
19887       vectube(1)=vectube(1)-tubecenter(1)
19888       vectube(2)=vectube(2)-tubecenter(2)
19889 !C THIS FRAGMENT MAKES TUBE FINITE
19890         positi=(mod(c(3,i+nres),boxzsize))
19891         if (positi.le.0) positi=positi+boxzsize
19892 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19893 !c for each residue check if it is in lipid or lipid water border area
19894 !C       respos=mod(c(3,i+nres),boxzsize)
19895 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19896
19897        if ((positi.gt.bordtubebot)  &
19898         .and.(positi.lt.bordtubetop)) then
19899 !C the energy transfer exist
19900         if (positi.lt.buftubebot) then
19901          fracinbuf=1.0d0- &
19902             ((positi-bordtubebot)/tubebufthick)
19903 !C lipbufthick is thickenes of lipid buffore
19904          sstube=sscalelip(fracinbuf)
19905          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19906 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19907          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19908 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19909 !C     &+ssgradtube*tubetranene(itype(i,1))
19910 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19911 !C     &+ssgradtube*tubetranene(itype(i,1))
19912 !C         print *,"doing sccale for lower part"
19913         elseif (positi.gt.buftubetop) then
19914          fracinbuf=1.0d0- &
19915         ((bordtubetop-positi)/tubebufthick)
19916
19917          sstube=sscalelip(fracinbuf)
19918          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19919          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19920 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19921 !C     &+ssgradtube*tubetranene(itype(i,1))
19922 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19923 !C     &+ssgradtube*tubetranene(itype(i,1))
19924 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19925         else
19926          sstube=1.0d0
19927          ssgradtube=0.0d0
19928          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19929 !C         print *,"I am in true lipid"
19930         endif
19931         else
19932 !C          sstube=0.0d0
19933 !C          ssgradtube=0.0d0
19934         cycle
19935         endif ! if in lipid or buffor
19936 !CEND OF FINITE FRAGMENT
19937 !C as the tube is infinity we do not calculate the Z-vector use of Z
19938 !C as chosen axis
19939       vectube(3)=0.0d0
19940 !C now calculte the distance
19941        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19942 !C now normalize vector
19943       vectube(1)=vectube(1)/tub_r
19944       vectube(2)=vectube(2)/tub_r
19945 !C calculte rdiffrence between r and r0
19946       rdiff=tub_r-tubeR0
19947 !C and its 6 power
19948       rdiff6=rdiff**6.0d0
19949 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19950        sc_aa_tube=sc_aa_tube_par(iti)
19951        sc_bb_tube=sc_bb_tube_par(iti)
19952        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19953                        *sstube+enetube(i+nres)
19954 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19955 !C now we calculate gradient
19956        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19957             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19958 !C now direction of gg_tube vector
19959          do j=1,3
19960           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19961           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19962          enddo
19963          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19964        +ssgradtube*enetube(i+nres)/sstube
19965          gg_tube(3,i-1)= gg_tube(3,i-1) &
19966        +ssgradtube*enetube(i+nres)/sstube
19967
19968         enddo
19969         do i=itube_start,itube_end
19970           Etube=Etube+enetube(i)+enetube(i+nres)
19971         enddo
19972 !C        print *,"ETUBE", etube
19973         return
19974         end subroutine calctube2
19975 !=====================================================================================================================================
19976       subroutine calcnano(Etube)
19977       real(kind=8),dimension(3) :: vectube
19978
19979       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19980        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19981        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19982        integer:: i,j,iti,r
19983
19984       Etube=0.0d0
19985 !      print *,itube_start,itube_end,"poczatek"
19986       do i=itube_start,itube_end
19987         enetube(i)=0.0d0
19988         enetube(i+nres)=0.0d0
19989       enddo
19990 !C first we calculate the distance from tube center
19991 !C first sugare-phosphate group for NARES this would be peptide group
19992 !C for UNRES
19993        do i=itube_start,itube_end
19994 !C lets ommit dummy atoms for now
19995        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19996 !C now calculate distance from center of tube and direction vectors
19997       xmin=boxxsize
19998       ymin=boxysize
19999       zmin=boxzsize
20000
20001         do j=-1,1
20002          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20003          vectube(1)=vectube(1)+boxxsize*j
20004          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20005          vectube(2)=vectube(2)+boxysize*j
20006          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20007          vectube(3)=vectube(3)+boxzsize*j
20008
20009
20010          xminact=dabs(vectube(1)-tubecenter(1))
20011          yminact=dabs(vectube(2)-tubecenter(2))
20012          zminact=dabs(vectube(3)-tubecenter(3))
20013
20014            if (xmin.gt.xminact) then
20015             xmin=xminact
20016             xtemp=vectube(1)
20017            endif
20018            if (ymin.gt.yminact) then
20019              ymin=yminact
20020              ytemp=vectube(2)
20021             endif
20022            if (zmin.gt.zminact) then
20023              zmin=zminact
20024              ztemp=vectube(3)
20025             endif
20026          enddo
20027       vectube(1)=xtemp
20028       vectube(2)=ytemp
20029       vectube(3)=ztemp
20030
20031       vectube(1)=vectube(1)-tubecenter(1)
20032       vectube(2)=vectube(2)-tubecenter(2)
20033       vectube(3)=vectube(3)-tubecenter(3)
20034
20035 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20036 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20037 !C as the tube is infinity we do not calculate the Z-vector use of Z
20038 !C as chosen axis
20039 !C      vectube(3)=0.0d0
20040 !C now calculte the distance
20041        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20042 !C now normalize vector
20043       vectube(1)=vectube(1)/tub_r
20044       vectube(2)=vectube(2)/tub_r
20045       vectube(3)=vectube(3)/tub_r
20046 !C calculte rdiffrence between r and r0
20047       rdiff=tub_r-tubeR0
20048 !C and its 6 power
20049       rdiff6=rdiff**6.0d0
20050 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20051        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20052 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20053 !C       print *,rdiff,rdiff6,pep_aa_tube
20054 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20055 !C now we calculate gradient
20056        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20057             6.0d0*pep_bb_tube)/rdiff6/rdiff
20058 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20059 !C     &rdiff,fac
20060          if (acavtubpep.eq.0.0d0) then
20061 !C go to 667
20062          enecavtube(i)=0.0
20063          faccav=0.0
20064          else
20065          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20066          enecavtube(i)=  &
20067         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20068         /denominator
20069          enecavtube(i)=0.0
20070          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20071         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20072         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20073         /denominator**2.0d0
20074 !C         faccav=0.0
20075 !C         fac=fac+faccav
20076 !C 667     continue
20077          endif
20078           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20079         do j=1,3
20080         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20081         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20082         enddo
20083         enddo
20084
20085        do i=itube_start,itube_end
20086         enecavtube(i)=0.0d0
20087 !C Lets not jump over memory as we use many times iti
20088          iti=itype(i,1)
20089 !C lets ommit dummy atoms for now
20090          if ((iti.eq.ntyp1) &
20091 !C in UNRES uncomment the line below as GLY has no side-chain...
20092 !C      .or.(iti.eq.10)
20093          ) cycle
20094       xmin=boxxsize
20095       ymin=boxysize
20096       zmin=boxzsize
20097         do j=-1,1
20098          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20099          vectube(1)=vectube(1)+boxxsize*j
20100          vectube(2)=dmod((c(2,i+nres)),boxysize)
20101          vectube(2)=vectube(2)+boxysize*j
20102          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20103          vectube(3)=vectube(3)+boxzsize*j
20104
20105
20106          xminact=dabs(vectube(1)-tubecenter(1))
20107          yminact=dabs(vectube(2)-tubecenter(2))
20108          zminact=dabs(vectube(3)-tubecenter(3))
20109
20110            if (xmin.gt.xminact) then
20111             xmin=xminact
20112             xtemp=vectube(1)
20113            endif
20114            if (ymin.gt.yminact) then
20115              ymin=yminact
20116              ytemp=vectube(2)
20117             endif
20118            if (zmin.gt.zminact) then
20119              zmin=zminact
20120              ztemp=vectube(3)
20121             endif
20122          enddo
20123       vectube(1)=xtemp
20124       vectube(2)=ytemp
20125       vectube(3)=ztemp
20126
20127 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20128 !C     &     tubecenter(2)
20129       vectube(1)=vectube(1)-tubecenter(1)
20130       vectube(2)=vectube(2)-tubecenter(2)
20131       vectube(3)=vectube(3)-tubecenter(3)
20132 !C now calculte the distance
20133        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20134 !C now normalize vector
20135       vectube(1)=vectube(1)/tub_r
20136       vectube(2)=vectube(2)/tub_r
20137       vectube(3)=vectube(3)/tub_r
20138
20139 !C calculte rdiffrence between r and r0
20140       rdiff=tub_r-tubeR0
20141 !C and its 6 power
20142       rdiff6=rdiff**6.0d0
20143        sc_aa_tube=sc_aa_tube_par(iti)
20144        sc_bb_tube=sc_bb_tube_par(iti)
20145        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20146 !C       enetube(i+nres)=0.0d0
20147 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20148 !C now we calculate gradient
20149        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20150             6.0d0*sc_bb_tube/rdiff6/rdiff
20151 !C       fac=0.0
20152 !C now direction of gg_tube vector
20153 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20154          if (acavtub(iti).eq.0.0d0) then
20155 !C go to 667
20156          enecavtube(i+nres)=0.0d0
20157          faccav=0.0d0
20158          else
20159          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20160          enecavtube(i+nres)=   &
20161         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20162         /denominator
20163 !C         enecavtube(i)=0.0
20164          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20165         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20166         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20167         /denominator**2.0d0
20168 !C         faccav=0.0
20169          fac=fac+faccav
20170 !C 667     continue
20171          endif
20172 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20173 !C     &   enecavtube(i),faccav
20174 !C         print *,"licz=",
20175 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20176 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20177          do j=1,3
20178           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20179           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20180          enddo
20181           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20182         enddo
20183
20184
20185
20186         do i=itube_start,itube_end
20187           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20188          +enecavtube(i+nres)
20189         enddo
20190 !        do i=1,20
20191 !         print *,"begin", i,"a"
20192 !         do r=1,10000
20193 !          rdiff=r/100.0d0
20194 !          rdiff6=rdiff**6.0d0
20195 !          sc_aa_tube=sc_aa_tube_par(i)
20196 !          sc_bb_tube=sc_bb_tube_par(i)
20197 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20198 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20199 !          enecavtube(i)=   &
20200 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20201 !         /denominator
20202
20203 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20204 !         enddo
20205 !         print *,"end",i,"a"
20206 !        enddo
20207 !C        print *,"ETUBE", etube
20208         return
20209         end subroutine calcnano
20210
20211 !===============================================
20212 !--------------------------------------------------------------------------------
20213 !C first for shielding is setting of function of side-chains
20214
20215        subroutine set_shield_fac2
20216        real(kind=8) :: div77_81=0.974996043d0, &
20217         div4_81=0.2222222222d0
20218        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20219          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20220          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20221          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20222 !C the vector between center of side_chain and peptide group
20223        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20224          pept_group,costhet_grad,cosphi_grad_long, &
20225          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20226          sh_frac_dist_grad,pep_side
20227         integer i,j,k
20228 !C      write(2,*) "ivec",ivec_start,ivec_end
20229       do i=1,nres
20230         fac_shield(i)=0.0d0
20231         ishield_list(i)=0
20232         do j=1,3
20233         grad_shield(j,i)=0.0d0
20234         enddo
20235       enddo
20236       do i=ivec_start,ivec_end
20237 !C      do i=1,nres-1
20238 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20239 !      ishield_list(i)=0
20240       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20241 !Cif there two consequtive dummy atoms there is no peptide group between them
20242 !C the line below has to be changed for FGPROC>1
20243       VolumeTotal=0.0
20244       do k=1,nres
20245        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20246        dist_pep_side=0.0
20247        dist_side_calf=0.0
20248        do j=1,3
20249 !C first lets set vector conecting the ithe side-chain with kth side-chain
20250       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20251 !C      pep_side(j)=2.0d0
20252 !C and vector conecting the side-chain with its proper calfa
20253       side_calf(j)=c(j,k+nres)-c(j,k)
20254 !C      side_calf(j)=2.0d0
20255       pept_group(j)=c(j,i)-c(j,i+1)
20256 !C lets have their lenght
20257       dist_pep_side=pep_side(j)**2+dist_pep_side
20258       dist_side_calf=dist_side_calf+side_calf(j)**2
20259       dist_pept_group=dist_pept_group+pept_group(j)**2
20260       enddo
20261        dist_pep_side=sqrt(dist_pep_side)
20262        dist_pept_group=sqrt(dist_pept_group)
20263        dist_side_calf=sqrt(dist_side_calf)
20264       do j=1,3
20265         pep_side_norm(j)=pep_side(j)/dist_pep_side
20266         side_calf_norm(j)=dist_side_calf
20267       enddo
20268 !C now sscale fraction
20269        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20270 !       print *,buff_shield,"buff",sh_frac_dist
20271 !C now sscale
20272         if (sh_frac_dist.le.0.0) cycle
20273 !C        print *,ishield_list(i),i
20274 !C If we reach here it means that this side chain reaches the shielding sphere
20275 !C Lets add him to the list for gradient
20276         ishield_list(i)=ishield_list(i)+1
20277 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20278 !C this list is essential otherwise problem would be O3
20279         shield_list(ishield_list(i),i)=k
20280 !C Lets have the sscale value
20281         if (sh_frac_dist.gt.1.0) then
20282          scale_fac_dist=1.0d0
20283          do j=1,3
20284          sh_frac_dist_grad(j)=0.0d0
20285          enddo
20286         else
20287          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20288                         *(2.0d0*sh_frac_dist-3.0d0)
20289          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20290                        /dist_pep_side/buff_shield*0.5d0
20291          do j=1,3
20292          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20293 !C         sh_frac_dist_grad(j)=0.0d0
20294 !C         scale_fac_dist=1.0d0
20295 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20296 !C     &                    sh_frac_dist_grad(j)
20297          enddo
20298         endif
20299 !C this is what is now we have the distance scaling now volume...
20300       short=short_r_sidechain(itype(k,1))
20301       long=long_r_sidechain(itype(k,1))
20302       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20303       sinthet=short/dist_pep_side*costhet
20304 !      print *,"SORT",short,long,sinthet,costhet
20305 !C now costhet_grad
20306 !C       costhet=0.6d0
20307 !C       sinthet=0.8
20308        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20309 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20310 !C     &             -short/dist_pep_side**2/costhet)
20311 !C       costhet_fac=0.0d0
20312        do j=1,3
20313          costhet_grad(j)=costhet_fac*pep_side(j)
20314        enddo
20315 !C remember for the final gradient multiply costhet_grad(j)
20316 !C for side_chain by factor -2 !
20317 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20318 !C pep_side0pept_group is vector multiplication
20319       pep_side0pept_group=0.0d0
20320       do j=1,3
20321       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20322       enddo
20323       cosalfa=(pep_side0pept_group/ &
20324       (dist_pep_side*dist_side_calf))
20325       fac_alfa_sin=1.0d0-cosalfa**2
20326       fac_alfa_sin=dsqrt(fac_alfa_sin)
20327       rkprim=fac_alfa_sin*(long-short)+short
20328 !C      rkprim=short
20329
20330 !C now costhet_grad
20331        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20332 !C       cosphi=0.6
20333        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20334        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20335            dist_pep_side**2)
20336 !C       sinphi=0.8
20337        do j=1,3
20338          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20339       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20340       *(long-short)/fac_alfa_sin*cosalfa/ &
20341       ((dist_pep_side*dist_side_calf))* &
20342       ((side_calf(j))-cosalfa* &
20343       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20344 !C       cosphi_grad_long(j)=0.0d0
20345         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20346       *(long-short)/fac_alfa_sin*cosalfa &
20347       /((dist_pep_side*dist_side_calf))* &
20348       (pep_side(j)- &
20349       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20350 !C       cosphi_grad_loc(j)=0.0d0
20351        enddo
20352 !C      print *,sinphi,sinthet
20353       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20354                          /VSolvSphere_div
20355 !C     &                    *wshield
20356 !C now the gradient...
20357       do j=1,3
20358       grad_shield(j,i)=grad_shield(j,i) &
20359 !C gradient po skalowaniu
20360                      +(sh_frac_dist_grad(j)*VofOverlap &
20361 !C  gradient po costhet
20362             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20363         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20364             sinphi/sinthet*costhet*costhet_grad(j) &
20365            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20366         )*wshield
20367 !C grad_shield_side is Cbeta sidechain gradient
20368       grad_shield_side(j,ishield_list(i),i)=&
20369              (sh_frac_dist_grad(j)*-2.0d0&
20370              *VofOverlap&
20371             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20372        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20373             sinphi/sinthet*costhet*costhet_grad(j)&
20374            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20375             )*wshield
20376 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20377 !            sinphi/sinthet,&
20378 !           +sinthet/sinphi,"HERE"
20379        grad_shield_loc(j,ishield_list(i),i)=   &
20380             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20381       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20382             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20383              ))&
20384              *wshield
20385 !         print *,grad_shield_loc(j,ishield_list(i),i)
20386       enddo
20387       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20388       enddo
20389       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20390
20391 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20392       enddo
20393       return
20394       end subroutine set_shield_fac2
20395 !----------------------------------------------------------------------------
20396 ! SOUBROUTINE FOR AFM
20397        subroutine AFMvel(Eafmforce)
20398        use MD_data, only:totTafm
20399       real(kind=8),dimension(3) :: diffafm
20400       real(kind=8) :: afmdist,Eafmforce
20401        integer :: i
20402 !C Only for check grad COMMENT if not used for checkgrad
20403 !C      totT=3.0d0
20404 !C--------------------------------------------------------
20405 !C      print *,"wchodze"
20406       afmdist=0.0d0
20407       Eafmforce=0.0d0
20408       do i=1,3
20409       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20410       afmdist=afmdist+diffafm(i)**2
20411       enddo
20412       afmdist=dsqrt(afmdist)
20413 !      totTafm=3.0
20414       Eafmforce=0.5d0*forceAFMconst &
20415       *(distafminit+totTafm*velAFMconst-afmdist)**2
20416 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20417       do i=1,3
20418       gradafm(i,afmend-1)=-forceAFMconst* &
20419        (distafminit+totTafm*velAFMconst-afmdist) &
20420        *diffafm(i)/afmdist
20421       gradafm(i,afmbeg-1)=forceAFMconst* &
20422       (distafminit+totTafm*velAFMconst-afmdist) &
20423       *diffafm(i)/afmdist
20424       enddo
20425 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20426       return
20427       end subroutine AFMvel
20428 !---------------------------------------------------------
20429        subroutine AFMforce(Eafmforce)
20430
20431       real(kind=8),dimension(3) :: diffafm
20432 !      real(kind=8) ::afmdist
20433       real(kind=8) :: afmdist,Eafmforce
20434       integer :: i
20435       afmdist=0.0d0
20436       Eafmforce=0.0d0
20437       do i=1,3
20438       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20439       afmdist=afmdist+diffafm(i)**2
20440       enddo
20441       afmdist=dsqrt(afmdist)
20442 !      print *,afmdist,distafminit
20443       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20444       do i=1,3
20445       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20446       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20447       enddo
20448 !C      print *,'AFM',Eafmforce
20449       return
20450       end subroutine AFMforce
20451
20452 !-----------------------------------------------------------------------------
20453 #ifdef WHAM
20454       subroutine read_ssHist
20455 !      implicit none
20456 !      Includes
20457 !      include 'DIMENSIONS'
20458 !      include "DIMENSIONS.FREE"
20459 !      include 'COMMON.FREE'
20460 !     Local variables
20461       integer :: i,j
20462       character(len=80) :: controlcard
20463
20464       do i=1,dyn_nssHist
20465         call card_concat(controlcard,.true.)
20466         read(controlcard,*) &
20467              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20468       enddo
20469
20470       return
20471       end subroutine read_ssHist
20472 #endif
20473 !-----------------------------------------------------------------------------
20474       integer function indmat(i,j)
20475 !el
20476 ! get the position of the jth ijth fragment of the chain coordinate system
20477 ! in the fromto array.
20478         integer :: i,j
20479
20480         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20481       return
20482       end function indmat
20483 !-----------------------------------------------------------------------------
20484       real(kind=8) function sigm(x)
20485 !el
20486        real(kind=8) :: x
20487         sigm=0.25d0*x
20488       return
20489       end function sigm
20490 !-----------------------------------------------------------------------------
20491 !-----------------------------------------------------------------------------
20492       subroutine alloc_ener_arrays
20493 !EL Allocation of arrays used by module energy
20494       use MD_data, only: mset
20495 !el local variables
20496       integer :: i,j
20497
20498       if(nres.lt.100) then
20499         maxconts=10*nres
20500       elseif(nres.lt.200) then
20501         maxconts=10*nres      ! Max. number of contacts per residue
20502       else
20503         maxconts=10*nres ! (maxconts=maxres/4)
20504       endif
20505       maxcont=12*nres      ! Max. number of SC contacts
20506       maxvar=6*nres      ! Max. number of variables
20507 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20508       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20509 !----------------------
20510 ! arrays in subroutine init_int_table
20511 !el#ifdef MPI
20512 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20513 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20514 !el#endif
20515       allocate(nint_gr(nres))
20516       allocate(nscp_gr(nres))
20517       allocate(ielstart(nres))
20518       allocate(ielend(nres))
20519 !(maxres)
20520       allocate(istart(nres,maxint_gr))
20521       allocate(iend(nres,maxint_gr))
20522 !(maxres,maxint_gr)
20523       allocate(iscpstart(nres,maxint_gr))
20524       allocate(iscpend(nres,maxint_gr))
20525 !(maxres,maxint_gr)
20526       allocate(ielstart_vdw(nres))
20527       allocate(ielend_vdw(nres))
20528 !(maxres)
20529       allocate(nint_gr_nucl(nres))
20530       allocate(nscp_gr_nucl(nres))
20531       allocate(ielstart_nucl(nres))
20532       allocate(ielend_nucl(nres))
20533 !(maxres)
20534       allocate(istart_nucl(nres,maxint_gr))
20535       allocate(iend_nucl(nres,maxint_gr))
20536 !(maxres,maxint_gr)
20537       allocate(iscpstart_nucl(nres,maxint_gr))
20538       allocate(iscpend_nucl(nres,maxint_gr))
20539 !(maxres,maxint_gr)
20540       allocate(ielstart_vdw_nucl(nres))
20541       allocate(ielend_vdw_nucl(nres))
20542
20543       allocate(lentyp(0:nfgtasks-1))
20544 !(0:maxprocs-1)
20545 !----------------------
20546 ! commom.contacts
20547 !      common /contacts/
20548       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20549       allocate(icont(2,maxcont))
20550 !(2,maxcont)
20551 !      common /contacts1/
20552       allocate(num_cont(0:nres+4))
20553 !(maxres)
20554       allocate(jcont(maxconts,nres))
20555 !(maxconts,maxres)
20556       allocate(facont(maxconts,nres))
20557 !(maxconts,maxres)
20558       allocate(gacont(3,maxconts,nres))
20559 !(3,maxconts,maxres)
20560 !      common /contacts_hb/
20561       allocate(gacontp_hb1(3,maxconts,nres))
20562       allocate(gacontp_hb2(3,maxconts,nres))
20563       allocate(gacontp_hb3(3,maxconts,nres))
20564       allocate(gacontm_hb1(3,maxconts,nres))
20565       allocate(gacontm_hb2(3,maxconts,nres))
20566       allocate(gacontm_hb3(3,maxconts,nres))
20567       allocate(gacont_hbr(3,maxconts,nres))
20568       allocate(grij_hb_cont(3,maxconts,nres))
20569 !(3,maxconts,maxres)
20570       allocate(facont_hb(maxconts,nres))
20571
20572       allocate(ees0p(maxconts,nres))
20573       allocate(ees0m(maxconts,nres))
20574       allocate(d_cont(maxconts,nres))
20575       allocate(ees0plist(maxconts,nres))
20576
20577 !(maxconts,maxres)
20578       allocate(num_cont_hb(nres))
20579 !(maxres)
20580       allocate(jcont_hb(maxconts,nres))
20581 !(maxconts,maxres)
20582 !      common /rotat/
20583       allocate(Ug(2,2,nres))
20584       allocate(Ugder(2,2,nres))
20585       allocate(Ug2(2,2,nres))
20586       allocate(Ug2der(2,2,nres))
20587 !(2,2,maxres)
20588       allocate(obrot(2,nres))
20589       allocate(obrot2(2,nres))
20590       allocate(obrot_der(2,nres))
20591       allocate(obrot2_der(2,nres))
20592 !(2,maxres)
20593 !      common /precomp1/
20594       allocate(mu(2,nres))
20595       allocate(muder(2,nres))
20596       allocate(Ub2(2,nres))
20597       Ub2(1,:)=0.0d0
20598       Ub2(2,:)=0.0d0
20599       allocate(Ub2der(2,nres))
20600       allocate(Ctobr(2,nres))
20601       allocate(Ctobrder(2,nres))
20602       allocate(Dtobr2(2,nres))
20603       allocate(Dtobr2der(2,nres))
20604 !(2,maxres)
20605       allocate(EUg(2,2,nres))
20606       allocate(EUgder(2,2,nres))
20607       allocate(CUg(2,2,nres))
20608       allocate(CUgder(2,2,nres))
20609       allocate(DUg(2,2,nres))
20610       allocate(Dugder(2,2,nres))
20611       allocate(DtUg2(2,2,nres))
20612       allocate(DtUg2der(2,2,nres))
20613 !(2,2,maxres)
20614 !      common /precomp2/
20615       allocate(Ug2Db1t(2,nres))
20616       allocate(Ug2Db1tder(2,nres))
20617       allocate(CUgb2(2,nres))
20618       allocate(CUgb2der(2,nres))
20619 !(2,maxres)
20620       allocate(EUgC(2,2,nres))
20621       allocate(EUgCder(2,2,nres))
20622       allocate(EUgD(2,2,nres))
20623       allocate(EUgDder(2,2,nres))
20624       allocate(DtUg2EUg(2,2,nres))
20625       allocate(Ug2DtEUg(2,2,nres))
20626 !(2,2,maxres)
20627       allocate(Ug2DtEUgder(2,2,2,nres))
20628       allocate(DtUg2EUgder(2,2,2,nres))
20629 !(2,2,2,maxres)
20630       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20631       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20632       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20633       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20634
20635       allocate(ctilde(2,2,nres))
20636       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20637       allocate(gtb1(2,nres))
20638       allocate(gtb2(2,nres))
20639       allocate(cc(2,2,nres))
20640       allocate(dd(2,2,nres))
20641       allocate(ee(2,2,nres))
20642       allocate(gtcc(2,2,nres))
20643       allocate(gtdd(2,2,nres))
20644       allocate(gtee(2,2,nres))
20645       allocate(gUb2(2,nres))
20646       allocate(gteUg(2,2,nres))
20647
20648 !      common /rotat_old/
20649       allocate(costab(nres))
20650       allocate(sintab(nres))
20651       allocate(costab2(nres))
20652       allocate(sintab2(nres))
20653 !(maxres)
20654 !      common /dipmat/
20655       allocate(a_chuj(2,2,maxconts,nres))
20656 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20657       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20658 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20659 !      common /contdistrib/
20660       allocate(ncont_sent(nres))
20661       allocate(ncont_recv(nres))
20662
20663       allocate(iat_sent(nres))
20664 !(maxres)
20665       allocate(iint_sent(4,nres,nres))
20666       allocate(iint_sent_local(4,nres,nres))
20667 !(4,maxres,maxres)
20668       allocate(iturn3_sent(4,0:nres+4))
20669       allocate(iturn4_sent(4,0:nres+4))
20670       allocate(iturn3_sent_local(4,nres))
20671       allocate(iturn4_sent_local(4,nres))
20672 !(4,maxres)
20673       allocate(itask_cont_from(0:nfgtasks-1))
20674       allocate(itask_cont_to(0:nfgtasks-1))
20675 !(0:max_fg_procs-1)
20676
20677
20678
20679 !----------------------
20680 ! commom.deriv;
20681 !      common /derivat/
20682       allocate(dcdv(6,maxdim))
20683       allocate(dxdv(6,maxdim))
20684 !(6,maxdim)
20685       allocate(dxds(6,nres))
20686 !(6,maxres)
20687       allocate(gradx(3,-1:nres,0:2))
20688       allocate(gradc(3,-1:nres,0:2))
20689 !(3,maxres,2)
20690       allocate(gvdwx(3,-1:nres))
20691       allocate(gvdwc(3,-1:nres))
20692       allocate(gelc(3,-1:nres))
20693       allocate(gelc_long(3,-1:nres))
20694       allocate(gvdwpp(3,-1:nres))
20695       allocate(gvdwc_scpp(3,-1:nres))
20696       allocate(gradx_scp(3,-1:nres))
20697       allocate(gvdwc_scp(3,-1:nres))
20698       allocate(ghpbx(3,-1:nres))
20699       allocate(ghpbc(3,-1:nres))
20700       allocate(gradcorr(3,-1:nres))
20701       allocate(gradcorr_long(3,-1:nres))
20702       allocate(gradcorr5_long(3,-1:nres))
20703       allocate(gradcorr6_long(3,-1:nres))
20704       allocate(gcorr6_turn_long(3,-1:nres))
20705       allocate(gradxorr(3,-1:nres))
20706       allocate(gradcorr5(3,-1:nres))
20707       allocate(gradcorr6(3,-1:nres))
20708       allocate(gliptran(3,-1:nres))
20709       allocate(gliptranc(3,-1:nres))
20710       allocate(gliptranx(3,-1:nres))
20711       allocate(gshieldx(3,-1:nres))
20712       allocate(gshieldc(3,-1:nres))
20713       allocate(gshieldc_loc(3,-1:nres))
20714       allocate(gshieldx_ec(3,-1:nres))
20715       allocate(gshieldc_ec(3,-1:nres))
20716       allocate(gshieldc_loc_ec(3,-1:nres))
20717       allocate(gshieldx_t3(3,-1:nres))
20718       allocate(gshieldc_t3(3,-1:nres))
20719       allocate(gshieldc_loc_t3(3,-1:nres))
20720       allocate(gshieldx_t4(3,-1:nres))
20721       allocate(gshieldc_t4(3,-1:nres))
20722       allocate(gshieldc_loc_t4(3,-1:nres))
20723       allocate(gshieldx_ll(3,-1:nres))
20724       allocate(gshieldc_ll(3,-1:nres))
20725       allocate(gshieldc_loc_ll(3,-1:nres))
20726       allocate(grad_shield(3,-1:nres))
20727       allocate(gg_tube_sc(3,-1:nres))
20728       allocate(gg_tube(3,-1:nres))
20729       allocate(gradafm(3,-1:nres))
20730       allocate(gradb_nucl(3,-1:nres))
20731       allocate(gradbx_nucl(3,-1:nres))
20732       allocate(gvdwpsb1(3,-1:nres))
20733       allocate(gelpp(3,-1:nres))
20734       allocate(gvdwpsb(3,-1:nres))
20735       allocate(gelsbc(3,-1:nres))
20736       allocate(gelsbx(3,-1:nres))
20737       allocate(gvdwsbx(3,-1:nres))
20738       allocate(gvdwsbc(3,-1:nres))
20739       allocate(gsbloc(3,-1:nres))
20740       allocate(gsblocx(3,-1:nres))
20741       allocate(gradcorr_nucl(3,-1:nres))
20742       allocate(gradxorr_nucl(3,-1:nres))
20743       allocate(gradcorr3_nucl(3,-1:nres))
20744       allocate(gradxorr3_nucl(3,-1:nres))
20745       allocate(gvdwpp_nucl(3,-1:nres))
20746       allocate(gradpepcat(3,-1:nres))
20747       allocate(gradpepcatx(3,-1:nres))
20748       allocate(gradcatcat(3,-1:nres))
20749 !(3,maxres)
20750       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20751       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20752 ! grad for shielding surroing
20753       allocate(gloc(0:maxvar,0:2))
20754       allocate(gloc_x(0:maxvar,2))
20755 !(maxvar,2)
20756       allocate(gel_loc(3,-1:nres))
20757       allocate(gel_loc_long(3,-1:nres))
20758       allocate(gcorr3_turn(3,-1:nres))
20759       allocate(gcorr4_turn(3,-1:nres))
20760       allocate(gcorr6_turn(3,-1:nres))
20761       allocate(gradb(3,-1:nres))
20762       allocate(gradbx(3,-1:nres))
20763 !(3,maxres)
20764       allocate(gel_loc_loc(maxvar))
20765       allocate(gel_loc_turn3(maxvar))
20766       allocate(gel_loc_turn4(maxvar))
20767       allocate(gel_loc_turn6(maxvar))
20768       allocate(gcorr_loc(maxvar))
20769       allocate(g_corr5_loc(maxvar))
20770       allocate(g_corr6_loc(maxvar))
20771 !(maxvar)
20772       allocate(gsccorc(3,-1:nres))
20773       allocate(gsccorx(3,-1:nres))
20774 !(3,maxres)
20775       allocate(gsccor_loc(-1:nres))
20776 !(maxres)
20777       allocate(gvdwx_scbase(3,-1:nres))
20778       allocate(gvdwc_scbase(3,-1:nres))
20779       allocate(gvdwx_pepbase(3,-1:nres))
20780       allocate(gvdwc_pepbase(3,-1:nres))
20781       allocate(gvdwx_scpho(3,-1:nres))
20782       allocate(gvdwc_scpho(3,-1:nres))
20783       allocate(gvdwc_peppho(3,-1:nres))
20784
20785       allocate(dtheta(3,2,-1:nres))
20786 !(3,2,maxres)
20787       allocate(gscloc(3,-1:nres))
20788       allocate(gsclocx(3,-1:nres))
20789 !(3,maxres)
20790       allocate(dphi(3,3,-1:nres))
20791       allocate(dalpha(3,3,-1:nres))
20792       allocate(domega(3,3,-1:nres))
20793 !(3,3,maxres)
20794 !      common /deriv_scloc/
20795       allocate(dXX_C1tab(3,nres))
20796       allocate(dYY_C1tab(3,nres))
20797       allocate(dZZ_C1tab(3,nres))
20798       allocate(dXX_Ctab(3,nres))
20799       allocate(dYY_Ctab(3,nres))
20800       allocate(dZZ_Ctab(3,nres))
20801       allocate(dXX_XYZtab(3,nres))
20802       allocate(dYY_XYZtab(3,nres))
20803       allocate(dZZ_XYZtab(3,nres))
20804 !(3,maxres)
20805 !      common /mpgrad/
20806       allocate(jgrad_start(nres))
20807       allocate(jgrad_end(nres))
20808 !(maxres)
20809 !----------------------
20810
20811 !      common /indices/
20812       allocate(ibond_displ(0:nfgtasks-1))
20813       allocate(ibond_count(0:nfgtasks-1))
20814       allocate(ithet_displ(0:nfgtasks-1))
20815       allocate(ithet_count(0:nfgtasks-1))
20816       allocate(iphi_displ(0:nfgtasks-1))
20817       allocate(iphi_count(0:nfgtasks-1))
20818       allocate(iphi1_displ(0:nfgtasks-1))
20819       allocate(iphi1_count(0:nfgtasks-1))
20820       allocate(ivec_displ(0:nfgtasks-1))
20821       allocate(ivec_count(0:nfgtasks-1))
20822       allocate(iset_displ(0:nfgtasks-1))
20823       allocate(iset_count(0:nfgtasks-1))
20824       allocate(iint_count(0:nfgtasks-1))
20825       allocate(iint_displ(0:nfgtasks-1))
20826 !(0:max_fg_procs-1)
20827 !----------------------
20828 ! common.MD
20829 !      common /mdgrad/
20830       allocate(gcart(3,-1:nres))
20831       allocate(gxcart(3,-1:nres))
20832 !(3,0:MAXRES)
20833       allocate(gradcag(3,-1:nres))
20834       allocate(gradxag(3,-1:nres))
20835 !(3,MAXRES)
20836 !      common /back_constr/
20837 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20838       allocate(dutheta(nres))
20839       allocate(dugamma(nres))
20840 !(maxres)
20841       allocate(duscdiff(3,nres))
20842       allocate(duscdiffx(3,nres))
20843 !(3,maxres)
20844 !el i io:read_fragments
20845 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20846 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20847 !      common /qmeas/
20848 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20849 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20850       allocate(mset(0:nprocs))  !(maxprocs/20)
20851       mset(:)=0
20852 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20853 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20854       allocate(dUdconst(3,0:nres))
20855       allocate(dUdxconst(3,0:nres))
20856       allocate(dqwol(3,0:nres))
20857       allocate(dxqwol(3,0:nres))
20858 !(3,0:MAXRES)
20859 !----------------------
20860 ! common.sbridge
20861 !      common /sbridge/ in io_common: read_bridge
20862 !el    allocate((:),allocatable :: iss      !(maxss)
20863 !      common /links/  in io_common: read_bridge
20864 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20865 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20866 !      common /dyn_ssbond/
20867 ! and side-chain vectors in theta or phi.
20868       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20869 !(maxres,maxres)
20870 !      do i=1,nres
20871 !        do j=i+1,nres
20872       dyn_ssbond_ij(:,:)=1.0d300
20873 !        enddo
20874 !      enddo
20875
20876 !      if (nss.gt.0) then
20877         allocate(idssb(maxdim),jdssb(maxdim))
20878 !        allocate(newihpb(nss),newjhpb(nss))
20879 !(maxdim)
20880 !      endif
20881       allocate(ishield_list(-1:nres))
20882       allocate(shield_list(maxcontsshi,-1:nres))
20883       allocate(dyn_ss_mask(nres))
20884       allocate(fac_shield(-1:nres))
20885       allocate(enetube(nres*2))
20886       allocate(enecavtube(nres*2))
20887
20888 !(maxres)
20889       dyn_ss_mask(:)=.false.
20890 !----------------------
20891 ! common.sccor
20892 ! Parameters of the SCCOR term
20893 !      common/sccor/
20894 !el in io_conf: parmread
20895 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20896 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20897 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20898 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20899 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20900 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20901 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20902 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20903 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20904 !----------------
20905       allocate(gloc_sc(3,0:2*nres,0:10))
20906 !(3,0:maxres2,10)maxres2=2*maxres
20907       allocate(dcostau(3,3,3,2*nres))
20908       allocate(dsintau(3,3,3,2*nres))
20909       allocate(dtauangle(3,3,3,2*nres))
20910       allocate(dcosomicron(3,3,3,2*nres))
20911       allocate(domicron(3,3,3,2*nres))
20912 !(3,3,3,maxres2)maxres2=2*maxres
20913 !----------------------
20914 ! common.var
20915 !      common /restr/
20916       allocate(varall(maxvar))
20917 !(maxvar)(maxvar=6*maxres)
20918       allocate(mask_theta(nres))
20919       allocate(mask_phi(nres))
20920       allocate(mask_side(nres))
20921 !(maxres)
20922 !----------------------
20923 ! common.vectors
20924 !      common /vectors/
20925       allocate(uy(3,nres))
20926       allocate(uz(3,nres))
20927 !(3,maxres)
20928       allocate(uygrad(3,3,2,nres))
20929       allocate(uzgrad(3,3,2,nres))
20930 !(3,3,2,maxres)
20931
20932       return
20933       end subroutine alloc_ener_arrays
20934 !-----------------------------------------------------------------
20935       subroutine ebond_nucl(estr_nucl)
20936 !c
20937 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20938 !c
20939
20940       real(kind=8),dimension(3) :: u,ud
20941       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20942       real(kind=8) :: estr_nucl,diff
20943       integer :: iti,i,j,k,nbi
20944       estr_nucl=0.0d0
20945 !C      print *,"I enter ebond"
20946       if (energy_dec) &
20947       write (iout,*) "ibondp_start,ibondp_end",&
20948        ibondp_nucl_start,ibondp_nucl_end
20949       do i=ibondp_nucl_start,ibondp_nucl_end
20950         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20951          itype(i,2).eq.ntyp1_molec(2)) cycle
20952 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20953 !          do j=1,3
20954 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20955 !     &      *dc(j,i-1)/vbld(i)
20956 !          enddo
20957 !          if (energy_dec) write(iout,*)
20958 !     &       "estr1",i,vbld(i),distchainmax,
20959 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20960
20961           diff = vbld(i)-vbldp0_nucl
20962           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20963           vbldp0_nucl,diff,AKP_nucl*diff*diff
20964           estr_nucl=estr_nucl+diff*diff
20965 !          print *,estr_nucl
20966           do j=1,3
20967             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20968           enddo
20969 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20970       enddo
20971       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20972 !      print *,"partial sum", estr_nucl,AKP_nucl
20973
20974       if (energy_dec) &
20975       write (iout,*) "ibondp_start,ibondp_end",&
20976        ibond_nucl_start,ibond_nucl_end
20977
20978       do i=ibond_nucl_start,ibond_nucl_end
20979 !C        print *, "I am stuck",i
20980         iti=itype(i,2)
20981         if (iti.eq.ntyp1_molec(2)) cycle
20982           nbi=nbondterm_nucl(iti)
20983 !C        print *,iti,nbi
20984           if (nbi.eq.1) then
20985             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20986
20987             if (energy_dec) &
20988            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20989            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20990             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20991 !            print *,estr_nucl
20992             do j=1,3
20993               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20994             enddo
20995           else
20996             do j=1,nbi
20997               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20998               ud(j)=aksc_nucl(j,iti)*diff
20999               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21000             enddo
21001             uprod=u(1)
21002             do j=2,nbi
21003               uprod=uprod*u(j)
21004             enddo
21005             usum=0.0d0
21006             usumsqder=0.0d0
21007             do j=1,nbi
21008               uprod1=1.0d0
21009               uprod2=1.0d0
21010               do k=1,nbi
21011                 if (k.ne.j) then
21012                   uprod1=uprod1*u(k)
21013                   uprod2=uprod2*u(k)*u(k)
21014                 endif
21015               enddo
21016               usum=usum+uprod1
21017               usumsqder=usumsqder+ud(j)*uprod2
21018             enddo
21019             estr_nucl=estr_nucl+uprod/usum
21020             do j=1,3
21021              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21022             enddo
21023         endif
21024       enddo
21025 !C      print *,"I am about to leave ebond"
21026       return
21027       end subroutine ebond_nucl
21028
21029 !-----------------------------------------------------------------------------
21030       subroutine ebend_nucl(etheta_nucl)
21031       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21032       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21033       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21034       logical :: lprn=.false., lprn1=.false.
21035 !el local variables
21036       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21037       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21038       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21039 ! local variables for constrains
21040       real(kind=8) :: difi,thetiii
21041        integer itheta
21042       etheta_nucl=0.0D0
21043 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21044       do i=ithet_nucl_start,ithet_nucl_end
21045         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21046         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21047         (itype(i,2).eq.ntyp1_molec(2))) cycle
21048         dethetai=0.0d0
21049         dephii=0.0d0
21050         dephii1=0.0d0
21051         theti2=0.5d0*theta(i)
21052         ityp2=ithetyp_nucl(itype(i-1,2))
21053         do k=1,nntheterm_nucl
21054           coskt(k)=dcos(k*theti2)
21055           sinkt(k)=dsin(k*theti2)
21056         enddo
21057         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21058 #ifdef OSF
21059           phii=phi(i)
21060           if (phii.ne.phii) phii=150.0
21061 #else
21062           phii=phi(i)
21063 #endif
21064           ityp1=ithetyp_nucl(itype(i-2,2))
21065           do k=1,nsingle_nucl
21066             cosph1(k)=dcos(k*phii)
21067             sinph1(k)=dsin(k*phii)
21068           enddo
21069         else
21070           phii=0.0d0
21071           ityp1=nthetyp_nucl+1
21072           do k=1,nsingle_nucl
21073             cosph1(k)=0.0d0
21074             sinph1(k)=0.0d0
21075           enddo
21076         endif
21077
21078         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21079 #ifdef OSF
21080           phii1=phi(i+1)
21081           if (phii1.ne.phii1) phii1=150.0
21082           phii1=pinorm(phii1)
21083 #else
21084           phii1=phi(i+1)
21085 #endif
21086           ityp3=ithetyp_nucl(itype(i,2))
21087           do k=1,nsingle_nucl
21088             cosph2(k)=dcos(k*phii1)
21089             sinph2(k)=dsin(k*phii1)
21090           enddo
21091         else
21092           phii1=0.0d0
21093           ityp3=nthetyp_nucl+1
21094           do k=1,nsingle_nucl
21095             cosph2(k)=0.0d0
21096             sinph2(k)=0.0d0
21097           enddo
21098         endif
21099         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21100         do k=1,ndouble_nucl
21101           do l=1,k-1
21102             ccl=cosph1(l)*cosph2(k-l)
21103             ssl=sinph1(l)*sinph2(k-l)
21104             scl=sinph1(l)*cosph2(k-l)
21105             csl=cosph1(l)*sinph2(k-l)
21106             cosph1ph2(l,k)=ccl-ssl
21107             cosph1ph2(k,l)=ccl+ssl
21108             sinph1ph2(l,k)=scl+csl
21109             sinph1ph2(k,l)=scl-csl
21110           enddo
21111         enddo
21112         if (lprn) then
21113         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21114          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21115         write (iout,*) "coskt and sinkt",nntheterm_nucl
21116         do k=1,nntheterm_nucl
21117           write (iout,*) k,coskt(k),sinkt(k)
21118         enddo
21119         endif
21120         do k=1,ntheterm_nucl
21121           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21122           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21123            *coskt(k)
21124           if (lprn)&
21125          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21126           " ethetai",ethetai
21127         enddo
21128         if (lprn) then
21129         write (iout,*) "cosph and sinph"
21130         do k=1,nsingle_nucl
21131           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21132         enddo
21133         write (iout,*) "cosph1ph2 and sinph2ph2"
21134         do k=2,ndouble_nucl
21135           do l=1,k-1
21136             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21137               sinph1ph2(l,k),sinph1ph2(k,l)
21138           enddo
21139         enddo
21140         write(iout,*) "ethetai",ethetai
21141         endif
21142         do m=1,ntheterm2_nucl
21143           do k=1,nsingle_nucl
21144             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21145               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21146               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21147               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21148             ethetai=ethetai+sinkt(m)*aux
21149             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21150             dephii=dephii+k*sinkt(m)*(&
21151                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21152                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21153             dephii1=dephii1+k*sinkt(m)*(&
21154                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21155                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21156             if (lprn) &
21157            write (iout,*) "m",m," k",k," bbthet",&
21158               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21159               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21160               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21161               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21162           enddo
21163         enddo
21164         if (lprn) &
21165         write(iout,*) "ethetai",ethetai
21166         do m=1,ntheterm3_nucl
21167           do k=2,ndouble_nucl
21168             do l=1,k-1
21169               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21170                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21171                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21172                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21173               ethetai=ethetai+sinkt(m)*aux
21174               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21175               dephii=dephii+l*sinkt(m)*(&
21176                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21177                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21178                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21179                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21180               dephii1=dephii1+(k-l)*sinkt(m)*( &
21181                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21182                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21183                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21184                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21185               if (lprn) then
21186               write (iout,*) "m",m," k",k," l",l," ffthet", &
21187                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21188                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21189                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21190                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21191               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21192                  cosph1ph2(k,l)*sinkt(m),&
21193                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21194               endif
21195             enddo
21196           enddo
21197         enddo
21198 10      continue
21199         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21200         i,theta(i)*rad2deg,phii*rad2deg, &
21201         phii1*rad2deg,ethetai
21202         etheta_nucl=etheta_nucl+ethetai
21203 !        print *,i,"partial sum",etheta_nucl
21204         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21205         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21206         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21207       enddo
21208       return
21209       end subroutine ebend_nucl
21210 !----------------------------------------------------
21211       subroutine etor_nucl(etors_nucl)
21212 !      implicit real*8 (a-h,o-z)
21213 !      include 'DIMENSIONS'
21214 !      include 'COMMON.VAR'
21215 !      include 'COMMON.GEO'
21216 !      include 'COMMON.LOCAL'
21217 !      include 'COMMON.TORSION'
21218 !      include 'COMMON.INTERACT'
21219 !      include 'COMMON.DERIV'
21220 !      include 'COMMON.CHAIN'
21221 !      include 'COMMON.NAMES'
21222 !      include 'COMMON.IOUNITS'
21223 !      include 'COMMON.FFIELD'
21224 !      include 'COMMON.TORCNSTR'
21225 !      include 'COMMON.CONTROL'
21226       real(kind=8) :: etors_nucl,edihcnstr
21227       logical :: lprn
21228 !el local variables
21229       integer :: i,j,iblock,itori,itori1
21230       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21231                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21232 ! Set lprn=.true. for debugging
21233       lprn=.false.
21234 !     lprn=.true.
21235       etors_nucl=0.0D0
21236 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21237       do i=iphi_nucl_start,iphi_nucl_end
21238         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21239              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21240              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21241         etors_ii=0.0D0
21242         itori=itortyp_nucl(itype(i-2,2))
21243         itori1=itortyp_nucl(itype(i-1,2))
21244         phii=phi(i)
21245 !         print *,i,itori,itori1
21246         gloci=0.0D0
21247 !C Regular cosine and sine terms
21248         do j=1,nterm_nucl(itori,itori1)
21249           v1ij=v1_nucl(j,itori,itori1)
21250           v2ij=v2_nucl(j,itori,itori1)
21251           cosphi=dcos(j*phii)
21252           sinphi=dsin(j*phii)
21253           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21254           if (energy_dec) etors_ii=etors_ii+&
21255                      v1ij*cosphi+v2ij*sinphi
21256           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21257         enddo
21258 !C Lorentz terms
21259 !C                         v1
21260 !C  E = SUM ----------------------------------- - v1
21261 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21262 !C
21263         cosphi=dcos(0.5d0*phii)
21264         sinphi=dsin(0.5d0*phii)
21265         do j=1,nlor_nucl(itori,itori1)
21266           vl1ij=vlor1_nucl(j,itori,itori1)
21267           vl2ij=vlor2_nucl(j,itori,itori1)
21268           vl3ij=vlor3_nucl(j,itori,itori1)
21269           pom=vl2ij*cosphi+vl3ij*sinphi
21270           pom1=1.0d0/(pom*pom+1.0d0)
21271           etors_nucl=etors_nucl+vl1ij*pom1
21272           if (energy_dec) etors_ii=etors_ii+ &
21273                      vl1ij*pom1
21274           pom=-pom*pom1*pom1
21275           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21276         enddo
21277 !C Subtract the constant term
21278         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21279           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21280               'etor',i,etors_ii-v0_nucl(itori,itori1)
21281         if (lprn) &
21282        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21283        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21284        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21285         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21286 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21287       enddo
21288       return
21289       end subroutine etor_nucl
21290 !------------------------------------------------------------
21291       subroutine epp_nucl_sub(evdw1,ees)
21292 !C
21293 !C This subroutine calculates the average interaction energy and its gradient
21294 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21295 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21296 !C The potential depends both on the distance of peptide-group centers and on
21297 !C the orientation of the CA-CA virtual bonds.
21298 !C
21299       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21300       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21301       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21302                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21303                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21304       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21305                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21306       integer xshift,yshift,zshift
21307       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21308       real(kind=8) :: ees,eesij
21309 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21310       real(kind=8) scal_el /0.5d0/
21311       t_eelecij=0.0d0
21312       ees=0.0D0
21313       evdw1=0.0D0
21314       ind=0
21315 !c
21316 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21317 !c
21318 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21319       do i=iatel_s_nucl,iatel_e_nucl
21320         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21321         dxi=dc(1,i)
21322         dyi=dc(2,i)
21323         dzi=dc(3,i)
21324         dx_normi=dc_norm(1,i)
21325         dy_normi=dc_norm(2,i)
21326         dz_normi=dc_norm(3,i)
21327         xmedi=c(1,i)+0.5d0*dxi
21328         ymedi=c(2,i)+0.5d0*dyi
21329         zmedi=c(3,i)+0.5d0*dzi
21330           xmedi=dmod(xmedi,boxxsize)
21331           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21332           ymedi=dmod(ymedi,boxysize)
21333           if (ymedi.lt.0) ymedi=ymedi+boxysize
21334           zmedi=dmod(zmedi,boxzsize)
21335           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21336
21337         do j=ielstart_nucl(i),ielend_nucl(i)
21338           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21339           ind=ind+1
21340           dxj=dc(1,j)
21341           dyj=dc(2,j)
21342           dzj=dc(3,j)
21343 !          xj=c(1,j)+0.5D0*dxj-xmedi
21344 !          yj=c(2,j)+0.5D0*dyj-ymedi
21345 !          zj=c(3,j)+0.5D0*dzj-zmedi
21346           xj=c(1,j)+0.5D0*dxj
21347           yj=c(2,j)+0.5D0*dyj
21348           zj=c(3,j)+0.5D0*dzj
21349           xj=mod(xj,boxxsize)
21350           if (xj.lt.0) xj=xj+boxxsize
21351           yj=mod(yj,boxysize)
21352           if (yj.lt.0) yj=yj+boxysize
21353           zj=mod(zj,boxzsize)
21354           if (zj.lt.0) zj=zj+boxzsize
21355       isubchap=0
21356       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21357       xj_safe=xj
21358       yj_safe=yj
21359       zj_safe=zj
21360       do xshift=-1,1
21361       do yshift=-1,1
21362       do zshift=-1,1
21363           xj=xj_safe+xshift*boxxsize
21364           yj=yj_safe+yshift*boxysize
21365           zj=zj_safe+zshift*boxzsize
21366           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21367           if(dist_temp.lt.dist_init) then
21368             dist_init=dist_temp
21369             xj_temp=xj
21370             yj_temp=yj
21371             zj_temp=zj
21372             isubchap=1
21373           endif
21374        enddo
21375        enddo
21376        enddo
21377        if (isubchap.eq.1) then
21378 !C          print *,i,j
21379           xj=xj_temp-xmedi
21380           yj=yj_temp-ymedi
21381           zj=zj_temp-zmedi
21382        else
21383           xj=xj_safe-xmedi
21384           yj=yj_safe-ymedi
21385           zj=zj_safe-zmedi
21386        endif
21387
21388           rij=xj*xj+yj*yj+zj*zj
21389 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21390           fac=(r0pp**2/rij)**3
21391           ev1=epspp*fac*fac
21392           ev2=epspp*fac
21393           evdw1ij=ev1-2*ev2
21394           fac=(-ev1-evdw1ij)/rij
21395 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21396           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21397           evdw1=evdw1+evdw1ij
21398 !C
21399 !C Calculate contributions to the Cartesian gradient.
21400 !C
21401           ggg(1)=fac*xj
21402           ggg(2)=fac*yj
21403           ggg(3)=fac*zj
21404           do k=1,3
21405             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21406             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21407           enddo
21408 !c phoshate-phosphate electrostatic interactions
21409           rij=dsqrt(rij)
21410           fac=1.0d0/rij
21411           eesij=dexp(-BEES*rij)*fac
21412 !          write (2,*)"fac",fac," eesijpp",eesij
21413           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21414           ees=ees+eesij
21415 !c          fac=-eesij*fac
21416           fac=-(fac+BEES)*eesij*fac
21417           ggg(1)=fac*xj
21418           ggg(2)=fac*yj
21419           ggg(3)=fac*zj
21420 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21421 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21422 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21423           do k=1,3
21424             gelpp(k,i)=gelpp(k,i)-ggg(k)
21425             gelpp(k,j)=gelpp(k,j)+ggg(k)
21426           enddo
21427         enddo ! j
21428       enddo   ! i
21429 !c      ees=332.0d0*ees
21430       ees=AEES*ees
21431       do i=nnt,nct
21432 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21433         do k=1,3
21434           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21435 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21436           gelpp(k,i)=AEES*gelpp(k,i)
21437         enddo
21438 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21439       enddo
21440 !c      write (2,*) "total EES",ees
21441       return
21442       end subroutine epp_nucl_sub
21443 !---------------------------------------------------------------------
21444       subroutine epsb(evdwpsb,eelpsb)
21445 !      use comm_locel
21446 !C
21447 !C This subroutine calculates the excluded-volume interaction energy between
21448 !C peptide-group centers and side chains and its gradient in virtual-bond and
21449 !C side-chain vectors.
21450 !C
21451       real(kind=8),dimension(3):: ggg
21452       integer :: i,iint,j,k,iteli,itypj,subchap
21453       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21454                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21455       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21456                     dist_temp, dist_init
21457       integer xshift,yshift,zshift
21458
21459 !cd    print '(a)','Enter ESCP'
21460 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21461       eelpsb=0.0d0
21462       evdwpsb=0.0d0
21463 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21464       do i=iatscp_s_nucl,iatscp_e_nucl
21465         if (itype(i,2).eq.ntyp1_molec(2) &
21466          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21467         xi=0.5D0*(c(1,i)+c(1,i+1))
21468         yi=0.5D0*(c(2,i)+c(2,i+1))
21469         zi=0.5D0*(c(3,i)+c(3,i+1))
21470           xi=mod(xi,boxxsize)
21471           if (xi.lt.0) xi=xi+boxxsize
21472           yi=mod(yi,boxysize)
21473           if (yi.lt.0) yi=yi+boxysize
21474           zi=mod(zi,boxzsize)
21475           if (zi.lt.0) zi=zi+boxzsize
21476
21477         do iint=1,nscp_gr_nucl(i)
21478
21479         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21480           itypj=itype(j,2)
21481           if (itypj.eq.ntyp1_molec(2)) cycle
21482 !C Uncomment following three lines for SC-p interactions
21483 !c         xj=c(1,nres+j)-xi
21484 !c         yj=c(2,nres+j)-yi
21485 !c         zj=c(3,nres+j)-zi
21486 !C Uncomment following three lines for Ca-p interactions
21487 !          xj=c(1,j)-xi
21488 !          yj=c(2,j)-yi
21489 !          zj=c(3,j)-zi
21490           xj=c(1,j)
21491           yj=c(2,j)
21492           zj=c(3,j)
21493           xj=mod(xj,boxxsize)
21494           if (xj.lt.0) xj=xj+boxxsize
21495           yj=mod(yj,boxysize)
21496           if (yj.lt.0) yj=yj+boxysize
21497           zj=mod(zj,boxzsize)
21498           if (zj.lt.0) zj=zj+boxzsize
21499       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21500       xj_safe=xj
21501       yj_safe=yj
21502       zj_safe=zj
21503       subchap=0
21504       do xshift=-1,1
21505       do yshift=-1,1
21506       do zshift=-1,1
21507           xj=xj_safe+xshift*boxxsize
21508           yj=yj_safe+yshift*boxysize
21509           zj=zj_safe+zshift*boxzsize
21510           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21511           if(dist_temp.lt.dist_init) then
21512             dist_init=dist_temp
21513             xj_temp=xj
21514             yj_temp=yj
21515             zj_temp=zj
21516             subchap=1
21517           endif
21518        enddo
21519        enddo
21520        enddo
21521        if (subchap.eq.1) then
21522           xj=xj_temp-xi
21523           yj=yj_temp-yi
21524           zj=zj_temp-zi
21525        else
21526           xj=xj_safe-xi
21527           yj=yj_safe-yi
21528           zj=zj_safe-zi
21529        endif
21530
21531           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21532           fac=rrij**expon2
21533           e1=fac*fac*aad_nucl(itypj)
21534           e2=fac*bad_nucl(itypj)
21535           if (iabs(j-i) .le. 2) then
21536             e1=scal14*e1
21537             e2=scal14*e2
21538           endif
21539           evdwij=e1+e2
21540           evdwpsb=evdwpsb+evdwij
21541           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21542              'evdw2',i,j,evdwij,"tu4"
21543 !C
21544 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21545 !C
21546           fac=-(evdwij+e1)*rrij
21547           ggg(1)=xj*fac
21548           ggg(2)=yj*fac
21549           ggg(3)=zj*fac
21550           do k=1,3
21551             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21552             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21553           enddo
21554         enddo
21555
21556         enddo ! iint
21557       enddo ! i
21558       do i=1,nct
21559         do j=1,3
21560           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21561           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21562         enddo
21563       enddo
21564       return
21565       end subroutine epsb
21566
21567 !------------------------------------------------------
21568       subroutine esb_gb(evdwsb,eelsb)
21569       use comm_locel
21570       use calc_data_nucl
21571       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21572       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21573       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21574       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21575                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21576       integer :: ii
21577       logical lprn
21578       evdw=0.0D0
21579       eelsb=0.0d0
21580       ecorr=0.0d0
21581       evdwsb=0.0D0
21582       lprn=.false.
21583       ind=0
21584 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21585       do i=iatsc_s_nucl,iatsc_e_nucl
21586         num_conti=0
21587         num_conti2=0
21588         itypi=itype(i,2)
21589 !        PRINT *,"I=",i,itypi
21590         if (itypi.eq.ntyp1_molec(2)) cycle
21591         itypi1=itype(i+1,2)
21592         xi=c(1,nres+i)
21593         yi=c(2,nres+i)
21594         zi=c(3,nres+i)
21595           xi=dmod(xi,boxxsize)
21596           if (xi.lt.0) xi=xi+boxxsize
21597           yi=dmod(yi,boxysize)
21598           if (yi.lt.0) yi=yi+boxysize
21599           zi=dmod(zi,boxzsize)
21600           if (zi.lt.0) zi=zi+boxzsize
21601
21602         dxi=dc_norm(1,nres+i)
21603         dyi=dc_norm(2,nres+i)
21604         dzi=dc_norm(3,nres+i)
21605         dsci_inv=vbld_inv(i+nres)
21606 !C
21607 !C Calculate SC interaction energy.
21608 !C
21609         do iint=1,nint_gr_nucl(i)
21610 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21611           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21612             ind=ind+1
21613 !            print *,"JESTEM"
21614             itypj=itype(j,2)
21615             if (itypj.eq.ntyp1_molec(2)) cycle
21616             dscj_inv=vbld_inv(j+nres)
21617             sig0ij=sigma_nucl(itypi,itypj)
21618             chi1=chi_nucl(itypi,itypj)
21619             chi2=chi_nucl(itypj,itypi)
21620             chi12=chi1*chi2
21621             chip1=chip_nucl(itypi,itypj)
21622             chip2=chip_nucl(itypj,itypi)
21623             chip12=chip1*chip2
21624 !            xj=c(1,nres+j)-xi
21625 !            yj=c(2,nres+j)-yi
21626 !            zj=c(3,nres+j)-zi
21627            xj=c(1,nres+j)
21628            yj=c(2,nres+j)
21629            zj=c(3,nres+j)
21630           xj=dmod(xj,boxxsize)
21631           if (xj.lt.0) xj=xj+boxxsize
21632           yj=dmod(yj,boxysize)
21633           if (yj.lt.0) yj=yj+boxysize
21634           zj=dmod(zj,boxzsize)
21635           if (zj.lt.0) zj=zj+boxzsize
21636       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21637       xj_safe=xj
21638       yj_safe=yj
21639       zj_safe=zj
21640       subchap=0
21641       do xshift=-1,1
21642       do yshift=-1,1
21643       do zshift=-1,1
21644           xj=xj_safe+xshift*boxxsize
21645           yj=yj_safe+yshift*boxysize
21646           zj=zj_safe+zshift*boxzsize
21647           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21648           if(dist_temp.lt.dist_init) then
21649             dist_init=dist_temp
21650             xj_temp=xj
21651             yj_temp=yj
21652             zj_temp=zj
21653             subchap=1
21654           endif
21655        enddo
21656        enddo
21657        enddo
21658        if (subchap.eq.1) then
21659           xj=xj_temp-xi
21660           yj=yj_temp-yi
21661           zj=zj_temp-zi
21662        else
21663           xj=xj_safe-xi
21664           yj=yj_safe-yi
21665           zj=zj_safe-zi
21666        endif
21667
21668             dxj=dc_norm(1,nres+j)
21669             dyj=dc_norm(2,nres+j)
21670             dzj=dc_norm(3,nres+j)
21671             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21672             rij=dsqrt(rrij)
21673 !C Calculate angle-dependent terms of energy and contributions to their
21674 !C derivatives.
21675             erij(1)=xj*rij
21676             erij(2)=yj*rij
21677             erij(3)=zj*rij
21678             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21679             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21680             om12=dxi*dxj+dyi*dyj+dzi*dzj
21681             call sc_angular_nucl
21682             sigsq=1.0D0/sigsq
21683             sig=sig0ij*dsqrt(sigsq)
21684             rij_shift=1.0D0/rij-sig+sig0ij
21685 !            print *,rij_shift,"rij_shift"
21686 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21687 !c     &       " rij_shift",rij_shift
21688             if (rij_shift.le.0.0D0) then
21689               evdw=1.0D20
21690               return
21691             endif
21692             sigder=-sig*sigsq
21693 !c---------------------------------------------------------------
21694             rij_shift=1.0D0/rij_shift
21695             fac=rij_shift**expon
21696             e1=fac*fac*aa_nucl(itypi,itypj)
21697             e2=fac*bb_nucl(itypi,itypj)
21698             evdwij=eps1*eps2rt*(e1+e2)
21699 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21700 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21701             eps2der=evdwij
21702             evdwij=evdwij*eps2rt
21703             evdwsb=evdwsb+evdwij
21704             if (lprn) then
21705             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21706             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21707             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21708              restyp(itypi,2),i,restyp(itypj,2),j, &
21709              epsi,sigm,chi1,chi2,chip1,chip2, &
21710              eps1,eps2rt**2,sig,sig0ij, &
21711              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21712             evdwij
21713             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21714             endif
21715
21716             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21717                              'evdw',i,j,evdwij,"tu3"
21718
21719
21720 !C Calculate gradient components.
21721             e1=e1*eps1*eps2rt**2
21722             fac=-expon*(e1+evdwij)*rij_shift
21723             sigder=fac*sigder
21724             fac=rij*fac
21725 !c            fac=0.0d0
21726 !C Calculate the radial part of the gradient
21727             gg(1)=xj*fac
21728             gg(2)=yj*fac
21729             gg(3)=zj*fac
21730 !C Calculate angular part of the gradient.
21731             call sc_grad_nucl
21732             call eelsbij(eelij,num_conti2)
21733             if (energy_dec .and. &
21734            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21735           write (istat,'(e14.5)') evdwij
21736             eelsb=eelsb+eelij
21737           enddo      ! j
21738         enddo        ! iint
21739         num_cont_hb(i)=num_conti2
21740       enddo          ! i
21741 !c      write (iout,*) "Number of loop steps in EGB:",ind
21742 !cccc      energy_dec=.false.
21743       return
21744       end subroutine esb_gb
21745 !-------------------------------------------------------------------------------
21746       subroutine eelsbij(eesij,num_conti2)
21747       use comm_locel
21748       use calc_data_nucl
21749       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21750       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21751       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21752                     dist_temp, dist_init,rlocshield,fracinbuf
21753       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21754
21755 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21756       real(kind=8) scal_el /0.5d0/
21757       integer :: iteli,itelj,kkk,kkll,m,isubchap
21758       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21759       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21760       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21761                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21762                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21763                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21764                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21765                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21766                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21767                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21768       ind=ind+1
21769       itypi=itype(i,2)
21770       itypj=itype(j,2)
21771 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21772       ael6i=ael6_nucl(itypi,itypj)
21773       ael3i=ael3_nucl(itypi,itypj)
21774       ael63i=ael63_nucl(itypi,itypj)
21775       ael32i=ael32_nucl(itypi,itypj)
21776 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21777 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21778       dxj=dc(1,j+nres)
21779       dyj=dc(2,j+nres)
21780       dzj=dc(3,j+nres)
21781       dx_normi=dc_norm(1,i+nres)
21782       dy_normi=dc_norm(2,i+nres)
21783       dz_normi=dc_norm(3,i+nres)
21784       dx_normj=dc_norm(1,j+nres)
21785       dy_normj=dc_norm(2,j+nres)
21786       dz_normj=dc_norm(3,j+nres)
21787 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21788 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21789 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21790       if (ipot_nucl.ne.2) then
21791         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21792         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21793         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21794       else
21795         cosa=om12
21796         cosb=om1
21797         cosg=om2
21798       endif
21799       r3ij=rij*rrij
21800       r6ij=r3ij*r3ij
21801       fac=cosa-3.0D0*cosb*cosg
21802       facfac=fac*fac
21803       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21804       fac3=ael6i*r6ij
21805       fac4=ael3i*r3ij
21806       fac5=ael63i*r6ij
21807       fac6=ael32i*r6ij
21808 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21809 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21810       el1=fac3*(4.0D0+facfac-fac1)
21811       el2=fac4*fac
21812       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21813       el4=fac6*facfac
21814       eesij=el1+el2+el3+el4
21815 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21816       ees0ij=4.0D0+facfac-fac1
21817
21818       if (energy_dec) then
21819           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21820           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21821            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21822            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21823            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21824           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21825       endif
21826
21827 !C
21828 !C Calculate contributions to the Cartesian gradient.
21829 !C
21830       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21831       fac1=fac
21832 !c      erij(1)=xj*rmij
21833 !c      erij(2)=yj*rmij
21834 !c      erij(3)=zj*rmij
21835 !*
21836 !* Radial derivatives. First process both termini of the fragment (i,j)
21837 !*
21838       ggg(1)=facel*xj
21839       ggg(2)=facel*yj
21840       ggg(3)=facel*zj
21841       do k=1,3
21842         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21843         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21844         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21845         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21846       enddo
21847 !*
21848 !* Angular part
21849 !*
21850       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21851       fac4=-3.0D0*fac4
21852       fac3=-6.0D0*fac3
21853       fac5= 6.0d0*fac5
21854       fac6=-6.0d0*fac6
21855       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21856        fac6*fac1*cosg
21857       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21858        fac6*fac1*cosb
21859       do k=1,3
21860         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21861         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21862       enddo
21863       do k=1,3
21864         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21865       enddo
21866       do k=1,3
21867         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21868              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21869              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21870         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21871              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21872              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21873         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21874         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21875       enddo
21876 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21877        IF ( j.gt.i+1 .and.&
21878           num_conti.le.maxcont) THEN
21879 !C
21880 !C Calculate the contact function. The ith column of the array JCONT will
21881 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21882 !C greater than I). The arrays FACONT and GACONT will contain the values of
21883 !C the contact function and its derivative.
21884         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21885 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21886         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21887 !c        write (2,*) "fcont",fcont
21888         if (fcont.gt.0.0D0) then
21889           num_conti=num_conti+1
21890           num_conti2=num_conti2+1
21891
21892           if (num_conti.gt.maxconts) then
21893             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21894                           ' will skip next contacts for this conf.',maxconts
21895           else
21896             jcont_hb(num_conti,i)=j
21897 !c            write (iout,*) "num_conti",num_conti,
21898 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21899 !C Calculate contact energies
21900             cosa4=4.0D0*cosa
21901             wij=cosa-3.0D0*cosb*cosg
21902             cosbg1=cosb+cosg
21903             cosbg2=cosb-cosg
21904             fac3=dsqrt(-ael6i)*r3ij
21905 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21906             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21907             if (ees0tmp.gt.0) then
21908               ees0pij=dsqrt(ees0tmp)
21909             else
21910               ees0pij=0
21911             endif
21912             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21913             if (ees0tmp.gt.0) then
21914               ees0mij=dsqrt(ees0tmp)
21915             else
21916               ees0mij=0
21917             endif
21918             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21919             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21920 !c            write (iout,*) "i",i," j",j,
21921 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21922             ees0pij1=fac3/ees0pij
21923             ees0mij1=fac3/ees0mij
21924             fac3p=-3.0D0*fac3*rrij
21925             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21926             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21927             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21928             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21929             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21930             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21931             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21932             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21933             ecosap=ecosa1+ecosa2
21934             ecosbp=ecosb1+ecosb2
21935             ecosgp=ecosg1+ecosg2
21936             ecosam=ecosa1-ecosa2
21937             ecosbm=ecosb1-ecosb2
21938             ecosgm=ecosg1-ecosg2
21939 !C End diagnostics
21940             facont_hb(num_conti,i)=fcont
21941             fprimcont=fprimcont/rij
21942             do k=1,3
21943               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21944               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21945             enddo
21946             gggp(1)=gggp(1)+ees0pijp*xj
21947             gggp(2)=gggp(2)+ees0pijp*yj
21948             gggp(3)=gggp(3)+ees0pijp*zj
21949             gggm(1)=gggm(1)+ees0mijp*xj
21950             gggm(2)=gggm(2)+ees0mijp*yj
21951             gggm(3)=gggm(3)+ees0mijp*zj
21952 !C Derivatives due to the contact function
21953             gacont_hbr(1,num_conti,i)=fprimcont*xj
21954             gacont_hbr(2,num_conti,i)=fprimcont*yj
21955             gacont_hbr(3,num_conti,i)=fprimcont*zj
21956             do k=1,3
21957 !c
21958 !c Gradient of the correlation terms
21959 !c
21960               gacontp_hb1(k,num_conti,i)= &
21961              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21962             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21963               gacontp_hb2(k,num_conti,i)= &
21964              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21965             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21966               gacontp_hb3(k,num_conti,i)=gggp(k)
21967               gacontm_hb1(k,num_conti,i)= &
21968              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21969             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21970               gacontm_hb2(k,num_conti,i)= &
21971              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21972             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21973               gacontm_hb3(k,num_conti,i)=gggm(k)
21974             enddo
21975           endif
21976         endif
21977       ENDIF
21978       return
21979       end subroutine eelsbij
21980 !------------------------------------------------------------------
21981       subroutine sc_grad_nucl
21982       use comm_locel
21983       use calc_data_nucl
21984       real(kind=8),dimension(3) :: dcosom1,dcosom2
21985       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21986       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21987       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21988       do k=1,3
21989         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21990         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21991       enddo
21992       do k=1,3
21993         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21994       enddo
21995       do k=1,3
21996         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21997                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21998                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21999         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22000                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22001                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22002       enddo
22003 !C
22004 !C Calculate the components of the gradient in DC and X
22005 !C
22006       do l=1,3
22007         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22008         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22009       enddo
22010       return
22011       end subroutine sc_grad_nucl
22012 !-----------------------------------------------------------------------
22013       subroutine esb(esbloc)
22014 !C Calculate the local energy of a side chain and its derivatives in the
22015 !C corresponding virtual-bond valence angles THETA and the spherical angles
22016 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22017 !C added by Urszula Kozlowska. 07/11/2007
22018 !C
22019       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22020       real(kind=8),dimension(9):: x
22021      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22022       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22023       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22024       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22025        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22026        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22027        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22028        integer::it,nlobit,i,j,k
22029 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22030       delta=0.02d0*pi
22031       esbloc=0.0D0
22032       do i=loc_start_nucl,loc_end_nucl
22033         if (itype(i,2).eq.ntyp1_molec(2)) cycle
22034         costtab(i+1) =dcos(theta(i+1))
22035         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22036         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22037         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22038         cosfac2=0.5d0/(1.0d0+costtab(i+1))
22039         cosfac=dsqrt(cosfac2)
22040         sinfac2=0.5d0/(1.0d0-costtab(i+1))
22041         sinfac=dsqrt(sinfac2)
22042         it=itype(i,2)
22043         if (it.eq.10) goto 1
22044
22045 !c
22046 !C  Compute the axes of tghe local cartesian coordinates system; store in
22047 !c   x_prime, y_prime and z_prime
22048 !c
22049         do j=1,3
22050           x_prime(j) = 0.00
22051           y_prime(j) = 0.00
22052           z_prime(j) = 0.00
22053         enddo
22054 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22055 !C     &   dc_norm(3,i+nres)
22056         do j = 1,3
22057           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22058           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22059         enddo
22060         do j = 1,3
22061           z_prime(j) = -uz(j,i-1)
22062 !           z_prime(j)=0.0
22063         enddo
22064
22065         xx=0.0d0
22066         yy=0.0d0
22067         zz=0.0d0
22068         do j = 1,3
22069           xx = xx + x_prime(j)*dc_norm(j,i+nres)
22070           yy = yy + y_prime(j)*dc_norm(j,i+nres)
22071           zz = zz + z_prime(j)*dc_norm(j,i+nres)
22072         enddo
22073
22074         xxtab(i)=xx
22075         yytab(i)=yy
22076         zztab(i)=zz
22077          it=itype(i,2)
22078         do j = 1,9
22079           x(j) = sc_parmin_nucl(j,it)
22080         enddo
22081 #ifdef CHECK_COORD
22082 !Cc diagnostics - remove later
22083         xx1 = dcos(alph(2))
22084         yy1 = dsin(alph(2))*dcos(omeg(2))
22085         zz1 = -dsin(alph(2))*dsin(omeg(2))
22086         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22087          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22088          xx1,yy1,zz1
22089 !C,"  --- ", xx_w,yy_w,zz_w
22090 !c end diagnostics
22091 #endif
22092         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22093         esbloc = esbloc + sumene
22094         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22095 !        print *,"enecomp",sumene,sumene2
22096 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22097 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22098 #ifdef DEBUG
22099         write (2,*) "x",(x(k),k=1,9)
22100 !C
22101 !C This section to check the numerical derivatives of the energy of ith side
22102 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22103 !C #define DEBUG in the code to turn it on.
22104 !C
22105         write (2,*) "sumene               =",sumene
22106         aincr=1.0d-7
22107         xxsave=xx
22108         xx=xx+aincr
22109         write (2,*) xx,yy,zz
22110         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22111         de_dxx_num=(sumenep-sumene)/aincr
22112         xx=xxsave
22113         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22114         yysave=yy
22115         yy=yy+aincr
22116         write (2,*) xx,yy,zz
22117         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22118         de_dyy_num=(sumenep-sumene)/aincr
22119         yy=yysave
22120         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22121         zzsave=zz
22122         zz=zz+aincr
22123         write (2,*) xx,yy,zz
22124         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22125         de_dzz_num=(sumenep-sumene)/aincr
22126         zz=zzsave
22127         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22128         costsave=cost2tab(i+1)
22129         sintsave=sint2tab(i+1)
22130         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22131         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22132         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22133         de_dt_num=(sumenep-sumene)/aincr
22134         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22135         cost2tab(i+1)=costsave
22136         sint2tab(i+1)=sintsave
22137 !C End of diagnostics section.
22138 #endif
22139 !C
22140 !C Compute the gradient of esc
22141 !C
22142         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22143         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22144         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22145         de_dtt=0.0d0
22146 #ifdef DEBUG
22147         write (2,*) "x",(x(k),k=1,9)
22148         write (2,*) "xx",xx," yy",yy," zz",zz
22149         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22150           " de_zz   ",de_zz," de_tt   ",de_tt
22151         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22152           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22153 #endif
22154 !C
22155        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22156        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22157        cosfac2xx=cosfac2*xx
22158        sinfac2yy=sinfac2*yy
22159        do k = 1,3
22160          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22161            vbld_inv(i+1)
22162          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22163            vbld_inv(i)
22164          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22165          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22166 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22167 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22168 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22169 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22170          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22171          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22172          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22173          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22174          dZZ_Ci1(k)=0.0d0
22175          dZZ_Ci(k)=0.0d0
22176          do j=1,3
22177            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22178            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22179          enddo
22180
22181          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22182          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22183          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22184 !c
22185          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22186          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22187        enddo
22188
22189        do k=1,3
22190          dXX_Ctab(k,i)=dXX_Ci(k)
22191          dXX_C1tab(k,i)=dXX_Ci1(k)
22192          dYY_Ctab(k,i)=dYY_Ci(k)
22193          dYY_C1tab(k,i)=dYY_Ci1(k)
22194          dZZ_Ctab(k,i)=dZZ_Ci(k)
22195          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22196          dXX_XYZtab(k,i)=dXX_XYZ(k)
22197          dYY_XYZtab(k,i)=dYY_XYZ(k)
22198          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22199        enddo
22200        do k = 1,3
22201 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22202 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22203 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22204 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22205 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22206 !c     &    dt_dci(k)
22207 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22208 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22209          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22210          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22211          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22212          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22213          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22214          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22215 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22216        enddo
22217 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22218 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22219
22220 !C to check gradient call subroutine check_grad
22221
22222     1 continue
22223       enddo
22224       return
22225       end subroutine esb
22226 !=-------------------------------------------------------
22227       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22228 !      implicit none
22229       real(kind=8),dimension(9):: x(9)
22230        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22231       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22232       integer i
22233 !c      write (2,*) "enesc"
22234 !c      write (2,*) "x",(x(i),i=1,9)
22235 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22236       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22237         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22238         + x(9)*yy*zz
22239       enesc_nucl=sumene
22240       return
22241       end function enesc_nucl
22242 !-----------------------------------------------------------------------------
22243       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22244 #ifdef MPI
22245       include 'mpif.h'
22246       integer,parameter :: max_cont=2000
22247       integer,parameter:: max_dim=2*(8*3+6)
22248       integer, parameter :: msglen1=max_cont*max_dim
22249       integer,parameter :: msglen2=2*msglen1
22250       integer source,CorrelType,CorrelID,Error
22251       real(kind=8) :: buffer(max_cont,max_dim)
22252       integer status(MPI_STATUS_SIZE)
22253       integer :: ierror,nbytes
22254 #endif
22255       real(kind=8),dimension(3):: gx(3),gx1(3)
22256       real(kind=8) :: time00
22257       logical lprn,ldone
22258       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22259       real(kind=8) ecorr,ecorr3
22260       integer :: n_corr,n_corr1,mm,msglen
22261 !C Set lprn=.true. for debugging
22262       lprn=.false.
22263       n_corr=0
22264       n_corr1=0
22265 #ifdef MPI
22266       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22267
22268       if (nfgtasks.le.1) goto 30
22269       if (lprn) then
22270         write (iout,'(a)') 'Contact function values:'
22271         do i=nnt,nct-1
22272           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22273          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22274          j=1,num_cont_hb(i))
22275         enddo
22276       endif
22277 !C Caution! Following code assumes that electrostatic interactions concerning
22278 !C a given atom are split among at most two processors!
22279       CorrelType=477
22280       CorrelID=fg_rank+1
22281       ldone=.false.
22282       do i=1,max_cont
22283         do j=1,max_dim
22284           buffer(i,j)=0.0D0
22285         enddo
22286       enddo
22287       mm=mod(fg_rank,2)
22288 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22289       if (mm) 20,20,10
22290    10 continue
22291 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22292       if (fg_rank.gt.0) then
22293 !C Send correlation contributions to the preceding processor
22294         msglen=msglen1
22295         nn=num_cont_hb(iatel_s_nucl)
22296         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22297 !c        write (*,*) 'The BUFFER array:'
22298 !c        do i=1,nn
22299 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22300 !c        enddo
22301         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22302           msglen=msglen2
22303           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22304 !C Clear the contacts of the atom passed to the neighboring processor
22305         nn=num_cont_hb(iatel_s_nucl+1)
22306 !c        do i=1,nn
22307 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22308 !c        enddo
22309             num_cont_hb(iatel_s_nucl)=0
22310         endif
22311 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22312 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22313 !cd   & ' msglen=',msglen
22314 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22315 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22316 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22317         time00=MPI_Wtime()
22318         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22319          CorrelType,FG_COMM,IERROR)
22320         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22321 !cd      write (iout,*) 'Processor ',fg_rank,
22322 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22323 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22324 !c        write (*,*) 'Processor ',fg_rank,
22325 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22326 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22327 !c        msglen=msglen1
22328       endif ! (fg_rank.gt.0)
22329       if (ldone) goto 30
22330       ldone=.true.
22331    20 continue
22332 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22333       if (fg_rank.lt.nfgtasks-1) then
22334 !C Receive correlation contributions from the next processor
22335         msglen=msglen1
22336         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22337 !cd      write (iout,*) 'Processor',fg_rank,
22338 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22339 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22340 !c        write (*,*) 'Processor',fg_rank,
22341 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22342 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22343         time00=MPI_Wtime()
22344         nbytes=-1
22345         do while (nbytes.le.0)
22346           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22347           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22348         enddo
22349 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22350         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22351          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22352         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22353 !c        write (*,*) 'Processor',fg_rank,
22354 !c     &' has received correlation contribution from processor',fg_rank+1,
22355 !c     & ' msglen=',msglen,' nbytes=',nbytes
22356 !c        write (*,*) 'The received BUFFER array:'
22357 !c        do i=1,max_cont
22358 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22359 !c        enddo
22360         if (msglen.eq.msglen1) then
22361           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22362         else if (msglen.eq.msglen2)  then
22363           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22364           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22365         else
22366           write (iout,*) &
22367       'ERROR!!!! message length changed while processing correlations.'
22368           write (*,*) &
22369       'ERROR!!!! message length changed while processing correlations.'
22370           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22371         endif ! msglen.eq.msglen1
22372       endif ! fg_rank.lt.nfgtasks-1
22373       if (ldone) goto 30
22374       ldone=.true.
22375       goto 10
22376    30 continue
22377 #endif
22378       if (lprn) then
22379         write (iout,'(a)') 'Contact function values:'
22380         do i=nnt_molec(2),nct_molec(2)-1
22381           write (iout,'(2i3,50(1x,i2,f5.2))') &
22382          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22383          j=1,num_cont_hb(i))
22384         enddo
22385       endif
22386       ecorr=0.0D0
22387       ecorr3=0.0d0
22388 !C Remove the loop below after debugging !!!
22389 !      do i=nnt_molec(2),nct_molec(2)
22390 !        do j=1,3
22391 !          gradcorr_nucl(j,i)=0.0D0
22392 !          gradxorr_nucl(j,i)=0.0D0
22393 !          gradcorr3_nucl(j,i)=0.0D0
22394 !          gradxorr3_nucl(j,i)=0.0D0
22395 !        enddo
22396 !      enddo
22397 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22398 !C Calculate the local-electrostatic correlation terms
22399       do i=iatsc_s_nucl,iatsc_e_nucl
22400         i1=i+1
22401         num_conti=num_cont_hb(i)
22402         num_conti1=num_cont_hb(i+1)
22403 !        print *,i,num_conti,num_conti1
22404         do jj=1,num_conti
22405           j=jcont_hb(jj,i)
22406           do kk=1,num_conti1
22407             j1=jcont_hb(kk,i1)
22408 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22409 !c     &         ' jj=',jj,' kk=',kk
22410             if (j1.eq.j+1 .or. j1.eq.j-1) then
22411 !C
22412 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22413 !C The system gains extra energy.
22414 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22415 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22416 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22417 !C
22418               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22419               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22420                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22421               n_corr=n_corr+1
22422             else if (j1.eq.j) then
22423 !C
22424 !C Contacts I-J and I-(J+1) occur simultaneously.
22425 !C The system loses extra energy.
22426 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22427 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22428 !C Need to implement full formulas 32 from Liwo et al., 1998.
22429 !C
22430 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22431 !c     &         ' jj=',jj,' kk=',kk
22432               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22433             endif
22434           enddo ! kk
22435           do kk=1,num_conti
22436             j1=jcont_hb(kk,i)
22437 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22438 !c     &         ' jj=',jj,' kk=',kk
22439             if (j1.eq.j+1) then
22440 !C Contacts I-J and (I+1)-J occur simultaneously.
22441 !C The system loses extra energy.
22442               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22443             endif ! j1==j+1
22444           enddo ! kk
22445         enddo ! jj
22446       enddo ! i
22447       return
22448       end subroutine multibody_hb_nucl
22449 !-----------------------------------------------------------
22450       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22451 !      implicit real*8 (a-h,o-z)
22452 !      include 'DIMENSIONS'
22453 !      include 'COMMON.IOUNITS'
22454 !      include 'COMMON.DERIV'
22455 !      include 'COMMON.INTERACT'
22456 !      include 'COMMON.CONTACTS'
22457       real(kind=8),dimension(3) :: gx,gx1
22458       logical :: lprn
22459 !el local variables
22460       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22461       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22462                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22463                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22464                    rlocshield
22465
22466       lprn=.false.
22467       eij=facont_hb(jj,i)
22468       ekl=facont_hb(kk,k)
22469       ees0pij=ees0p(jj,i)
22470       ees0pkl=ees0p(kk,k)
22471       ees0mij=ees0m(jj,i)
22472       ees0mkl=ees0m(kk,k)
22473       ekont=eij*ekl
22474       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22475 !      print *,"ehbcorr_nucl",ekont,ees
22476 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22477 !C Following 4 lines for diagnostics.
22478 !cd    ees0pkl=0.0D0
22479 !cd    ees0pij=1.0D0
22480 !cd    ees0mkl=0.0D0
22481 !cd    ees0mij=1.0D0
22482 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22483 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22484 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22485 !C Calculate the multi-body contribution to energy.
22486 !      ecorr_nucl=ecorr_nucl+ekont*ees
22487 !C Calculate multi-body contributions to the gradient.
22488       coeffpees0pij=coeffp*ees0pij
22489       coeffmees0mij=coeffm*ees0mij
22490       coeffpees0pkl=coeffp*ees0pkl
22491       coeffmees0mkl=coeffm*ees0mkl
22492       do ll=1,3
22493         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22494        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22495        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22496         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22497         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22498         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22499         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22500         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22501         coeffmees0mij*gacontm_hb1(ll,kk,k))
22502         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22503         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22504         coeffmees0mij*gacontm_hb2(ll,kk,k))
22505         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22506           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22507           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22508         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22509         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22510         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22511           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22512           coeffmees0mij*gacontm_hb3(ll,kk,k))
22513         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22514         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22515         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22516         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22517         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22518         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22519       enddo
22520       ehbcorr_nucl=ekont*ees
22521       return
22522       end function ehbcorr_nucl
22523 !-------------------------------------------------------------------------
22524
22525      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22526 !      implicit real*8 (a-h,o-z)
22527 !      include 'DIMENSIONS'
22528 !      include 'COMMON.IOUNITS'
22529 !      include 'COMMON.DERIV'
22530 !      include 'COMMON.INTERACT'
22531 !      include 'COMMON.CONTACTS'
22532       real(kind=8),dimension(3) :: gx,gx1
22533       logical :: lprn
22534 !el local variables
22535       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22536       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22537                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22538                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22539                    rlocshield
22540
22541       lprn=.false.
22542       eij=facont_hb(jj,i)
22543       ekl=facont_hb(kk,k)
22544       ees0pij=ees0p(jj,i)
22545       ees0pkl=ees0p(kk,k)
22546       ees0mij=ees0m(jj,i)
22547       ees0mkl=ees0m(kk,k)
22548       ekont=eij*ekl
22549       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22550 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22551 !C Following 4 lines for diagnostics.
22552 !cd    ees0pkl=0.0D0
22553 !cd    ees0pij=1.0D0
22554 !cd    ees0mkl=0.0D0
22555 !cd    ees0mij=1.0D0
22556 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22557 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22558 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22559 !C Calculate the multi-body contribution to energy.
22560 !      ecorr=ecorr+ekont*ees
22561 !C Calculate multi-body contributions to the gradient.
22562       coeffpees0pij=coeffp*ees0pij
22563       coeffmees0mij=coeffm*ees0mij
22564       coeffpees0pkl=coeffp*ees0pkl
22565       coeffmees0mkl=coeffm*ees0mkl
22566       do ll=1,3
22567         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22568        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22569        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22570         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22571         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22572         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22573         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22574         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22575         coeffmees0mij*gacontm_hb1(ll,kk,k))
22576         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22577         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22578         coeffmees0mij*gacontm_hb2(ll,kk,k))
22579         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22580           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22581           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22582         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22583         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22584         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22585           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22586           coeffmees0mij*gacontm_hb3(ll,kk,k))
22587         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22588         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22589         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22590         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22591         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22592         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22593       enddo
22594       ehbcorr3_nucl=ekont*ees
22595       return
22596       end function ehbcorr3_nucl
22597 #ifdef MPI
22598       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22599       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22600       real(kind=8):: buffer(dimen1,dimen2)
22601       num_kont=num_cont_hb(atom)
22602       do i=1,num_kont
22603         do k=1,8
22604           do j=1,3
22605             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22606           enddo ! j
22607         enddo ! k
22608         buffer(i,indx+25)=facont_hb(i,atom)
22609         buffer(i,indx+26)=ees0p(i,atom)
22610         buffer(i,indx+27)=ees0m(i,atom)
22611         buffer(i,indx+28)=d_cont(i,atom)
22612         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22613       enddo ! i
22614       buffer(1,indx+30)=dfloat(num_kont)
22615       return
22616       end subroutine pack_buffer
22617 !c------------------------------------------------------------------------------
22618       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22619       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22620       real(kind=8):: buffer(dimen1,dimen2)
22621 !      double precision zapas
22622 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22623 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22624 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22625 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22626       num_kont=buffer(1,indx+30)
22627       num_kont_old=num_cont_hb(atom)
22628       num_cont_hb(atom)=num_kont+num_kont_old
22629       do i=1,num_kont
22630         ii=i+num_kont_old
22631         do k=1,8
22632           do j=1,3
22633             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22634           enddo ! j
22635         enddo ! k
22636         facont_hb(ii,atom)=buffer(i,indx+25)
22637         ees0p(ii,atom)=buffer(i,indx+26)
22638         ees0m(ii,atom)=buffer(i,indx+27)
22639         d_cont(i,atom)=buffer(i,indx+28)
22640         jcont_hb(ii,atom)=buffer(i,indx+29)
22641       enddo ! i
22642       return
22643       end subroutine unpack_buffer
22644 !c------------------------------------------------------------------------------
22645 #endif
22646       subroutine ecatcat(ecationcation)
22647         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22648         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22649         r7,r4,ecationcation,k0,rcal
22650         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22651         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22652         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22653         gg,r
22654
22655         ecationcation=0.0d0
22656         if (nres_molec(5).eq.0) return
22657         rcat0=3.472
22658         epscalc=0.05
22659         r06 = rcat0**6
22660         r012 = r06**2
22661 !        k0 = 332.0*(2.0*2.0)/80.0
22662         itmp=0
22663
22664         do i=1,4
22665         itmp=itmp+nres_molec(i)
22666         enddo
22667 !        write(iout,*) "itmp",itmp
22668         do i=itmp+1,itmp+nres_molec(5)-1
22669
22670         xi=c(1,i)
22671         yi=c(2,i)
22672         zi=c(3,i)
22673           itypi=itype(i,5)
22674           xi=mod(xi,boxxsize)
22675           if (xi.lt.0) xi=xi+boxxsize
22676           yi=mod(yi,boxysize)
22677           if (yi.lt.0) yi=yi+boxysize
22678           zi=mod(zi,boxzsize)
22679           if (zi.lt.0) zi=zi+boxzsize
22680
22681           do j=i+1,itmp+nres_molec(5)
22682           itypj=itype(j,5)
22683           k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22684 !           print *,i,j,'catcat'
22685            xj=c(1,j)
22686            yj=c(2,j)
22687            zj=c(3,j)
22688           xj=dmod(xj,boxxsize)
22689           if (xj.lt.0) xj=xj+boxxsize
22690           yj=dmod(yj,boxysize)
22691           if (yj.lt.0) yj=yj+boxysize
22692           zj=dmod(zj,boxzsize)
22693           if (zj.lt.0) zj=zj+boxzsize
22694 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22695       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22696       xj_safe=xj
22697       yj_safe=yj
22698       zj_safe=zj
22699       subchap=0
22700       do xshift=-1,1
22701       do yshift=-1,1
22702       do zshift=-1,1
22703           xj=xj_safe+xshift*boxxsize
22704           yj=yj_safe+yshift*boxysize
22705           zj=zj_safe+zshift*boxzsize
22706           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22707           if(dist_temp.lt.dist_init) then
22708             dist_init=dist_temp
22709             xj_temp=xj
22710             yj_temp=yj
22711             zj_temp=zj
22712             subchap=1
22713           endif
22714        enddo
22715        enddo
22716        enddo
22717        if (subchap.eq.1) then
22718           xj=xj_temp-xi
22719           yj=yj_temp-yi
22720           zj=zj_temp-zi
22721        else
22722           xj=xj_safe-xi
22723           yj=yj_safe-yi
22724           zj=zj_safe-zi
22725        endif
22726        rcal =xj**2+yj**2+zj**2
22727         ract=sqrt(rcal)
22728 !        rcat0=3.472
22729 !        epscalc=0.05
22730 !        r06 = rcat0**6
22731 !        r012 = r06**2
22732 !        k0 = 332*(2*2)/80
22733         Evan1cat=epscalc*(r012/rcal**6)
22734         Evan2cat=epscalc*2*(r06/rcal**3)
22735         Eeleccat=k0/ract
22736         r7 = rcal**7
22737         r4 = rcal**4
22738         r(1)=xj
22739         r(2)=yj
22740         r(3)=zj
22741         do k=1,3
22742           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22743           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22744           dEeleccat(k)=-k0*r(k)/ract**3
22745         enddo
22746         do k=1,3
22747           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22748           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22749           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22750         enddo
22751
22752 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22753         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22754        enddo
22755        enddo
22756        return
22757        end subroutine ecatcat
22758 !---------------------------------------------------------------------------
22759 ! new for K+
22760       subroutine ecats_prot_amber(evdw)
22761 !      subroutine ecat_prot2(ecation_prot)
22762       use calc_data
22763       use comm_momo
22764
22765       logical :: lprn
22766 !el local variables
22767       integer :: iint,itypi1,subchap,isel,itmp
22768       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22769       real(kind=8) :: evdw
22770       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22771                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22772                     sslipi,sslipj,faclip,alpha_sco
22773       integer :: ii
22774       real(kind=8) :: fracinbuf
22775       real (kind=8) :: escpho
22776       real (kind=8),dimension(4):: ener
22777       real(kind=8) :: b1,b2,egb
22778       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22779        Lambf,&
22780        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22781        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22782        federmaus,&
22783        d1i,d1j
22784 !       real(kind=8),dimension(3,2)::erhead_tail
22785 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22786       real(kind=8) ::  facd4, adler, Fgb, facd3
22787       integer troll,jj,istate
22788       real (kind=8) :: dcosom1(3),dcosom2(3)
22789
22790       ecations_prot_amber=0.0D0
22791       if (nres_molec(5).eq.0) return
22792       eps_out=80.0d0
22793 !      sss_ele_cut=1.0d0
22794
22795         itmp=0
22796         do i=1,4
22797         itmp=itmp+nres_molec(i)
22798         enddo
22799 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22800         do i=ibond_start,ibond_end
22801
22802 !        print *,"I am in EVDW",i
22803         itypi=iabs(itype(i,1))
22804 !        if (i.ne.47) cycle
22805         if (itypi.eq.ntyp1) cycle
22806         itypi1=iabs(itype(i+1,1))
22807         xi=c(1,nres+i)
22808         yi=c(2,nres+i)
22809         zi=c(3,nres+i)
22810           xi=dmod(xi,boxxsize)
22811           if (xi.lt.0) xi=xi+boxxsize
22812           yi=dmod(yi,boxysize)
22813           if (yi.lt.0) yi=yi+boxysize
22814           zi=dmod(zi,boxzsize)
22815           if (zi.lt.0) zi=zi+boxzsize
22816         dxi=dc_norm(1,nres+i)
22817         dyi=dc_norm(2,nres+i)
22818         dzi=dc_norm(3,nres+i)
22819         dsci_inv=vbld_inv(i+nres)
22820          do j=itmp+1,itmp+nres_molec(5)
22821
22822 ! Calculate SC interaction energy.
22823             itypj=iabs(itype(j,5))
22824             if ((itypj.eq.ntyp1)) cycle
22825              CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22826
22827             dscj_inv=0.0
22828            xj=c(1,j)
22829            yj=c(2,j)
22830            zj=c(3,j)
22831            xj=dmod(xj,boxxsize)
22832            if (xj.lt.0) xj=xj+boxxsize
22833            yj=dmod(yj,boxysize)
22834            if (yj.lt.0) yj=yj+boxysize
22835            zj=dmod(zj,boxzsize)
22836            if (zj.lt.0) zj=zj+boxzsize
22837           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22838           xj_safe=xj
22839           yj_safe=yj
22840           zj_safe=zj
22841           subchap=0
22842
22843           do xshift=-1,1
22844           do yshift=-1,1
22845           do zshift=-1,1
22846           xj=xj_safe+xshift*boxxsize
22847           yj=yj_safe+yshift*boxysize
22848           zj=zj_safe+zshift*boxzsize
22849           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22850           if(dist_temp.lt.dist_init) then
22851             dist_init=dist_temp
22852             xj_temp=xj
22853             yj_temp=yj
22854             zj_temp=zj
22855             subchap=1
22856           endif
22857           enddo
22858           enddo
22859           enddo
22860           if (subchap.eq.1) then
22861           xj=xj_temp-xi
22862           yj=yj_temp-yi
22863           zj=zj_temp-zi
22864           else
22865           xj=xj_safe-xi
22866           yj=yj_safe-yi
22867           zj=zj_safe-zi
22868           endif
22869
22870 !          dxj = dc_norm( 1, nres+j )
22871 !          dyj = dc_norm( 2, nres+j )
22872 !          dzj = dc_norm( 3, nres+j )
22873
22874           itypi = itype(i,1)
22875           itypj = itype(j,5)
22876 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22877 ! sampling performed with amber package
22878 !          alf1   = 0.0d0
22879 !          alf2   = 0.0d0
22880 !          alf12  = 0.0d0
22881 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22882           chi1 = chicat(itypi,itypj)
22883           chis1 = chiscat(itypi,itypj)
22884           chip1 = chippcat(itypi,itypj)
22885 !          chi1=0.0d0
22886 !          chis1=0.0d0
22887 !          chip1=0.0d0
22888           chi2=0.0
22889           chip2=0.0
22890           chis2=0.0
22891 !          chis2 = chis(itypj,itypi)
22892           chis12 = chis1 * chis2
22893           sig1 = sigmap1cat(itypi,itypj)
22894 !          sig2 = sigmap2(itypi,itypj)
22895 ! alpha factors from Fcav/Gcav
22896           b1cav = alphasurcat(1,itypi,itypj)
22897           b2cav = alphasurcat(2,itypi,itypj)
22898           b3cav = alphasurcat(3,itypi,itypj)
22899           b4cav = alphasurcat(4,itypi,itypj)
22900
22901 ! used to determine whether we want to do quadrupole calculations
22902        eps_in = epsintabcat(itypi,itypj)
22903        if (eps_in.eq.0.0) eps_in=1.0
22904
22905        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22906 !       Rtail = 0.0d0
22907
22908        DO k = 1, 3
22909         ctail(k,1)=c(k,i+nres)
22910         ctail(k,2)=c(k,j)
22911        END DO
22912 !c! tail distances will be themselves usefull elswhere
22913 !c1 (in Gcav, for example)
22914        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22915        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22916        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22917        Rtail = dsqrt( &
22918           (Rtail_distance(1)*Rtail_distance(1)) &
22919         + (Rtail_distance(2)*Rtail_distance(2)) &
22920         + (Rtail_distance(3)*Rtail_distance(3)))
22921 ! tail location and distance calculations
22922 ! dhead1
22923        d1 = dheadcat(1, 1, itypi, itypj)
22924 !       d2 = dhead(2, 1, itypi, itypj)
22925        DO k = 1,3
22926 ! location of polar head is computed by taking hydrophobic centre
22927 ! and moving by a d1 * dc_norm vector
22928 ! see unres publications for very informative images
22929         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22930         chead(k,2) = c(k, j)
22931 ! distance
22932 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22933 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22934         Rhead_distance(k) = chead(k,2) - chead(k,1)
22935        END DO
22936 ! pitagoras (root of sum of squares)
22937        Rhead = dsqrt( &
22938           (Rhead_distance(1)*Rhead_distance(1)) &
22939         + (Rhead_distance(2)*Rhead_distance(2)) &
22940         + (Rhead_distance(3)*Rhead_distance(3)))
22941 !-------------------------------------------------------------------
22942 ! zero everything that should be zero'ed
22943        evdwij = 0.0d0
22944        ECL = 0.0d0
22945        Elj = 0.0d0
22946        Equad = 0.0d0
22947        Epol = 0.0d0
22948        Fcav=0.0d0
22949        eheadtail = 0.0d0
22950        dGCLdOM1 = 0.0d0
22951        dGCLdOM2 = 0.0d0
22952        dGCLdOM12 = 0.0d0
22953        dPOLdOM1 = 0.0d0
22954        dPOLdOM2 = 0.0d0
22955           Fcav = 0.0d0
22956           dFdR = 0.0d0
22957           dCAVdOM1  = 0.0d0
22958           dCAVdOM2  = 0.0d0
22959           dCAVdOM12 = 0.0d0
22960           dscj_inv = vbld_inv(j+nres)
22961 !          print *,i,j,dscj_inv,dsci_inv
22962 ! rij holds 1/(distance of Calpha atoms)
22963           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22964           rij  = dsqrt(rrij)
22965           CALL sc_angular
22966 ! this should be in elgrad_init but om's are calculated by sc_angular
22967 ! which in turn is used by older potentials
22968 ! om = omega, sqom = om^2
22969           sqom1  = om1 * om1
22970           sqom2  = om2 * om2
22971           sqom12 = om12 * om12
22972
22973 ! now we calculate EGB - Gey-Berne
22974 ! It will be summed up in evdwij and saved in evdw
22975           sigsq     = 1.0D0  / sigsq
22976           sig       = sig0ij * dsqrt(sigsq)
22977 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22978           rij_shift = Rtail - sig + sig0ij
22979           IF (rij_shift.le.0.0D0) THEN
22980            evdw = 1.0D20
22981            RETURN
22982           END IF
22983           sigder = -sig * sigsq
22984           rij_shift = 1.0D0 / rij_shift
22985           fac       = rij_shift**expon
22986           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22987 !          print *,"ADAM",aa_aq(itypi,itypj)
22988
22989 !          c1        = 0.0d0
22990           c2        = fac  * bb_aq_cat(itypi,itypj)
22991 !          c2        = 0.0d0
22992           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22993           eps2der   = eps3rt * evdwij
22994           eps3der   = eps2rt * evdwij
22995 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22996           evdwij    = eps2rt * eps3rt * evdwij
22997 !#ifdef TSCSC
22998 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22999 !           evdw_p = evdw_p + evdwij
23000 !          ELSE
23001 !           evdw_m = evdw_m + evdwij
23002 !          END IF
23003 !#else
23004           evdw = evdw  &
23005               + evdwij
23006 !#endif
23007           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23008           fac    = -expon * (c1 + evdwij) * rij_shift
23009           sigder = fac * sigder
23010 ! Calculate distance derivative
23011           gg(1) =  fac
23012           gg(2) =  fac
23013           gg(3) =  fac
23014
23015           fac = chis1 * sqom1 + chis2 * sqom2 &
23016           - 2.0d0 * chis12 * om1 * om2 * om12
23017           pom = 1.0d0 - chis1 * chis2 * sqom12
23018           Lambf = (1.0d0 - (fac / pom))
23019           Lambf = dsqrt(Lambf)
23020           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23021           Chif = Rtail * sparrow
23022           ChiLambf = Chif * Lambf
23023           eagle = dsqrt(ChiLambf)
23024           bat = ChiLambf ** 11.0d0
23025           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23026           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23027           botsq = bot * bot
23028           Fcav = top / bot
23029
23030        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23031        dbot = 12.0d0 * b4cav * bat * Lambf
23032        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23033
23034           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23035           dbot = 12.0d0 * b4cav * bat * Chif
23036           eagle = Lambf * pom
23037           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23038           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23039           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23040               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23041
23042           dFdL = ((dtop * bot - top * dbot) / botsq)
23043           dCAVdOM1  = dFdL * ( dFdOM1 )
23044           dCAVdOM2  = dFdL * ( dFdOM2 )
23045           dCAVdOM12 = dFdL * ( dFdOM12 )
23046
23047        DO k= 1, 3
23048         ertail(k) = Rtail_distance(k)/Rtail
23049        END DO
23050        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23051        erdxj = scalar( ertail(1), dC_norm(1,j) )
23052        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23053        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23054        DO k = 1, 3
23055         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23056         gradpepcatx(k,i) = gradpepcatx(k,i) &
23057                   - (( dFdR + gg(k) ) * pom)
23058         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23059 !        gvdwx(k,j) = gvdwx(k,j)   &
23060 !                  + (( dFdR + gg(k) ) * pom)
23061         gradpepcat(k,i) = gradpepcat(k,i)  &
23062                   - (( dFdR + gg(k) ) * ertail(k))
23063         gradpepcat(k,j) = gradpepcat(k,j) &
23064                   + (( dFdR + gg(k) ) * ertail(k))
23065         gg(k) = 0.0d0
23066        ENDDO
23067 !c! Compute head-head and head-tail energies for each state
23068           isel = iabs(Qi) + iabs(Qj)
23069           IF (isel.eq.0) THEN
23070 !c! No charges - do nothing
23071            eheadtail = 0.0d0
23072
23073           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
23074 !c! Nonpolar-charge interactions
23075           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23076             Qi=Qi*2
23077             Qij=Qij*2
23078            endif
23079           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23080             Qj=Qj*2
23081             Qij=Qij*2
23082            endif
23083
23084            CALL enq_cat(epol)
23085            eheadtail = epol
23086 !           eheadtail = 0.0d0
23087
23088           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
23089 !c! Dipole-charge interactions
23090           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23091             Qi=Qi*2
23092             Qij=Qij*2
23093            endif
23094           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23095             Qj=Qj*2
23096             Qij=Qij*2
23097            endif
23098            CALL edq_cat(ecl, elj, epol)
23099           eheadtail = ECL + elj + epol
23100 !           eheadtail = 0.0d0
23101
23102           ELSE IF ((isel.eq.2.and.   &
23103                iabs(Qi).eq.1).and.  &
23104                nstatecat(itypi,itypj).eq.1) THEN
23105
23106 !c! Same charge-charge interaction ( +/+ or -/- )
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
23116            CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23117            eheadtail = ECL + Egb + Epol + Fisocav + Elj
23118 !           eheadtail = 0.0d0
23119
23120 !          ELSE IF ((isel.eq.2.and.  &
23121 !               iabs(Qi).eq.1).and. &
23122 !               nstate(itypi,itypj).ne.1) THEN
23123 !c! Different 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 energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23134        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23135         evdw = evdw  + Fcav + eheadtail
23136
23137        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23138         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23139         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23140         Equad,evdwij+Fcav+eheadtail,evdw
23141 !       evdw = evdw  + Fcav  + eheadtail
23142
23143 !        iF (nstate(itypi,itypj).eq.1) THEN
23144         CALL sc_grad_cat
23145 !       END IF
23146 !c!-------------------------------------------------------------------
23147 !c! NAPISY KONCOWE
23148          END DO   ! j
23149        END DO     ! i
23150 !c      write (iout,*) "Number of loop steps in EGB:",ind
23151 !c      energy_dec=.false.
23152 !              print *,"EVDW KURW",evdw,nres
23153
23154       return
23155       end subroutine ecats_prot_amber
23156
23157 !---------------------------------------------------------------------------
23158 ! old for Ca2+
23159        subroutine ecat_prot(ecation_prot)
23160 !      use calc_data
23161 !      use comm_momo
23162        integer i,j,k,subchap,itmp,inum
23163         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23164         r7,r4,ecationcation
23165         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23166         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23167         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23168         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23169         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23170         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23171         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23172         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23173         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23174         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23175         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23176         ndiv,ndivi
23177         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23178         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23179         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23180         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23181         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23182         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23183         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23184         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23185         dEvan1Cat
23186         real(kind=8),dimension(6) :: vcatprm
23187         ecation_prot=0.0d0
23188 ! first lets calculate interaction with peptide groups
23189         if (nres_molec(5).eq.0) return
23190         itmp=0
23191         do i=1,4
23192         itmp=itmp+nres_molec(i)
23193         enddo
23194 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23195         do i=ibond_start,ibond_end
23196 !         cycle
23197          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23198         xi=0.5d0*(c(1,i)+c(1,i+1))
23199         yi=0.5d0*(c(2,i)+c(2,i+1))
23200         zi=0.5d0*(c(3,i)+c(3,i+1))
23201           xi=mod(xi,boxxsize)
23202           if (xi.lt.0) xi=xi+boxxsize
23203           yi=mod(yi,boxysize)
23204           if (yi.lt.0) yi=yi+boxysize
23205           zi=mod(zi,boxzsize)
23206           if (zi.lt.0) zi=zi+boxzsize
23207
23208          do j=itmp+1,itmp+nres_molec(5)
23209 !           print *,"WTF",itmp,j,i
23210 ! all parameters were for Ca2+ to approximate single charge divide by two
23211          ndiv=1.0
23212          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23213          wconst=78*ndiv
23214         wdip =1.092777950857032D2
23215         wdip=wdip/wconst
23216         wmodquad=-2.174122713004870D4
23217         wmodquad=wmodquad/wconst
23218         wquad1 = 3.901232068562804D1
23219         wquad1=wquad1/wconst
23220         wquad2 = 3
23221         wquad2=wquad2/wconst
23222         wvan1 = 0.1
23223         wvan2 = 6
23224 !        itmp=0
23225
23226            xj=c(1,j)
23227            yj=c(2,j)
23228            zj=c(3,j)
23229           xj=dmod(xj,boxxsize)
23230           if (xj.lt.0) xj=xj+boxxsize
23231           yj=dmod(yj,boxysize)
23232           if (yj.lt.0) yj=yj+boxysize
23233           zj=dmod(zj,boxzsize)
23234           if (zj.lt.0) zj=zj+boxzsize
23235       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23236       xj_safe=xj
23237       yj_safe=yj
23238       zj_safe=zj
23239       subchap=0
23240       do xshift=-1,1
23241       do yshift=-1,1
23242       do zshift=-1,1
23243           xj=xj_safe+xshift*boxxsize
23244           yj=yj_safe+yshift*boxysize
23245           zj=zj_safe+zshift*boxzsize
23246           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23247           if(dist_temp.lt.dist_init) then
23248             dist_init=dist_temp
23249             xj_temp=xj
23250             yj_temp=yj
23251             zj_temp=zj
23252             subchap=1
23253           endif
23254        enddo
23255        enddo
23256        enddo
23257        if (subchap.eq.1) then
23258           xj=xj_temp-xi
23259           yj=yj_temp-yi
23260           zj=zj_temp-zi
23261        else
23262           xj=xj_safe-xi
23263           yj=yj_safe-yi
23264           zj=zj_safe-zi
23265        endif
23266 !       enddo
23267 !       enddo
23268        rcpm = sqrt(xj**2+yj**2+zj**2)
23269        drcp_norm(1)=xj/rcpm
23270        drcp_norm(2)=yj/rcpm
23271        drcp_norm(3)=zj/rcpm
23272        dcmag=0.0
23273        do k=1,3
23274        dcmag=dcmag+dc(k,i)**2
23275        enddo
23276        dcmag=dsqrt(dcmag)
23277        do k=1,3
23278          myd_norm(k)=dc(k,i)/dcmag
23279        enddo
23280         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23281         drcp_norm(3)*myd_norm(3)
23282         rsecp = rcpm**2
23283         Ir = 1.0d0/rcpm
23284         Irsecp = 1.0d0/rsecp
23285         Irthrp = Irsecp/rcpm
23286         Irfourp = Irthrp/rcpm
23287         Irfiftp = Irfourp/rcpm
23288         Irsistp=Irfiftp/rcpm
23289         Irseven=Irsistp/rcpm
23290         Irtwelv=Irsistp*Irsistp
23291         Irthir=Irtwelv/rcpm
23292         sin2thet = (1-costhet*costhet)
23293         sinthet=sqrt(sin2thet)
23294         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23295              *sin2thet
23296         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23297              2*wvan2**6*Irsistp)
23298         ecation_prot = ecation_prot+E1+E2
23299 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23300         dE1dr = -2*costhet*wdip*Irthrp-&
23301          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23302         dE2dr = 3*wquad1*wquad2*Irfourp-     &
23303           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23304         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23305         do k=1,3
23306           drdpep(k) = -drcp_norm(k)
23307           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23308           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23309           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23310           dEddci(k) = dEdcos*dcosddci(k)
23311         enddo
23312         do k=1,3
23313         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23314         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23315         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23316         enddo
23317        enddo ! j
23318        enddo ! i
23319 !------------------------------------------sidechains
23320 !        do i=1,nres_molec(1)
23321         do i=ibond_start,ibond_end
23322          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23323 !         cycle
23324 !        print *,i,ecation_prot
23325         xi=(c(1,i+nres))
23326         yi=(c(2,i+nres))
23327         zi=(c(3,i+nres))
23328           xi=mod(xi,boxxsize)
23329           if (xi.lt.0) xi=xi+boxxsize
23330           yi=mod(yi,boxysize)
23331           if (yi.lt.0) yi=yi+boxysize
23332           zi=mod(zi,boxzsize)
23333           if (zi.lt.0) zi=zi+boxzsize
23334           do k=1,3
23335             cm1(k)=dc(k,i+nres)
23336           enddo
23337            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23338          do j=itmp+1,itmp+nres_molec(5)
23339          ndiv=1.0
23340          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23341
23342            xj=c(1,j)
23343            yj=c(2,j)
23344            zj=c(3,j)
23345           xj=dmod(xj,boxxsize)
23346           if (xj.lt.0) xj=xj+boxxsize
23347           yj=dmod(yj,boxysize)
23348           if (yj.lt.0) yj=yj+boxysize
23349           zj=dmod(zj,boxzsize)
23350           if (zj.lt.0) zj=zj+boxzsize
23351       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23352       xj_safe=xj
23353       yj_safe=yj
23354       zj_safe=zj
23355       subchap=0
23356       do xshift=-1,1
23357       do yshift=-1,1
23358       do zshift=-1,1
23359           xj=xj_safe+xshift*boxxsize
23360           yj=yj_safe+yshift*boxysize
23361           zj=zj_safe+zshift*boxzsize
23362           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23363           if(dist_temp.lt.dist_init) then
23364             dist_init=dist_temp
23365             xj_temp=xj
23366             yj_temp=yj
23367             zj_temp=zj
23368             subchap=1
23369           endif
23370        enddo
23371        enddo
23372        enddo
23373        if (subchap.eq.1) then
23374           xj=xj_temp-xi
23375           yj=yj_temp-yi
23376           zj=zj_temp-zi
23377        else
23378           xj=xj_safe-xi
23379           yj=yj_safe-yi
23380           zj=zj_safe-zi
23381        endif
23382 !       enddo
23383 !       enddo
23384 ! 15- Glu 16-Asp
23385          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23386          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23387          (itype(i,1).eq.25))) then
23388             if(itype(i,1).eq.16) then
23389             inum=1
23390             else
23391             inum=2
23392             endif
23393             do k=1,6
23394             vcatprm(k)=catprm(k,inum)
23395             enddo
23396             dASGL=catprm(7,inum)
23397 !             do k=1,3
23398 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23399                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23400                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23401                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23402
23403 !                valpha(k)=c(k,i)
23404 !                vcat(k)=c(k,j)
23405                 if (subchap.eq.1) then
23406                  vcat(1)=xj_temp
23407                  vcat(2)=yj_temp
23408                  vcat(3)=zj_temp
23409                  else
23410                 vcat(1)=xj_safe
23411                 vcat(2)=yj_safe
23412                 vcat(3)=zj_safe
23413                  endif
23414                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23415                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23416                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23417
23418 !              enddo
23419         do k=1,3
23420           dx(k) = vcat(k)-vcm(k)
23421         enddo
23422         do k=1,3
23423           v1(k)=(vcm(k)-valpha(k))
23424           v2(k)=(vcat(k)-valpha(k))
23425         enddo
23426         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23427         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23428         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23429
23430 !  The weights of the energy function calculated from
23431 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23432           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23433             ndivi=0.5
23434           else
23435             ndivi=1.0
23436           endif
23437          ndiv=1.0
23438          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23439
23440         wh2o=78*ndivi*ndiv
23441         wc = vcatprm(1)
23442         wc=wc/wh2o
23443         wdip =vcatprm(2)
23444         wdip=wdip/wh2o
23445         wquad1 =vcatprm(3)
23446         wquad1=wquad1/wh2o
23447         wquad2 = vcatprm(4)
23448         wquad2=wquad2/wh2o
23449         wquad2p = 1.0d0-wquad2
23450         wvan1 = vcatprm(5)
23451         wvan2 =vcatprm(6)
23452         opt = dx(1)**2+dx(2)**2
23453         rsecp = opt+dx(3)**2
23454         rs = sqrt(rsecp)
23455         rthrp = rsecp*rs
23456         rfourp = rthrp*rs
23457         rsixp = rfourp*rsecp
23458         reight=rsixp*rsecp
23459         Ir = 1.0d0/rs
23460         Irsecp = 1.0d0/rsecp
23461         Irthrp = Irsecp/rs
23462         Irfourp = Irthrp/rs
23463         Irsixp = 1.0d0/rsixp
23464         Ireight=1.0d0/reight
23465         Irtw=Irsixp*Irsixp
23466         Irthir=Irtw/rs
23467         Irfourt=Irthir/rs
23468         opt1 = (4*rs*dx(3)*wdip)
23469         opt2 = 6*rsecp*wquad1*opt
23470         opt3 = wquad1*wquad2p*Irsixp
23471         opt4 = (wvan1*wvan2**12)
23472         opt5 = opt4*12*Irfourt
23473         opt6 = 2*wvan1*wvan2**6
23474         opt7 = 6*opt6*Ireight
23475         opt8 = wdip/v1m
23476         opt10 = wdip/v2m
23477         opt11 = (rsecp*v2m)**2
23478         opt12 = (rsecp*v1m)**2
23479         opt14 = (v1m*v2m*rsecp)**2
23480         opt15 = -wquad1/v2m**2
23481         opt16 = (rthrp*(v1m*v2m)**2)**2
23482         opt17 = (v1m**2*rthrp)**2
23483         opt18 = -wquad1/rthrp
23484         opt19 = (v1m**2*v2m**2)**2
23485         Ec = wc*Ir
23486         do k=1,3
23487           dEcCat(k) = -(dx(k)*wc)*Irthrp
23488           dEcCm(k)=(dx(k)*wc)*Irthrp
23489           dEcCalp(k)=0.0d0
23490         enddo
23491         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23492         do k=1,3
23493           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23494                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23495           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23496                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23497           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23498                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23499                       *v1dpv2)/opt14
23500         enddo
23501         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23502         do k=1,3
23503           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23504                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23505                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23506           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23507                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23508                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23509           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23510                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23511                         v1dpv2**2)/opt19
23512         enddo
23513         Equad2=wquad1*wquad2p*Irthrp
23514         do k=1,3
23515           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23516           dEquad2Cm(k)=3*dx(k)*rs*opt3
23517           dEquad2Calp(k)=0.0d0
23518         enddo
23519         Evan1=opt4*Irtw
23520         do k=1,3
23521           dEvan1Cat(k)=-dx(k)*opt5
23522           dEvan1Cm(k)=dx(k)*opt5
23523           dEvan1Calp(k)=0.0d0
23524         enddo
23525         Evan2=-opt6*Irsixp
23526         do k=1,3
23527           dEvan2Cat(k)=dx(k)*opt7
23528           dEvan2Cm(k)=-dx(k)*opt7
23529           dEvan2Calp(k)=0.0d0
23530         enddo
23531         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23532 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23533
23534         do k=1,3
23535           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23536                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23537 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23538           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23539                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23540           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23541                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23542         enddo
23543             dscmag = 0.0d0
23544             do k=1,3
23545               dscvec(k) = dc(k,i+nres)
23546               dscmag = dscmag+dscvec(k)*dscvec(k)
23547             enddo
23548             dscmag3 = dscmag
23549             dscmag = sqrt(dscmag)
23550             dscmag3 = dscmag3*dscmag
23551             constA = 1.0d0+dASGL/dscmag
23552             constB = 0.0d0
23553             do k=1,3
23554               constB = constB+dscvec(k)*dEtotalCm(k)
23555             enddo
23556             constB = constB*dASGL/dscmag3
23557             do k=1,3
23558               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23559               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23560                constA*dEtotalCm(k)-constB*dscvec(k)
23561 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23562               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23563               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23564              enddo
23565         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23566            if(itype(i,1).eq.14) then
23567             inum=3
23568             else
23569             inum=4
23570             endif
23571             do k=1,6
23572             vcatprm(k)=catprm(k,inum)
23573             enddo
23574             dASGL=catprm(7,inum)
23575 !             do k=1,3
23576 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23577 !                valpha(k)=c(k,i)
23578 !                vcat(k)=c(k,j)
23579 !              enddo
23580                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23581                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23582                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23583                 if (subchap.eq.1) then
23584                  vcat(1)=xj_temp
23585                  vcat(2)=yj_temp
23586                  vcat(3)=zj_temp
23587                  else
23588                 vcat(1)=xj_safe
23589                 vcat(2)=yj_safe
23590                 vcat(3)=zj_safe
23591                 endif
23592                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23593                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23594                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23595
23596
23597         do k=1,3
23598           dx(k) = vcat(k)-vcm(k)
23599         enddo
23600         do k=1,3
23601           v1(k)=(vcm(k)-valpha(k))
23602           v2(k)=(vcat(k)-valpha(k))
23603         enddo
23604         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23605         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23606         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23607 !  The weights of the energy function calculated from
23608 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23609          ndiv=1.0
23610          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23611
23612         wh2o=78*ndiv
23613         wdip =vcatprm(2)
23614         wdip=wdip/wh2o
23615         wquad1 =vcatprm(3)
23616         wquad1=wquad1/wh2o
23617         wquad2 = vcatprm(4)
23618         wquad2=wquad2/wh2o
23619         wquad2p = 1-wquad2
23620         wvan1 = vcatprm(5)
23621         wvan2 =vcatprm(6)
23622         opt = dx(1)**2+dx(2)**2
23623         rsecp = opt+dx(3)**2
23624         rs = sqrt(rsecp)
23625         rthrp = rsecp*rs
23626         rfourp = rthrp*rs
23627         rsixp = rfourp*rsecp
23628         reight=rsixp*rsecp
23629         Ir = 1.0d0/rs
23630         Irsecp = 1/rsecp
23631         Irthrp = Irsecp/rs
23632         Irfourp = Irthrp/rs
23633         Irsixp = 1/rsixp
23634         Ireight=1/reight
23635         Irtw=Irsixp*Irsixp
23636         Irthir=Irtw/rs
23637         Irfourt=Irthir/rs
23638         opt1 = (4*rs*dx(3)*wdip)
23639         opt2 = 6*rsecp*wquad1*opt
23640         opt3 = wquad1*wquad2p*Irsixp
23641         opt4 = (wvan1*wvan2**12)
23642         opt5 = opt4*12*Irfourt
23643         opt6 = 2*wvan1*wvan2**6
23644         opt7 = 6*opt6*Ireight
23645         opt8 = wdip/v1m
23646         opt10 = wdip/v2m
23647         opt11 = (rsecp*v2m)**2
23648         opt12 = (rsecp*v1m)**2
23649         opt14 = (v1m*v2m*rsecp)**2
23650         opt15 = -wquad1/v2m**2
23651         opt16 = (rthrp*(v1m*v2m)**2)**2
23652         opt17 = (v1m**2*rthrp)**2
23653         opt18 = -wquad1/rthrp
23654         opt19 = (v1m**2*v2m**2)**2
23655         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23656         do k=1,3
23657           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23658                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23659          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23660                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23661           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23662                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23663                       *v1dpv2)/opt14
23664         enddo
23665         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23666         do k=1,3
23667           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23668                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23669                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23670           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23671                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23672                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23673           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23674                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23675                         v1dpv2**2)/opt19
23676         enddo
23677         Equad2=wquad1*wquad2p*Irthrp
23678         do k=1,3
23679           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23680           dEquad2Cm(k)=3*dx(k)*rs*opt3
23681           dEquad2Calp(k)=0.0d0
23682         enddo
23683         Evan1=opt4*Irtw
23684         do k=1,3
23685           dEvan1Cat(k)=-dx(k)*opt5
23686           dEvan1Cm(k)=dx(k)*opt5
23687           dEvan1Calp(k)=0.0d0
23688         enddo
23689         Evan2=-opt6*Irsixp
23690         do k=1,3
23691           dEvan2Cat(k)=dx(k)*opt7
23692           dEvan2Cm(k)=-dx(k)*opt7
23693           dEvan2Calp(k)=0.0d0
23694         enddo
23695          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23696         do k=1,3
23697           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23698                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23699           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23700                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23701           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23702                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23703         enddo
23704             dscmag = 0.0d0
23705             do k=1,3
23706               dscvec(k) = c(k,i+nres)-c(k,i)
23707 ! TU SPRAWDZ???
23708 !              dscvec(1) = xj
23709 !              dscvec(2) = yj
23710 !              dscvec(3) = zj
23711
23712               dscmag = dscmag+dscvec(k)*dscvec(k)
23713             enddo
23714             dscmag3 = dscmag
23715             dscmag = sqrt(dscmag)
23716             dscmag3 = dscmag3*dscmag
23717             constA = 1+dASGL/dscmag
23718             constB = 0.0d0
23719             do k=1,3
23720               constB = constB+dscvec(k)*dEtotalCm(k)
23721             enddo
23722             constB = constB*dASGL/dscmag3
23723             do k=1,3
23724               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23725               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23726                constA*dEtotalCm(k)-constB*dscvec(k)
23727               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23728               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23729              enddo
23730            else
23731             rcal = 0.0d0
23732             do k=1,3
23733 !              r(k) = c(k,j)-c(k,i+nres)
23734               r(1) = xj
23735               r(2) = yj
23736               r(3) = zj
23737               rcal = rcal+r(k)*r(k)
23738             enddo
23739             ract=sqrt(rcal)
23740             rocal=1.5
23741             epscalc=0.2
23742             r0p=0.5*(rocal+sig0(itype(i,1)))
23743             r06 = r0p**6
23744             r012 = r06*r06
23745             Evan1=epscalc*(r012/rcal**6)
23746             Evan2=epscalc*2*(r06/rcal**3)
23747             r4 = rcal**4
23748             r7 = rcal**7
23749             do k=1,3
23750               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23751               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23752             enddo
23753             do k=1,3
23754               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23755             enddo
23756                  ecation_prot = ecation_prot+ Evan1+Evan2
23757             do  k=1,3
23758                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23759                dEtotalCm(k)
23760               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23761               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23762              enddo
23763          endif ! 13-16 residues
23764        enddo !j
23765        enddo !i
23766        return
23767        end subroutine ecat_prot
23768
23769 !----------------------------------------------------------------------------
23770 !-----------------------------------------------------------------------------
23771 !-----------------------------------------------------------------------------
23772       subroutine eprot_sc_base(escbase)
23773       use calc_data
23774 !      implicit real*8 (a-h,o-z)
23775 !      include 'DIMENSIONS'
23776 !      include 'COMMON.GEO'
23777 !      include 'COMMON.VAR'
23778 !      include 'COMMON.LOCAL'
23779 !      include 'COMMON.CHAIN'
23780 !      include 'COMMON.DERIV'
23781 !      include 'COMMON.NAMES'
23782 !      include 'COMMON.INTERACT'
23783 !      include 'COMMON.IOUNITS'
23784 !      include 'COMMON.CALC'
23785 !      include 'COMMON.CONTROL'
23786 !      include 'COMMON.SBRIDGE'
23787       logical :: lprn
23788 !el local variables
23789       integer :: iint,itypi,itypi1,itypj,subchap
23790       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23791       real(kind=8) :: evdw,sig0ij
23792       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23793                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23794                     sslipi,sslipj,faclip
23795       integer :: ii
23796       real(kind=8) :: fracinbuf
23797        real (kind=8) :: escbase
23798        real (kind=8),dimension(4):: ener
23799        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23800        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23801         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23802         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23803         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23804         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23805         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23806         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23807        real(kind=8),dimension(3,2)::chead,erhead_tail
23808        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23809        integer troll
23810        eps_out=80.0d0
23811        escbase=0.0d0
23812 !       do i=1,nres_molec(1)
23813         do i=ibond_start,ibond_end
23814         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23815         itypi  = itype(i,1)
23816         dxi    = dc_norm(1,nres+i)
23817         dyi    = dc_norm(2,nres+i)
23818         dzi    = dc_norm(3,nres+i)
23819         dsci_inv = vbld_inv(i+nres)
23820         xi=c(1,nres+i)
23821         yi=c(2,nres+i)
23822         zi=c(3,nres+i)
23823         xi=mod(xi,boxxsize)
23824          if (xi.lt.0) xi=xi+boxxsize
23825         yi=mod(yi,boxysize)
23826          if (yi.lt.0) yi=yi+boxysize
23827         zi=mod(zi,boxzsize)
23828          if (zi.lt.0) zi=zi+boxzsize
23829          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23830            itypj= itype(j,2)
23831            if (itype(j,2).eq.ntyp1_molec(2))cycle
23832            xj=c(1,j+nres)
23833            yj=c(2,j+nres)
23834            zj=c(3,j+nres)
23835            xj=dmod(xj,boxxsize)
23836            if (xj.lt.0) xj=xj+boxxsize
23837            yj=dmod(yj,boxysize)
23838            if (yj.lt.0) yj=yj+boxysize
23839            zj=dmod(zj,boxzsize)
23840            if (zj.lt.0) zj=zj+boxzsize
23841           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23842           xj_safe=xj
23843           yj_safe=yj
23844           zj_safe=zj
23845           subchap=0
23846
23847           do xshift=-1,1
23848           do yshift=-1,1
23849           do zshift=-1,1
23850           xj=xj_safe+xshift*boxxsize
23851           yj=yj_safe+yshift*boxysize
23852           zj=zj_safe+zshift*boxzsize
23853           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23854           if(dist_temp.lt.dist_init) then
23855             dist_init=dist_temp
23856             xj_temp=xj
23857             yj_temp=yj
23858             zj_temp=zj
23859             subchap=1
23860           endif
23861           enddo
23862           enddo
23863           enddo
23864           if (subchap.eq.1) then
23865           xj=xj_temp-xi
23866           yj=yj_temp-yi
23867           zj=zj_temp-zi
23868           else
23869           xj=xj_safe-xi
23870           yj=yj_safe-yi
23871           zj=zj_safe-zi
23872           endif
23873           dxj = dc_norm( 1, nres+j )
23874           dyj = dc_norm( 2, nres+j )
23875           dzj = dc_norm( 3, nres+j )
23876 !          print *,i,j,itypi,itypj
23877           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23878           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23879 !          d1i=0.0d0
23880 !          d1j=0.0d0
23881 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23882 ! Gay-berne var's
23883           sig0ij = sigma_scbase( itypi,itypj )
23884           chi1   = chi_scbase( itypi, itypj,1 )
23885           chi2   = chi_scbase( itypi, itypj,2 )
23886 !          chi1=0.0d0
23887 !          chi2=0.0d0
23888           chi12  = chi1 * chi2
23889           chip1  = chipp_scbase( itypi, itypj,1 )
23890           chip2  = chipp_scbase( itypi, itypj,2 )
23891 !          chip1=0.0d0
23892 !          chip2=0.0d0
23893           chip12 = chip1 * chip2
23894 ! not used by momo potential, but needed by sc_angular which is shared
23895 ! by all energy_potential subroutines
23896           alf1   = 0.0d0
23897           alf2   = 0.0d0
23898           alf12  = 0.0d0
23899           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23900 !       a12sq = a12sq * a12sq
23901 ! charge of amino acid itypi is...
23902           chis1 = chis_scbase(itypi,itypj,1)
23903           chis2 = chis_scbase(itypi,itypj,2)
23904           chis12 = chis1 * chis2
23905           sig1 = sigmap1_scbase(itypi,itypj)
23906           sig2 = sigmap2_scbase(itypi,itypj)
23907 !       write (*,*) "sig1 = ", sig1
23908 !       write (*,*) "sig2 = ", sig2
23909 ! alpha factors from Fcav/Gcav
23910           b1 = alphasur_scbase(1,itypi,itypj)
23911 !          b1=0.0d0
23912           b2 = alphasur_scbase(2,itypi,itypj)
23913           b3 = alphasur_scbase(3,itypi,itypj)
23914           b4 = alphasur_scbase(4,itypi,itypj)
23915 ! used to determine whether we want to do quadrupole calculations
23916 ! used by Fgb
23917        eps_in = epsintab_scbase(itypi,itypj)
23918        if (eps_in.eq.0.0) eps_in=1.0
23919        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23920 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23921 !-------------------------------------------------------------------
23922 ! tail location and distance calculations
23923        DO k = 1,3
23924 ! location of polar head is computed by taking hydrophobic centre
23925 ! and moving by a d1 * dc_norm vector
23926 ! see unres publications for very informative images
23927         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23928         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23929 ! distance
23930 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23931 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23932         Rhead_distance(k) = chead(k,2) - chead(k,1)
23933        END DO
23934 ! pitagoras (root of sum of squares)
23935        Rhead = dsqrt( &
23936           (Rhead_distance(1)*Rhead_distance(1)) &
23937         + (Rhead_distance(2)*Rhead_distance(2)) &
23938         + (Rhead_distance(3)*Rhead_distance(3)))
23939 !-------------------------------------------------------------------
23940 ! zero everything that should be zero'ed
23941        evdwij = 0.0d0
23942        ECL = 0.0d0
23943        Elj = 0.0d0
23944        Equad = 0.0d0
23945        Epol = 0.0d0
23946        Fcav=0.0d0
23947        eheadtail = 0.0d0
23948        dGCLdOM1 = 0.0d0
23949        dGCLdOM2 = 0.0d0
23950        dGCLdOM12 = 0.0d0
23951        dPOLdOM1 = 0.0d0
23952        dPOLdOM2 = 0.0d0
23953           Fcav = 0.0d0
23954           dFdR = 0.0d0
23955           dCAVdOM1  = 0.0d0
23956           dCAVdOM2  = 0.0d0
23957           dCAVdOM12 = 0.0d0
23958           dscj_inv = vbld_inv(j+nres)
23959 !          print *,i,j,dscj_inv,dsci_inv
23960 ! rij holds 1/(distance of Calpha atoms)
23961           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23962           rij  = dsqrt(rrij)
23963 !----------------------------
23964           CALL sc_angular
23965 ! this should be in elgrad_init but om's are calculated by sc_angular
23966 ! which in turn is used by older potentials
23967 ! om = omega, sqom = om^2
23968           sqom1  = om1 * om1
23969           sqom2  = om2 * om2
23970           sqom12 = om12 * om12
23971
23972 ! now we calculate EGB - Gey-Berne
23973 ! It will be summed up in evdwij and saved in evdw
23974           sigsq     = 1.0D0  / sigsq
23975           sig       = sig0ij * dsqrt(sigsq)
23976 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23977           rij_shift = 1.0/rij - sig + sig0ij
23978           IF (rij_shift.le.0.0D0) THEN
23979            evdw = 1.0D20
23980            RETURN
23981           END IF
23982           sigder = -sig * sigsq
23983           rij_shift = 1.0D0 / rij_shift
23984           fac       = rij_shift**expon
23985           c1        = fac  * fac * aa_scbase(itypi,itypj)
23986 !          c1        = 0.0d0
23987           c2        = fac  * bb_scbase(itypi,itypj)
23988 !          c2        = 0.0d0
23989           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23990           eps2der   = eps3rt * evdwij
23991           eps3der   = eps2rt * evdwij
23992 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23993           evdwij    = eps2rt * eps3rt * evdwij
23994           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23995           fac    = -expon * (c1 + evdwij) * rij_shift
23996           sigder = fac * sigder
23997 !          fac    = rij * fac
23998 ! Calculate distance derivative
23999           gg(1) =  fac
24000           gg(2) =  fac
24001           gg(3) =  fac
24002 !          if (b2.gt.0.0) then
24003           fac = chis1 * sqom1 + chis2 * sqom2 &
24004           - 2.0d0 * chis12 * om1 * om2 * om12
24005 ! we will use pom later in Gcav, so dont mess with it!
24006           pom = 1.0d0 - chis1 * chis2 * sqom12
24007           Lambf = (1.0d0 - (fac / pom))
24008           Lambf = dsqrt(Lambf)
24009           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24010 !       write (*,*) "sparrow = ", sparrow
24011           Chif = 1.0d0/rij * sparrow
24012           ChiLambf = Chif * Lambf
24013           eagle = dsqrt(ChiLambf)
24014           bat = ChiLambf ** 11.0d0
24015           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24016           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24017           botsq = bot * bot
24018           Fcav = top / bot
24019 !          print *,i,j,Fcav
24020           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24021           dbot = 12.0d0 * b4 * bat * Lambf
24022           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24023 !       dFdR = 0.0d0
24024 !      write (*,*) "dFcav/dR = ", dFdR
24025           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24026           dbot = 12.0d0 * b4 * bat * Chif
24027           eagle = Lambf * pom
24028           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24029           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24030           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24031               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24032
24033           dFdL = ((dtop * bot - top * dbot) / botsq)
24034 !       dFdL = 0.0d0
24035           dCAVdOM1  = dFdL * ( dFdOM1 )
24036           dCAVdOM2  = dFdL * ( dFdOM2 )
24037           dCAVdOM12 = dFdL * ( dFdOM12 )
24038
24039           ertail(1) = xj*rij
24040           ertail(2) = yj*rij
24041           ertail(3) = zj*rij
24042 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24043 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24044 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24045 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24046 !           print *,"EOMY",eom1,eom2,eom12
24047 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24048 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24049 ! here dtail=0.0
24050 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24051 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24052        DO k = 1, 3
24053 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24054 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24055         pom = ertail(k)
24056 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24057         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24058                   - (( dFdR + gg(k) ) * pom)
24059 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24060 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24061 !     &             - ( dFdR * pom )
24062         pom = ertail(k)
24063 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24064         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24065                   + (( dFdR + gg(k) ) * pom)
24066 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24067 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24068 !c!     &             + ( dFdR * pom )
24069
24070         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24071                   - (( dFdR + gg(k) ) * ertail(k))
24072 !c!     &             - ( dFdR * ertail(k))
24073
24074         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24075                   + (( dFdR + gg(k) ) * ertail(k))
24076 !c!     &             + ( dFdR * ertail(k))
24077
24078         gg(k) = 0.0d0
24079 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24080 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24081       END DO
24082
24083 !          else
24084
24085 !          endif
24086 !Now dipole-dipole
24087          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24088        w1 = wdipdip_scbase(1,itypi,itypj)
24089        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24090        w3 = wdipdip_scbase(2,itypi,itypj)
24091 !c!-------------------------------------------------------------------
24092 !c! ECL
24093        fac = (om12 - 3.0d0 * om1 * om2)
24094        c1 = (w1 / (Rhead**3.0d0)) * fac
24095        c2 = (w2 / Rhead ** 6.0d0)  &
24096          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24097        c3= (w3/ Rhead ** 6.0d0)  &
24098          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24099        ECL = c1 - c2 + c3
24100 !c!       write (*,*) "w1 = ", w1
24101 !c!       write (*,*) "w2 = ", w2
24102 !c!       write (*,*) "om1 = ", om1
24103 !c!       write (*,*) "om2 = ", om2
24104 !c!       write (*,*) "om12 = ", om12
24105 !c!       write (*,*) "fac = ", fac
24106 !c!       write (*,*) "c1 = ", c1
24107 !c!       write (*,*) "c2 = ", c2
24108 !c!       write (*,*) "Ecl = ", Ecl
24109 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24110 !c!       write (*,*) "c2_2 = ",
24111 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24112 !c!-------------------------------------------------------------------
24113 !c! dervative of ECL is GCL...
24114 !c! dECL/dr
24115        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24116        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24117          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24118        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24119          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24120        dGCLdR = c1 - c2 + c3
24121 !c! dECL/dom1
24122        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24123        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24124          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24125        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24126        dGCLdOM1 = c1 - c2 + c3
24127 !c! dECL/dom2
24128        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24129        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24130          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24131        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24132        dGCLdOM2 = c1 - c2 + c3
24133 !c! dECL/dom12
24134        c1 = w1 / (Rhead ** 3.0d0)
24135        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24136        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24137        dGCLdOM12 = c1 - c2 + c3
24138        DO k= 1, 3
24139         erhead(k) = Rhead_distance(k)/Rhead
24140        END DO
24141        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24142        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24143        facd1 = d1i * vbld_inv(i+nres)
24144        facd2 = d1j * vbld_inv(j+nres)
24145        DO k = 1, 3
24146
24147         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24148         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24149                   - dGCLdR * pom
24150         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24151         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24152                   + dGCLdR * pom
24153
24154         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24155                   - dGCLdR * erhead(k)
24156         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24157                   + dGCLdR * erhead(k)
24158        END DO
24159        endif
24160 !now charge with dipole eg. ARG-dG
24161        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24162       alphapol1 = alphapol_scbase(itypi,itypj)
24163        w1        = wqdip_scbase(1,itypi,itypj)
24164        w2        = wqdip_scbase(2,itypi,itypj)
24165 !       w1=0.0d0
24166 !       w2=0.0d0
24167 !       pis       = sig0head_scbase(itypi,itypj)
24168 !       eps_head   = epshead_scbase(itypi,itypj)
24169 !c!-------------------------------------------------------------------
24170 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24171        R1 = 0.0d0
24172        DO k = 1, 3
24173 !c! Calculate head-to-tail distances tail is center of side-chain
24174         R1=R1+(c(k,j+nres)-chead(k,1))**2
24175        END DO
24176 !c! Pitagoras
24177        R1 = dsqrt(R1)
24178
24179 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24180 !c!     &        +dhead(1,1,itypi,itypj))**2))
24181 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24182 !c!     &        +dhead(2,1,itypi,itypj))**2))
24183
24184 !c!-------------------------------------------------------------------
24185 !c! ecl
24186        sparrow  = w1  *  om1
24187        hawk     = w2 *  (1.0d0 - sqom2)
24188        Ecl = sparrow / Rhead**2.0d0 &
24189            - hawk    / Rhead**4.0d0
24190 !c!-------------------------------------------------------------------
24191 !c! derivative of ecl is Gcl
24192 !c! dF/dr part
24193        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24194                 + 4.0d0 * hawk    / Rhead**5.0d0
24195 !c! dF/dom1
24196        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24197 !c! dF/dom2
24198        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24199 !c--------------------------------------------------------------------
24200 !c Polarization energy
24201 !c Epol
24202        MomoFac1 = (1.0d0 - chi1 * sqom2)
24203        RR1  = R1 * R1 / MomoFac1
24204        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24205        fgb1 = sqrt( RR1 + a12sq * ee1)
24206 !       eps_inout_fac=0.0d0
24207        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24208 ! derivative of Epol is Gpol...
24209        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24210                 / (fgb1 ** 5.0d0)
24211        dFGBdR1 = ( (R1 / MomoFac1) &
24212              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24213              / ( 2.0d0 * fgb1 )
24214        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24215                * (2.0d0 - 0.5d0 * ee1) ) &
24216                / (2.0d0 * fgb1)
24217        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24218 !       dPOLdR1 = 0.0d0
24219        dPOLdOM1 = 0.0d0
24220        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24221        DO k = 1, 3
24222         erhead(k) = Rhead_distance(k)/Rhead
24223         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24224        END DO
24225
24226        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24227        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24228        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24229 !       bat=0.0d0
24230        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24231        facd1 = d1i * vbld_inv(i+nres)
24232        facd2 = d1j * vbld_inv(j+nres)
24233 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24234
24235        DO k = 1, 3
24236         hawk = (erhead_tail(k,1) + &
24237         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24238 !        facd1=0.0d0
24239 !        facd2=0.0d0
24240         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24241         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24242                    - dGCLdR * pom &
24243                    - dPOLdR1 *  (erhead_tail(k,1))
24244 !     &             - dGLJdR * pom
24245
24246         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24247         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24248                    + dGCLdR * pom  &
24249                    + dPOLdR1 * (erhead_tail(k,1))
24250 !     &             + dGLJdR * pom
24251
24252
24253         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24254                   - dGCLdR * erhead(k) &
24255                   - dPOLdR1 * erhead_tail(k,1)
24256 !     &             - dGLJdR * erhead(k)
24257
24258         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24259                   + dGCLdR * erhead(k)  &
24260                   + dPOLdR1 * erhead_tail(k,1)
24261 !     &             + dGLJdR * erhead(k)
24262
24263        END DO
24264        endif
24265 !       print *,i,j,evdwij,epol,Fcav,ECL
24266        escbase=escbase+evdwij+epol+Fcav+ECL
24267        call sc_grad_scbase
24268          enddo
24269       enddo
24270
24271       return
24272       end subroutine eprot_sc_base
24273       SUBROUTINE sc_grad_scbase
24274       use calc_data
24275
24276        real (kind=8) :: dcosom1(3),dcosom2(3)
24277        eom1  =    &
24278               eps2der * eps2rt_om1   &
24279             - 2.0D0 * alf1 * eps3der &
24280             + sigder * sigsq_om1     &
24281             + dCAVdOM1               &
24282             + dGCLdOM1               &
24283             + dPOLdOM1
24284
24285        eom2  =  &
24286               eps2der * eps2rt_om2   &
24287             + 2.0D0 * alf2 * eps3der &
24288             + sigder * sigsq_om2     &
24289             + dCAVdOM2               &
24290             + dGCLdOM2               &
24291             + dPOLdOM2
24292
24293        eom12 =    &
24294               evdwij  * eps1_om12     &
24295             + eps2der * eps2rt_om12   &
24296             - 2.0D0 * alf12 * eps3der &
24297             + sigder *sigsq_om12      &
24298             + dCAVdOM12               &
24299             + dGCLdOM12
24300
24301 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24302 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24303 !               gg(1),gg(2),"rozne"
24304        DO k = 1, 3
24305         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24306         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24307         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24308         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24309                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24310                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24311         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24312                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24313                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24314         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24315         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24316        END DO
24317        RETURN
24318       END SUBROUTINE sc_grad_scbase
24319
24320
24321       subroutine epep_sc_base(epepbase)
24322       use calc_data
24323       logical :: lprn
24324 !el local variables
24325       integer :: iint,itypi,itypi1,itypj,subchap
24326       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24327       real(kind=8) :: evdw,sig0ij
24328       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24329                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24330                     sslipi,sslipj,faclip
24331       integer :: ii
24332       real(kind=8) :: fracinbuf
24333        real (kind=8) :: epepbase
24334        real (kind=8),dimension(4):: ener
24335        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24336        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24337         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24338         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24339         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24340         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24341         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24342         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24343        real(kind=8),dimension(3,2)::chead,erhead_tail
24344        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24345        integer troll
24346        eps_out=80.0d0
24347        epepbase=0.0d0
24348 !       do i=1,nres_molec(1)-1
24349         do i=ibond_start,ibond_end
24350         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24351 !C        itypi  = itype(i,1)
24352         dxi    = dc_norm(1,i)
24353         dyi    = dc_norm(2,i)
24354         dzi    = dc_norm(3,i)
24355 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24356         dsci_inv = vbld_inv(i+1)/2.0
24357         xi=(c(1,i)+c(1,i+1))/2.0
24358         yi=(c(2,i)+c(2,i+1))/2.0
24359         zi=(c(3,i)+c(3,i+1))/2.0
24360         xi=mod(xi,boxxsize)
24361          if (xi.lt.0) xi=xi+boxxsize
24362         yi=mod(yi,boxysize)
24363          if (yi.lt.0) yi=yi+boxysize
24364         zi=mod(zi,boxzsize)
24365          if (zi.lt.0) zi=zi+boxzsize
24366          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24367            itypj= itype(j,2)
24368            if (itype(j,2).eq.ntyp1_molec(2))cycle
24369            xj=c(1,j+nres)
24370            yj=c(2,j+nres)
24371            zj=c(3,j+nres)
24372            xj=dmod(xj,boxxsize)
24373            if (xj.lt.0) xj=xj+boxxsize
24374            yj=dmod(yj,boxysize)
24375            if (yj.lt.0) yj=yj+boxysize
24376            zj=dmod(zj,boxzsize)
24377            if (zj.lt.0) zj=zj+boxzsize
24378           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24379           xj_safe=xj
24380           yj_safe=yj
24381           zj_safe=zj
24382           subchap=0
24383
24384           do xshift=-1,1
24385           do yshift=-1,1
24386           do zshift=-1,1
24387           xj=xj_safe+xshift*boxxsize
24388           yj=yj_safe+yshift*boxysize
24389           zj=zj_safe+zshift*boxzsize
24390           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24391           if(dist_temp.lt.dist_init) then
24392             dist_init=dist_temp
24393             xj_temp=xj
24394             yj_temp=yj
24395             zj_temp=zj
24396             subchap=1
24397           endif
24398           enddo
24399           enddo
24400           enddo
24401           if (subchap.eq.1) then
24402           xj=xj_temp-xi
24403           yj=yj_temp-yi
24404           zj=zj_temp-zi
24405           else
24406           xj=xj_safe-xi
24407           yj=yj_safe-yi
24408           zj=zj_safe-zi
24409           endif
24410           dxj = dc_norm( 1, nres+j )
24411           dyj = dc_norm( 2, nres+j )
24412           dzj = dc_norm( 3, nres+j )
24413 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24414 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24415
24416 ! Gay-berne var's
24417           sig0ij = sigma_pepbase(itypj )
24418           chi1   = chi_pepbase(itypj,1 )
24419           chi2   = chi_pepbase(itypj,2 )
24420 !          chi1=0.0d0
24421 !          chi2=0.0d0
24422           chi12  = chi1 * chi2
24423           chip1  = chipp_pepbase(itypj,1 )
24424           chip2  = chipp_pepbase(itypj,2 )
24425 !          chip1=0.0d0
24426 !          chip2=0.0d0
24427           chip12 = chip1 * chip2
24428           chis1 = chis_pepbase(itypj,1)
24429           chis2 = chis_pepbase(itypj,2)
24430           chis12 = chis1 * chis2
24431           sig1 = sigmap1_pepbase(itypj)
24432           sig2 = sigmap2_pepbase(itypj)
24433 !       write (*,*) "sig1 = ", sig1
24434 !       write (*,*) "sig2 = ", sig2
24435        DO k = 1,3
24436 ! location of polar head is computed by taking hydrophobic centre
24437 ! and moving by a d1 * dc_norm vector
24438 ! see unres publications for very informative images
24439         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24440 ! + d1i * dc_norm(k, i+nres)
24441         chead(k,2) = c(k, j+nres)
24442 ! + d1j * dc_norm(k, j+nres)
24443 ! distance
24444 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24445 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24446         Rhead_distance(k) = chead(k,2) - chead(k,1)
24447 !        print *,gvdwc_pepbase(k,i)
24448
24449        END DO
24450        Rhead = dsqrt( &
24451           (Rhead_distance(1)*Rhead_distance(1)) &
24452         + (Rhead_distance(2)*Rhead_distance(2)) &
24453         + (Rhead_distance(3)*Rhead_distance(3)))
24454
24455 ! alpha factors from Fcav/Gcav
24456           b1 = alphasur_pepbase(1,itypj)
24457 !          b1=0.0d0
24458           b2 = alphasur_pepbase(2,itypj)
24459           b3 = alphasur_pepbase(3,itypj)
24460           b4 = alphasur_pepbase(4,itypj)
24461           alf1   = 0.0d0
24462           alf2   = 0.0d0
24463           alf12  = 0.0d0
24464           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24465 !          print *,i,j,rrij
24466           rij  = dsqrt(rrij)
24467 !----------------------------
24468        evdwij = 0.0d0
24469        ECL = 0.0d0
24470        Elj = 0.0d0
24471        Equad = 0.0d0
24472        Epol = 0.0d0
24473        Fcav=0.0d0
24474        eheadtail = 0.0d0
24475        dGCLdOM1 = 0.0d0
24476        dGCLdOM2 = 0.0d0
24477        dGCLdOM12 = 0.0d0
24478        dPOLdOM1 = 0.0d0
24479        dPOLdOM2 = 0.0d0
24480           Fcav = 0.0d0
24481           dFdR = 0.0d0
24482           dCAVdOM1  = 0.0d0
24483           dCAVdOM2  = 0.0d0
24484           dCAVdOM12 = 0.0d0
24485           dscj_inv = vbld_inv(j+nres)
24486           CALL sc_angular
24487 ! this should be in elgrad_init but om's are calculated by sc_angular
24488 ! which in turn is used by older potentials
24489 ! om = omega, sqom = om^2
24490           sqom1  = om1 * om1
24491           sqom2  = om2 * om2
24492           sqom12 = om12 * om12
24493
24494 ! now we calculate EGB - Gey-Berne
24495 ! It will be summed up in evdwij and saved in evdw
24496           sigsq     = 1.0D0  / sigsq
24497           sig       = sig0ij * dsqrt(sigsq)
24498           rij_shift = 1.0/rij - sig + sig0ij
24499           IF (rij_shift.le.0.0D0) THEN
24500            evdw = 1.0D20
24501            RETURN
24502           END IF
24503           sigder = -sig * sigsq
24504           rij_shift = 1.0D0 / rij_shift
24505           fac       = rij_shift**expon
24506           c1        = fac  * fac * aa_pepbase(itypj)
24507 !          c1        = 0.0d0
24508           c2        = fac  * bb_pepbase(itypj)
24509 !          c2        = 0.0d0
24510           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24511           eps2der   = eps3rt * evdwij
24512           eps3der   = eps2rt * evdwij
24513 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24514           evdwij    = eps2rt * eps3rt * evdwij
24515           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24516           fac    = -expon * (c1 + evdwij) * rij_shift
24517           sigder = fac * sigder
24518 !          fac    = rij * fac
24519 ! Calculate distance derivative
24520           gg(1) =  fac
24521           gg(2) =  fac
24522           gg(3) =  fac
24523           fac = chis1 * sqom1 + chis2 * sqom2 &
24524           - 2.0d0 * chis12 * om1 * om2 * om12
24525 ! we will use pom later in Gcav, so dont mess with it!
24526           pom = 1.0d0 - chis1 * chis2 * sqom12
24527           Lambf = (1.0d0 - (fac / pom))
24528           Lambf = dsqrt(Lambf)
24529           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24530 !       write (*,*) "sparrow = ", sparrow
24531           Chif = 1.0d0/rij * sparrow
24532           ChiLambf = Chif * Lambf
24533           eagle = dsqrt(ChiLambf)
24534           bat = ChiLambf ** 11.0d0
24535           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24536           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24537           botsq = bot * bot
24538           Fcav = top / bot
24539 !          print *,i,j,Fcav
24540           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24541           dbot = 12.0d0 * b4 * bat * Lambf
24542           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24543 !       dFdR = 0.0d0
24544 !      write (*,*) "dFcav/dR = ", dFdR
24545           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24546           dbot = 12.0d0 * b4 * bat * Chif
24547           eagle = Lambf * pom
24548           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24549           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24550           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24551               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24552
24553           dFdL = ((dtop * bot - top * dbot) / botsq)
24554 !       dFdL = 0.0d0
24555           dCAVdOM1  = dFdL * ( dFdOM1 )
24556           dCAVdOM2  = dFdL * ( dFdOM2 )
24557           dCAVdOM12 = dFdL * ( dFdOM12 )
24558
24559           ertail(1) = xj*rij
24560           ertail(2) = yj*rij
24561           ertail(3) = zj*rij
24562        DO k = 1, 3
24563 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24564 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24565         pom = ertail(k)
24566 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24567         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24568                   - (( dFdR + gg(k) ) * pom)/2.0
24569 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24570 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24571 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24572 !     &             - ( dFdR * pom )
24573         pom = ertail(k)
24574 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24575         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24576                   + (( dFdR + gg(k) ) * pom)
24577 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24578 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24579 !c!     &             + ( dFdR * pom )
24580
24581         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24582                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24583 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24584
24585 !c!     &             - ( dFdR * ertail(k))
24586
24587         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24588                   + (( dFdR + gg(k) ) * ertail(k))
24589 !c!     &             + ( dFdR * ertail(k))
24590
24591         gg(k) = 0.0d0
24592 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24593 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24594       END DO
24595
24596
24597        w1 = wdipdip_pepbase(1,itypj)
24598        w2 = -wdipdip_pepbase(3,itypj)/2.0
24599        w3 = wdipdip_pepbase(2,itypj)
24600 !       w1=0.0d0
24601 !       w2=0.0d0
24602 !c!-------------------------------------------------------------------
24603 !c! ECL
24604 !       w3=0.0d0
24605        fac = (om12 - 3.0d0 * om1 * om2)
24606        c1 = (w1 / (Rhead**3.0d0)) * fac
24607        c2 = (w2 / Rhead ** 6.0d0)  &
24608          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24609        c3= (w3/ Rhead ** 6.0d0)  &
24610          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24611
24612        ECL = c1 - c2 + c3
24613
24614        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24615        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24616          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24617        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24618          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24619
24620        dGCLdR = c1 - c2 + c3
24621 !c! dECL/dom1
24622        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24623        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24624          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24625        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24626        dGCLdOM1 = c1 - c2 + c3
24627 !c! dECL/dom2
24628        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24629        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24630          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24631        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24632
24633        dGCLdOM2 = c1 - c2 + c3
24634 !c! dECL/dom12
24635        c1 = w1 / (Rhead ** 3.0d0)
24636        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24637        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24638        dGCLdOM12 = c1 - c2 + c3
24639        DO k= 1, 3
24640         erhead(k) = Rhead_distance(k)/Rhead
24641        END DO
24642        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24643        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24644 !       facd1 = d1 * vbld_inv(i+nres)
24645 !       facd2 = d2 * vbld_inv(j+nres)
24646        DO k = 1, 3
24647
24648 !        pom = erhead(k)
24649 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24650 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24651 !                  - dGCLdR * pom
24652         pom = erhead(k)
24653 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24654         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24655                   + dGCLdR * pom
24656
24657         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24658                   - dGCLdR * erhead(k)/2.0d0
24659 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24660         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24661                   - dGCLdR * erhead(k)/2.0d0
24662 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24663         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24664                   + dGCLdR * erhead(k)
24665        END DO
24666 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24667        epepbase=epepbase+evdwij+Fcav+ECL
24668        call sc_grad_pepbase
24669        enddo
24670        enddo
24671       END SUBROUTINE epep_sc_base
24672       SUBROUTINE sc_grad_pepbase
24673       use calc_data
24674
24675        real (kind=8) :: dcosom1(3),dcosom2(3)
24676        eom1  =    &
24677               eps2der * eps2rt_om1   &
24678             - 2.0D0 * alf1 * eps3der &
24679             + sigder * sigsq_om1     &
24680             + dCAVdOM1               &
24681             + dGCLdOM1               &
24682             + dPOLdOM1
24683
24684        eom2  =  &
24685               eps2der * eps2rt_om2   &
24686             + 2.0D0 * alf2 * eps3der &
24687             + sigder * sigsq_om2     &
24688             + dCAVdOM2               &
24689             + dGCLdOM2               &
24690             + dPOLdOM2
24691
24692        eom12 =    &
24693               evdwij  * eps1_om12     &
24694             + eps2der * eps2rt_om12   &
24695             - 2.0D0 * alf12 * eps3der &
24696             + sigder *sigsq_om12      &
24697             + dCAVdOM12               &
24698             + dGCLdOM12
24699 !        om12=0.0
24700 !        eom12=0.0
24701 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24702 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24703 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24704 !                 *dsci_inv*2.0
24705 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24706 !               gg(1),gg(2),"rozne"
24707        DO k = 1, 3
24708         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24709         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24710         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24711         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24712                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24713                  *dsci_inv*2.0 &
24714                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24715         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24716                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24717                  *dsci_inv*2.0 &
24718                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24719 !         print *,eom12,eom2,om12,om2
24720 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24721 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24722         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24723                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24724                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24725         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24726        END DO
24727        RETURN
24728       END SUBROUTINE sc_grad_pepbase
24729       subroutine eprot_sc_phosphate(escpho)
24730       use calc_data
24731 !      implicit real*8 (a-h,o-z)
24732 !      include 'DIMENSIONS'
24733 !      include 'COMMON.GEO'
24734 !      include 'COMMON.VAR'
24735 !      include 'COMMON.LOCAL'
24736 !      include 'COMMON.CHAIN'
24737 !      include 'COMMON.DERIV'
24738 !      include 'COMMON.NAMES'
24739 !      include 'COMMON.INTERACT'
24740 !      include 'COMMON.IOUNITS'
24741 !      include 'COMMON.CALC'
24742 !      include 'COMMON.CONTROL'
24743 !      include 'COMMON.SBRIDGE'
24744       logical :: lprn
24745 !el local variables
24746       integer :: iint,itypi,itypi1,itypj,subchap
24747       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24748       real(kind=8) :: evdw,sig0ij
24749       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24750                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24751                     sslipi,sslipj,faclip,alpha_sco
24752       integer :: ii
24753       real(kind=8) :: fracinbuf
24754        real (kind=8) :: escpho
24755        real (kind=8),dimension(4):: ener
24756        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24757        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24758         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24759         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24760         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24761         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24762         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24763         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24764        real(kind=8),dimension(3,2)::chead,erhead_tail
24765        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24766        integer troll
24767        eps_out=80.0d0
24768        escpho=0.0d0
24769 !       do i=1,nres_molec(1)
24770         do i=ibond_start,ibond_end
24771         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24772         itypi  = itype(i,1)
24773         dxi    = dc_norm(1,nres+i)
24774         dyi    = dc_norm(2,nres+i)
24775         dzi    = dc_norm(3,nres+i)
24776         dsci_inv = vbld_inv(i+nres)
24777         xi=c(1,nres+i)
24778         yi=c(2,nres+i)
24779         zi=c(3,nres+i)
24780         xi=mod(xi,boxxsize)
24781          if (xi.lt.0) xi=xi+boxxsize
24782         yi=mod(yi,boxysize)
24783          if (yi.lt.0) yi=yi+boxysize
24784         zi=mod(zi,boxzsize)
24785          if (zi.lt.0) zi=zi+boxzsize
24786          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24787            itypj= itype(j,2)
24788            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24789             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24790            xj=(c(1,j)+c(1,j+1))/2.0
24791            yj=(c(2,j)+c(2,j+1))/2.0
24792            zj=(c(3,j)+c(3,j+1))/2.0
24793            xj=dmod(xj,boxxsize)
24794            if (xj.lt.0) xj=xj+boxxsize
24795            yj=dmod(yj,boxysize)
24796            if (yj.lt.0) yj=yj+boxysize
24797            zj=dmod(zj,boxzsize)
24798            if (zj.lt.0) zj=zj+boxzsize
24799           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24800           xj_safe=xj
24801           yj_safe=yj
24802           zj_safe=zj
24803           subchap=0
24804           do xshift=-1,1
24805           do yshift=-1,1
24806           do zshift=-1,1
24807           xj=xj_safe+xshift*boxxsize
24808           yj=yj_safe+yshift*boxysize
24809           zj=zj_safe+zshift*boxzsize
24810           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24811           if(dist_temp.lt.dist_init) then
24812             dist_init=dist_temp
24813             xj_temp=xj
24814             yj_temp=yj
24815             zj_temp=zj
24816             subchap=1
24817           endif
24818           enddo
24819           enddo
24820           enddo
24821           if (subchap.eq.1) then
24822           xj=xj_temp-xi
24823           yj=yj_temp-yi
24824           zj=zj_temp-zi
24825           else
24826           xj=xj_safe-xi
24827           yj=yj_safe-yi
24828           zj=zj_safe-zi
24829           endif
24830           dxj = dc_norm( 1,j )
24831           dyj = dc_norm( 2,j )
24832           dzj = dc_norm( 3,j )
24833           dscj_inv = vbld_inv(j+1)
24834
24835 ! Gay-berne var's
24836           sig0ij = sigma_scpho(itypi )
24837           chi1   = chi_scpho(itypi,1 )
24838           chi2   = chi_scpho(itypi,2 )
24839 !          chi1=0.0d0
24840 !          chi2=0.0d0
24841           chi12  = chi1 * chi2
24842           chip1  = chipp_scpho(itypi,1 )
24843           chip2  = chipp_scpho(itypi,2 )
24844 !          chip1=0.0d0
24845 !          chip2=0.0d0
24846           chip12 = chip1 * chip2
24847           chis1 = chis_scpho(itypi,1)
24848           chis2 = chis_scpho(itypi,2)
24849           chis12 = chis1 * chis2
24850           sig1 = sigmap1_scpho(itypi)
24851           sig2 = sigmap2_scpho(itypi)
24852 !       write (*,*) "sig1 = ", sig1
24853 !       write (*,*) "sig1 = ", sig1
24854 !       write (*,*) "sig2 = ", sig2
24855 ! alpha factors from Fcav/Gcav
24856           alf1   = 0.0d0
24857           alf2   = 0.0d0
24858           alf12  = 0.0d0
24859           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24860
24861           b1 = alphasur_scpho(1,itypi)
24862 !          b1=0.0d0
24863           b2 = alphasur_scpho(2,itypi)
24864           b3 = alphasur_scpho(3,itypi)
24865           b4 = alphasur_scpho(4,itypi)
24866 ! used to determine whether we want to do quadrupole calculations
24867 ! used by Fgb
24868        eps_in = epsintab_scpho(itypi)
24869        if (eps_in.eq.0.0) eps_in=1.0
24870        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24871 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24872 !-------------------------------------------------------------------
24873 ! tail location and distance calculations
24874           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24875           d1j = 0.0
24876        DO k = 1,3
24877 ! location of polar head is computed by taking hydrophobic centre
24878 ! and moving by a d1 * dc_norm vector
24879 ! see unres publications for very informative images
24880         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24881         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24882 ! distance
24883 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24884 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24885         Rhead_distance(k) = chead(k,2) - chead(k,1)
24886        END DO
24887 ! pitagoras (root of sum of squares)
24888        Rhead = dsqrt( &
24889           (Rhead_distance(1)*Rhead_distance(1)) &
24890         + (Rhead_distance(2)*Rhead_distance(2)) &
24891         + (Rhead_distance(3)*Rhead_distance(3)))
24892        Rhead_sq=Rhead**2.0
24893 !-------------------------------------------------------------------
24894 ! zero everything that should be zero'ed
24895        evdwij = 0.0d0
24896        ECL = 0.0d0
24897        Elj = 0.0d0
24898        Equad = 0.0d0
24899        Epol = 0.0d0
24900        Fcav=0.0d0
24901        eheadtail = 0.0d0
24902        dGCLdR=0.0d0
24903        dGCLdOM1 = 0.0d0
24904        dGCLdOM2 = 0.0d0
24905        dGCLdOM12 = 0.0d0
24906        dPOLdOM1 = 0.0d0
24907        dPOLdOM2 = 0.0d0
24908           Fcav = 0.0d0
24909           dFdR = 0.0d0
24910           dCAVdOM1  = 0.0d0
24911           dCAVdOM2  = 0.0d0
24912           dCAVdOM12 = 0.0d0
24913           dscj_inv = vbld_inv(j+1)/2.0
24914 !dhead_scbasej(itypi,itypj)
24915 !          print *,i,j,dscj_inv,dsci_inv
24916 ! rij holds 1/(distance of Calpha atoms)
24917           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24918           rij  = dsqrt(rrij)
24919 !----------------------------
24920           CALL sc_angular
24921 ! this should be in elgrad_init but om's are calculated by sc_angular
24922 ! which in turn is used by older potentials
24923 ! om = omega, sqom = om^2
24924           sqom1  = om1 * om1
24925           sqom2  = om2 * om2
24926           sqom12 = om12 * om12
24927
24928 ! now we calculate EGB - Gey-Berne
24929 ! It will be summed up in evdwij and saved in evdw
24930           sigsq     = 1.0D0  / sigsq
24931           sig       = sig0ij * dsqrt(sigsq)
24932 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24933           rij_shift = 1.0/rij - sig + sig0ij
24934           IF (rij_shift.le.0.0D0) THEN
24935            evdw = 1.0D20
24936            RETURN
24937           END IF
24938           sigder = -sig * sigsq
24939           rij_shift = 1.0D0 / rij_shift
24940           fac       = rij_shift**expon
24941           c1        = fac  * fac * aa_scpho(itypi)
24942 !          c1        = 0.0d0
24943           c2        = fac  * bb_scpho(itypi)
24944 !          c2        = 0.0d0
24945           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24946           eps2der   = eps3rt * evdwij
24947           eps3der   = eps2rt * evdwij
24948 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24949           evdwij    = eps2rt * eps3rt * evdwij
24950           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24951           fac    = -expon * (c1 + evdwij) * rij_shift
24952           sigder = fac * sigder
24953 !          fac    = rij * fac
24954 ! Calculate distance derivative
24955           gg(1) =  fac
24956           gg(2) =  fac
24957           gg(3) =  fac
24958           fac = chis1 * sqom1 + chis2 * sqom2 &
24959           - 2.0d0 * chis12 * om1 * om2 * om12
24960 ! we will use pom later in Gcav, so dont mess with it!
24961           pom = 1.0d0 - chis1 * chis2 * sqom12
24962           Lambf = (1.0d0 - (fac / pom))
24963           Lambf = dsqrt(Lambf)
24964           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24965 !       write (*,*) "sparrow = ", sparrow
24966           Chif = 1.0d0/rij * sparrow
24967           ChiLambf = Chif * Lambf
24968           eagle = dsqrt(ChiLambf)
24969           bat = ChiLambf ** 11.0d0
24970           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24971           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24972           botsq = bot * bot
24973           Fcav = top / bot
24974           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24975           dbot = 12.0d0 * b4 * bat * Lambf
24976           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24977 !       dFdR = 0.0d0
24978 !      write (*,*) "dFcav/dR = ", dFdR
24979           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24980           dbot = 12.0d0 * b4 * bat * Chif
24981           eagle = Lambf * pom
24982           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24983           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24984           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24985               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24986
24987           dFdL = ((dtop * bot - top * dbot) / botsq)
24988 !       dFdL = 0.0d0
24989           dCAVdOM1  = dFdL * ( dFdOM1 )
24990           dCAVdOM2  = dFdL * ( dFdOM2 )
24991           dCAVdOM12 = dFdL * ( dFdOM12 )
24992
24993           ertail(1) = xj*rij
24994           ertail(2) = yj*rij
24995           ertail(3) = zj*rij
24996        DO k = 1, 3
24997 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24998 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24999 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25000
25001         pom = ertail(k)
25002 !        print *,pom,gg(k),dFdR
25003 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25004         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25005                   - (( dFdR + gg(k) ) * pom)
25006 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25007 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25008 !     &             - ( dFdR * pom )
25009 !        pom = ertail(k)
25010 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25011 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25012 !                  + (( dFdR + gg(k) ) * pom)
25013 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25014 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25015 !c!     &             + ( dFdR * pom )
25016
25017         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25018                   - (( dFdR + gg(k) ) * ertail(k))
25019 !c!     &             - ( dFdR * ertail(k))
25020
25021         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25022                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25023
25024         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25025                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25026
25027 !c!     &             + ( dFdR * ertail(k))
25028
25029         gg(k) = 0.0d0
25030         ENDDO
25031 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25032 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25033 !      alphapol1 = alphapol_scpho(itypi)
25034        if (wqq_scpho(itypi).ne.0.0) then
25035        Qij=wqq_scpho(itypi)/eps_in
25036        alpha_sco=1.d0/alphi_scpho(itypi)
25037 !       Qij=0.0
25038        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25039 !c! derivative of Ecl is Gcl...
25040        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25041                 (Rhead*alpha_sco+1) ) / Rhead_sq
25042        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25043        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25044        w1        = wqdip_scpho(1,itypi)
25045        w2        = wqdip_scpho(2,itypi)
25046 !       w1=0.0d0
25047 !       w2=0.0d0
25048 !       pis       = sig0head_scbase(itypi,itypj)
25049 !       eps_head   = epshead_scbase(itypi,itypj)
25050 !c!-------------------------------------------------------------------
25051
25052 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25053 !c!     &        +dhead(1,1,itypi,itypj))**2))
25054 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25055 !c!     &        +dhead(2,1,itypi,itypj))**2))
25056
25057 !c!-------------------------------------------------------------------
25058 !c! ecl
25059        sparrow  = w1  *  om1
25060        hawk     = w2 *  (1.0d0 - sqom2)
25061        Ecl = sparrow / Rhead**2.0d0 &
25062            - hawk    / Rhead**4.0d0
25063 !c!-------------------------------------------------------------------
25064        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25065            1.0/rij,sparrow
25066
25067 !c! derivative of ecl is Gcl
25068 !c! dF/dr part
25069        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25070                 + 4.0d0 * hawk    / Rhead**5.0d0
25071 !c! dF/dom1
25072        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25073 !c! dF/dom2
25074        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25075        endif
25076
25077 !c--------------------------------------------------------------------
25078 !c Polarization energy
25079 !c Epol
25080        R1 = 0.0d0
25081        DO k = 1, 3
25082 !c! Calculate head-to-tail distances tail is center of side-chain
25083         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25084        END DO
25085 !c! Pitagoras
25086        R1 = dsqrt(R1)
25087
25088       alphapol1 = alphapol_scpho(itypi)
25089 !      alphapol1=0.0
25090        MomoFac1 = (1.0d0 - chi2 * sqom1)
25091        RR1  = R1 * R1 / MomoFac1
25092        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25093 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25094        fgb1 = sqrt( RR1 + a12sq * ee1)
25095 !       eps_inout_fac=0.0d0
25096        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25097 ! derivative of Epol is Gpol...
25098        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25099                 / (fgb1 ** 5.0d0)
25100        dFGBdR1 = ( (R1 / MomoFac1) &
25101              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25102              / ( 2.0d0 * fgb1 )
25103        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25104                * (2.0d0 - 0.5d0 * ee1) ) &
25105                / (2.0d0 * fgb1)
25106        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25107 !       dPOLdR1 = 0.0d0
25108 !       dPOLdOM1 = 0.0d0
25109        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25110                * (2.0d0 - 0.5d0 * ee1) ) &
25111                / (2.0d0 * fgb1)
25112
25113        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25114        dPOLdOM2 = 0.0
25115        DO k = 1, 3
25116         erhead(k) = Rhead_distance(k)/Rhead
25117         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25118        END DO
25119
25120        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25121        erdxj = scalar( erhead(1), dC_norm(1,j) )
25122        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25123 !       bat=0.0d0
25124        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25125        facd1 = d1i * vbld_inv(i+nres)
25126        facd2 = d1j * vbld_inv(j)
25127 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25128
25129        DO k = 1, 3
25130         hawk = (erhead_tail(k,1) + &
25131         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25132 !        facd1=0.0d0
25133 !        facd2=0.0d0
25134 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25135 !                pom,(erhead_tail(k,1))
25136
25137 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25138         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25139         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25140                    - dGCLdR * pom &
25141                    - dPOLdR1 *  (erhead_tail(k,1))
25142 !     &             - dGLJdR * pom
25143
25144         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25145 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25146 !                   + dGCLdR * pom  &
25147 !                   + dPOLdR1 * (erhead_tail(k,1))
25148 !     &             + dGLJdR * pom
25149
25150
25151         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25152                   - dGCLdR * erhead(k) &
25153                   - dPOLdR1 * erhead_tail(k,1)
25154 !     &             - dGLJdR * erhead(k)
25155
25156         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25157                   + (dGCLdR * erhead(k)  &
25158                   + dPOLdR1 * erhead_tail(k,1))/2.0
25159         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25160                   + (dGCLdR * erhead(k)  &
25161                   + dPOLdR1 * erhead_tail(k,1))/2.0
25162
25163 !     &             + dGLJdR * erhead(k)
25164 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25165
25166        END DO
25167 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25168        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25169         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25170        escpho=escpho+evdwij+epol+Fcav+ECL
25171        call sc_grad_scpho
25172          enddo
25173
25174       enddo
25175
25176       return
25177       end subroutine eprot_sc_phosphate
25178       SUBROUTINE sc_grad_scpho
25179       use calc_data
25180
25181        real (kind=8) :: dcosom1(3),dcosom2(3)
25182        eom1  =    &
25183               eps2der * eps2rt_om1   &
25184             - 2.0D0 * alf1 * eps3der &
25185             + sigder * sigsq_om1     &
25186             + dCAVdOM1               &
25187             + dGCLdOM1               &
25188             + dPOLdOM1
25189
25190        eom2  =  &
25191               eps2der * eps2rt_om2   &
25192             + 2.0D0 * alf2 * eps3der &
25193             + sigder * sigsq_om2     &
25194             + dCAVdOM2               &
25195             + dGCLdOM2               &
25196             + dPOLdOM2
25197
25198        eom12 =    &
25199               evdwij  * eps1_om12     &
25200             + eps2der * eps2rt_om12   &
25201             - 2.0D0 * alf12 * eps3der &
25202             + sigder *sigsq_om12      &
25203             + dCAVdOM12               &
25204             + dGCLdOM12
25205 !        om12=0.0
25206 !        eom12=0.0
25207 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25208 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25209 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25210 !                 *dsci_inv*2.0
25211 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25212 !               gg(1),gg(2),"rozne"
25213        DO k = 1, 3
25214         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25215         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25216         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25217         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25218                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25219                  *dscj_inv*2.0 &
25220                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25221         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25222                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25223                  *dscj_inv*2.0 &
25224                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25225         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25226                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25227                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25228
25229 !         print *,eom12,eom2,om12,om2
25230 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25231 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25232 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25233 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25234 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25235         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25236        END DO
25237        RETURN
25238       END SUBROUTINE sc_grad_scpho
25239       subroutine eprot_pep_phosphate(epeppho)
25240       use calc_data
25241 !      implicit real*8 (a-h,o-z)
25242 !      include 'DIMENSIONS'
25243 !      include 'COMMON.GEO'
25244 !      include 'COMMON.VAR'
25245 !      include 'COMMON.LOCAL'
25246 !      include 'COMMON.CHAIN'
25247 !      include 'COMMON.DERIV'
25248 !      include 'COMMON.NAMES'
25249 !      include 'COMMON.INTERACT'
25250 !      include 'COMMON.IOUNITS'
25251 !      include 'COMMON.CALC'
25252 !      include 'COMMON.CONTROL'
25253 !      include 'COMMON.SBRIDGE'
25254       logical :: lprn
25255 !el local variables
25256       integer :: iint,itypi,itypi1,itypj,subchap
25257       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25258       real(kind=8) :: evdw,sig0ij
25259       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25260                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25261                     sslipi,sslipj,faclip
25262       integer :: ii
25263       real(kind=8) :: fracinbuf
25264        real (kind=8) :: epeppho
25265        real (kind=8),dimension(4):: ener
25266        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25267        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25268         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25269         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25270         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25271         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25272         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25273         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25274        real(kind=8),dimension(3,2)::chead,erhead_tail
25275        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25276        integer troll
25277        real (kind=8) :: dcosom1(3),dcosom2(3)
25278        epeppho=0.0d0
25279 !       do i=1,nres_molec(1)
25280         do i=ibond_start,ibond_end
25281         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25282         itypi  = itype(i,1)
25283         dsci_inv = vbld_inv(i+1)/2.0
25284         dxi    = dc_norm(1,i)
25285         dyi    = dc_norm(2,i)
25286         dzi    = dc_norm(3,i)
25287         xi=(c(1,i)+c(1,i+1))/2.0
25288         yi=(c(2,i)+c(2,i+1))/2.0
25289         zi=(c(3,i)+c(3,i+1))/2.0
25290         xi=mod(xi,boxxsize)
25291          if (xi.lt.0) xi=xi+boxxsize
25292         yi=mod(yi,boxysize)
25293          if (yi.lt.0) yi=yi+boxysize
25294         zi=mod(zi,boxzsize)
25295          if (zi.lt.0) zi=zi+boxzsize
25296          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25297            itypj= itype(j,2)
25298            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25299             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25300            xj=(c(1,j)+c(1,j+1))/2.0
25301            yj=(c(2,j)+c(2,j+1))/2.0
25302            zj=(c(3,j)+c(3,j+1))/2.0
25303            xj=dmod(xj,boxxsize)
25304            if (xj.lt.0) xj=xj+boxxsize
25305            yj=dmod(yj,boxysize)
25306            if (yj.lt.0) yj=yj+boxysize
25307            zj=dmod(zj,boxzsize)
25308            if (zj.lt.0) zj=zj+boxzsize
25309           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25310           xj_safe=xj
25311           yj_safe=yj
25312           zj_safe=zj
25313           subchap=0
25314           do xshift=-1,1
25315           do yshift=-1,1
25316           do zshift=-1,1
25317           xj=xj_safe+xshift*boxxsize
25318           yj=yj_safe+yshift*boxysize
25319           zj=zj_safe+zshift*boxzsize
25320           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25321           if(dist_temp.lt.dist_init) then
25322             dist_init=dist_temp
25323             xj_temp=xj
25324             yj_temp=yj
25325             zj_temp=zj
25326             subchap=1
25327           endif
25328           enddo
25329           enddo
25330           enddo
25331           if (subchap.eq.1) then
25332           xj=xj_temp-xi
25333           yj=yj_temp-yi
25334           zj=zj_temp-zi
25335           else
25336           xj=xj_safe-xi
25337           yj=yj_safe-yi
25338           zj=zj_safe-zi
25339           endif
25340           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25341           rij  = dsqrt(rrij)
25342           dxj = dc_norm( 1,j )
25343           dyj = dc_norm( 2,j )
25344           dzj = dc_norm( 3,j )
25345           dscj_inv = vbld_inv(j+1)/2.0
25346 ! Gay-berne var's
25347           sig0ij = sigma_peppho
25348 !          chi1=0.0d0
25349 !          chi2=0.0d0
25350           chi12  = chi1 * chi2
25351 !          chip1=0.0d0
25352 !          chip2=0.0d0
25353           chip12 = chip1 * chip2
25354 !          chis1 = 0.0d0
25355 !          chis2 = 0.0d0
25356           chis12 = chis1 * chis2
25357           sig1 = sigmap1_peppho
25358           sig2 = sigmap2_peppho
25359 !       write (*,*) "sig1 = ", sig1
25360 !       write (*,*) "sig1 = ", sig1
25361 !       write (*,*) "sig2 = ", sig2
25362 ! alpha factors from Fcav/Gcav
25363           alf1   = 0.0d0
25364           alf2   = 0.0d0
25365           alf12  = 0.0d0
25366           b1 = alphasur_peppho(1)
25367 !          b1=0.0d0
25368           b2 = alphasur_peppho(2)
25369           b3 = alphasur_peppho(3)
25370           b4 = alphasur_peppho(4)
25371           CALL sc_angular
25372        sqom1=om1*om1
25373        evdwij = 0.0d0
25374        ECL = 0.0d0
25375        Elj = 0.0d0
25376        Equad = 0.0d0
25377        Epol = 0.0d0
25378        Fcav=0.0d0
25379        eheadtail = 0.0d0
25380        dGCLdR=0.0d0
25381        dGCLdOM1 = 0.0d0
25382        dGCLdOM2 = 0.0d0
25383        dGCLdOM12 = 0.0d0
25384        dPOLdOM1 = 0.0d0
25385        dPOLdOM2 = 0.0d0
25386           Fcav = 0.0d0
25387           dFdR = 0.0d0
25388           dCAVdOM1  = 0.0d0
25389           dCAVdOM2  = 0.0d0
25390           dCAVdOM12 = 0.0d0
25391           rij_shift = rij
25392           fac       = rij_shift**expon
25393           c1        = fac  * fac * aa_peppho
25394 !          c1        = 0.0d0
25395           c2        = fac  * bb_peppho
25396 !          c2        = 0.0d0
25397           evdwij    =  c1 + c2
25398 ! Now cavity....................
25399        eagle = dsqrt(1.0/rij_shift)
25400        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25401           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25402           botsq = bot * bot
25403           Fcav = top / bot
25404           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25405           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25406           dFdR = ((dtop * bot - top * dbot) / botsq)
25407        w1        = wqdip_peppho(1)
25408        w2        = wqdip_peppho(2)
25409 !       w1=0.0d0
25410 !       w2=0.0d0
25411 !       pis       = sig0head_scbase(itypi,itypj)
25412 !       eps_head   = epshead_scbase(itypi,itypj)
25413 !c!-------------------------------------------------------------------
25414
25415 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25416 !c!     &        +dhead(1,1,itypi,itypj))**2))
25417 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25418 !c!     &        +dhead(2,1,itypi,itypj))**2))
25419
25420 !c!-------------------------------------------------------------------
25421 !c! ecl
25422        sparrow  = w1  *  om1
25423        hawk     = w2 *  (1.0d0 - sqom1)
25424        Ecl = sparrow * rij_shift**2.0d0 &
25425            - hawk    * rij_shift**4.0d0
25426 !c!-------------------------------------------------------------------
25427 !c! derivative of ecl is Gcl
25428 !c! dF/dr part
25429 !       rij_shift=5.0
25430        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25431                 + 4.0d0 * hawk    * rij_shift**5.0d0
25432 !c! dF/dom1
25433        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25434 !c! dF/dom2
25435        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25436        eom1  =    dGCLdOM1+dGCLdOM2
25437        eom2  =    0.0
25438
25439           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25440 !          fac=0.0
25441           gg(1) =  fac*xj*rij
25442           gg(2) =  fac*yj*rij
25443           gg(3) =  fac*zj*rij
25444          do k=1,3
25445          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25446          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25447          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25448          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25449          gg(k)=0.0
25450          enddo
25451
25452       DO k = 1, 3
25453         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25454         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25455         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25456         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25457 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25458         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25459 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25460         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25461                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25462         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25463                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25464         enddo
25465        epeppho=epeppho+evdwij+Fcav+ECL
25466 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25467        enddo
25468        enddo
25469       end subroutine eprot_pep_phosphate
25470 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25471       subroutine emomo(evdw)
25472       use calc_data
25473       use comm_momo
25474 !      implicit real*8 (a-h,o-z)
25475 !      include 'DIMENSIONS'
25476 !      include 'COMMON.GEO'
25477 !      include 'COMMON.VAR'
25478 !      include 'COMMON.LOCAL'
25479 !      include 'COMMON.CHAIN'
25480 !      include 'COMMON.DERIV'
25481 !      include 'COMMON.NAMES'
25482 !      include 'COMMON.INTERACT'
25483 !      include 'COMMON.IOUNITS'
25484 !      include 'COMMON.CALC'
25485 !      include 'COMMON.CONTROL'
25486 !      include 'COMMON.SBRIDGE'
25487       logical :: lprn
25488 !el local variables
25489       integer :: iint,itypi1,subchap,isel
25490       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25491       real(kind=8) :: evdw
25492       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25493                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25494                     sslipi,sslipj,faclip,alpha_sco
25495       integer :: ii
25496       real(kind=8) :: fracinbuf
25497        real (kind=8) :: escpho
25498        real (kind=8),dimension(4):: ener
25499        real(kind=8) :: b1,b2,egb
25500        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25501         Lambf,&
25502         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25503         dFdOM2,dFdL,dFdOM12,&
25504         federmaus,&
25505         d1i,d1j
25506 !       real(kind=8),dimension(3,2)::erhead_tail
25507 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25508        real(kind=8) ::  facd4, adler, Fgb, facd3
25509        integer troll,jj,istate
25510        real (kind=8) :: dcosom1(3),dcosom2(3)
25511        eps_out=80.0d0
25512        sss_ele_cut=1.0d0
25513 !       print *,"EVDW KURW",evdw,nres
25514       do i=iatsc_s,iatsc_e
25515 !        print *,"I am in EVDW",i
25516         itypi=iabs(itype(i,1))
25517 !        if (i.ne.47) cycle
25518         if (itypi.eq.ntyp1) cycle
25519         itypi1=iabs(itype(i+1,1))
25520         xi=c(1,nres+i)
25521         yi=c(2,nres+i)
25522         zi=c(3,nres+i)
25523           xi=dmod(xi,boxxsize)
25524           if (xi.lt.0) xi=xi+boxxsize
25525           yi=dmod(yi,boxysize)
25526           if (yi.lt.0) yi=yi+boxysize
25527           zi=dmod(zi,boxzsize)
25528           if (zi.lt.0) zi=zi+boxzsize
25529
25530        if ((zi.gt.bordlipbot)  &
25531         .and.(zi.lt.bordliptop)) then
25532 !C the energy transfer exist
25533         if (zi.lt.buflipbot) then
25534 !C what fraction I am in
25535          fracinbuf=1.0d0-  &
25536               ((zi-bordlipbot)/lipbufthick)
25537 !C lipbufthick is thickenes of lipid buffore
25538          sslipi=sscalelip(fracinbuf)
25539          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25540         elseif (zi.gt.bufliptop) then
25541          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25542          sslipi=sscalelip(fracinbuf)
25543          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25544         else
25545          sslipi=1.0d0
25546          ssgradlipi=0.0
25547         endif
25548        else
25549          sslipi=0.0d0
25550          ssgradlipi=0.0
25551        endif
25552 !       print *, sslipi,ssgradlipi
25553         dxi=dc_norm(1,nres+i)
25554         dyi=dc_norm(2,nres+i)
25555         dzi=dc_norm(3,nres+i)
25556 !        dsci_inv=dsc_inv(itypi)
25557         dsci_inv=vbld_inv(i+nres)
25558 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25559 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25560 !
25561 ! Calculate SC interaction energy.
25562 !
25563         do iint=1,nint_gr(i)
25564           do j=istart(i,iint),iend(i,iint)
25565 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25566             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25567               call dyn_ssbond_ene(i,j,evdwij)
25568               evdw=evdw+evdwij
25569               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25570                               'evdw',i,j,evdwij,' ss'
25571 !              if (energy_dec) write (iout,*) &
25572 !                              'evdw',i,j,evdwij,' ss'
25573              do k=j+1,iend(i,iint)
25574 !C search over all next residues
25575               if (dyn_ss_mask(k)) then
25576 !C check if they are cysteins
25577 !C              write(iout,*) 'k=',k
25578
25579 !c              write(iout,*) "PRZED TRI", evdwij
25580 !               evdwij_przed_tri=evdwij
25581               call triple_ssbond_ene(i,j,k,evdwij)
25582 !c               if(evdwij_przed_tri.ne.evdwij) then
25583 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25584 !c               endif
25585
25586 !c              write(iout,*) "PO TRI", evdwij
25587 !C call the energy function that removes the artifical triple disulfide
25588 !C bond the soubroutine is located in ssMD.F
25589               evdw=evdw+evdwij
25590               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25591                             'evdw',i,j,evdwij,'tss'
25592               endif!dyn_ss_mask(k)
25593              enddo! k
25594             ELSE
25595 !el            ind=ind+1
25596             itypj=iabs(itype(j,1))
25597             if (itypj.eq.ntyp1) cycle
25598              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25599
25600 !             if (j.ne.78) cycle
25601 !            dscj_inv=dsc_inv(itypj)
25602             dscj_inv=vbld_inv(j+nres)
25603            xj=c(1,j+nres)
25604            yj=c(2,j+nres)
25605            zj=c(3,j+nres)
25606            xj=dmod(xj,boxxsize)
25607            if (xj.lt.0) xj=xj+boxxsize
25608            yj=dmod(yj,boxysize)
25609            if (yj.lt.0) yj=yj+boxysize
25610            zj=dmod(zj,boxzsize)
25611            if (zj.lt.0) zj=zj+boxzsize
25612           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25613           xj_safe=xj
25614           yj_safe=yj
25615           zj_safe=zj
25616           subchap=0
25617
25618           do xshift=-1,1
25619           do yshift=-1,1
25620           do zshift=-1,1
25621           xj=xj_safe+xshift*boxxsize
25622           yj=yj_safe+yshift*boxysize
25623           zj=zj_safe+zshift*boxzsize
25624           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25625           if(dist_temp.lt.dist_init) then
25626             dist_init=dist_temp
25627             xj_temp=xj
25628             yj_temp=yj
25629             zj_temp=zj
25630             subchap=1
25631           endif
25632           enddo
25633           enddo
25634           enddo
25635           if (subchap.eq.1) then
25636           xj=xj_temp-xi
25637           yj=yj_temp-yi
25638           zj=zj_temp-zi
25639           else
25640           xj=xj_safe-xi
25641           yj=yj_safe-yi
25642           zj=zj_safe-zi
25643           endif
25644           dxj = dc_norm( 1, nres+j )
25645           dyj = dc_norm( 2, nres+j )
25646           dzj = dc_norm( 3, nres+j )
25647 !          print *,i,j,itypi,itypj
25648 !          d1i=0.0d0
25649 !          d1j=0.0d0
25650 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25651 ! Gay-berne var's
25652 !1!          sig0ij = sigma_scsc( itypi,itypj )
25653 !          chi1=0.0d0
25654 !          chi2=0.0d0
25655 !          chip1=0.0d0
25656 !          chip2=0.0d0
25657 ! not used by momo potential, but needed by sc_angular which is shared
25658 ! by all energy_potential subroutines
25659           alf1   = 0.0d0
25660           alf2   = 0.0d0
25661           alf12  = 0.0d0
25662           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25663 !       a12sq = a12sq * a12sq
25664 ! charge of amino acid itypi is...
25665           chis1 = chis(itypi,itypj)
25666           chis2 = chis(itypj,itypi)
25667           chis12 = chis1 * chis2
25668           sig1 = sigmap1(itypi,itypj)
25669           sig2 = sigmap2(itypi,itypj)
25670 !       write (*,*) "sig1 = ", sig1
25671 !          chis1=0.0
25672 !          chis2=0.0
25673 !                    chis12 = chis1 * chis2
25674 !          sig1=0.0
25675 !          sig2=0.0
25676 !       write (*,*) "sig2 = ", sig2
25677 ! alpha factors from Fcav/Gcav
25678           b1cav = alphasur(1,itypi,itypj)
25679 !          b1cav=0.0d0
25680           b2cav = alphasur(2,itypi,itypj)
25681           b3cav = alphasur(3,itypi,itypj)
25682           b4cav = alphasur(4,itypi,itypj)
25683 ! used to determine whether we want to do quadrupole calculations
25684        eps_in = epsintab(itypi,itypj)
25685        if (eps_in.eq.0.0) eps_in=1.0
25686
25687        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25688        Rtail = 0.0d0
25689 !       dtail(1,itypi,itypj)=0.0
25690 !       dtail(2,itypi,itypj)=0.0
25691
25692        DO k = 1, 3
25693         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25694         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25695        END DO
25696 !c! tail distances will be themselves usefull elswhere
25697 !c1 (in Gcav, for example)
25698        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25699        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25700        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25701        Rtail = dsqrt( &
25702           (Rtail_distance(1)*Rtail_distance(1)) &
25703         + (Rtail_distance(2)*Rtail_distance(2)) &
25704         + (Rtail_distance(3)*Rtail_distance(3)))
25705
25706 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25707 !-------------------------------------------------------------------
25708 ! tail location and distance calculations
25709        d1 = dhead(1, 1, itypi, itypj)
25710        d2 = dhead(2, 1, itypi, itypj)
25711
25712        DO k = 1,3
25713 ! location of polar head is computed by taking hydrophobic centre
25714 ! and moving by a d1 * dc_norm vector
25715 ! see unres publications for very informative images
25716         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25717         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25718 ! distance
25719 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25720 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25721         Rhead_distance(k) = chead(k,2) - chead(k,1)
25722        END DO
25723 ! pitagoras (root of sum of squares)
25724        Rhead = dsqrt( &
25725           (Rhead_distance(1)*Rhead_distance(1)) &
25726         + (Rhead_distance(2)*Rhead_distance(2)) &
25727         + (Rhead_distance(3)*Rhead_distance(3)))
25728 !-------------------------------------------------------------------
25729 ! zero everything that should be zero'ed
25730        evdwij = 0.0d0
25731        ECL = 0.0d0
25732        Elj = 0.0d0
25733        Equad = 0.0d0
25734        Epol = 0.0d0
25735        Fcav=0.0d0
25736        eheadtail = 0.0d0
25737        dGCLdOM1 = 0.0d0
25738        dGCLdOM2 = 0.0d0
25739        dGCLdOM12 = 0.0d0
25740        dPOLdOM1 = 0.0d0
25741        dPOLdOM2 = 0.0d0
25742           Fcav = 0.0d0
25743           dFdR = 0.0d0
25744           dCAVdOM1  = 0.0d0
25745           dCAVdOM2  = 0.0d0
25746           dCAVdOM12 = 0.0d0
25747           dscj_inv = vbld_inv(j+nres)
25748 !          print *,i,j,dscj_inv,dsci_inv
25749 ! rij holds 1/(distance of Calpha atoms)
25750           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25751           rij  = dsqrt(rrij)
25752 !----------------------------
25753           CALL sc_angular
25754 ! this should be in elgrad_init but om's are calculated by sc_angular
25755 ! which in turn is used by older potentials
25756 ! om = omega, sqom = om^2
25757           sqom1  = om1 * om1
25758           sqom2  = om2 * om2
25759           sqom12 = om12 * om12
25760
25761 ! now we calculate EGB - Gey-Berne
25762 ! It will be summed up in evdwij and saved in evdw
25763           sigsq     = 1.0D0  / sigsq
25764           sig       = sig0ij * dsqrt(sigsq)
25765 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25766           rij_shift = Rtail - sig + sig0ij
25767           IF (rij_shift.le.0.0D0) THEN
25768            evdw = 1.0D20
25769            RETURN
25770           END IF
25771           sigder = -sig * sigsq
25772           rij_shift = 1.0D0 / rij_shift
25773           fac       = rij_shift**expon
25774           c1        = fac  * fac * aa_aq(itypi,itypj)
25775 !          print *,"ADAM",aa_aq(itypi,itypj)
25776
25777 !          c1        = 0.0d0
25778           c2        = fac  * bb_aq(itypi,itypj)
25779 !          c2        = 0.0d0
25780           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25781           eps2der   = eps3rt * evdwij
25782           eps3der   = eps2rt * evdwij
25783 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25784           evdwij    = eps2rt * eps3rt * evdwij
25785 !#ifdef TSCSC
25786 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25787 !           evdw_p = evdw_p + evdwij
25788 !          ELSE
25789 !           evdw_m = evdw_m + evdwij
25790 !          END IF
25791 !#else
25792           evdw = evdw  &
25793               + evdwij
25794 !#endif
25795
25796           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25797           fac    = -expon * (c1 + evdwij) * rij_shift
25798           sigder = fac * sigder
25799 !          fac    = rij * fac
25800 ! Calculate distance derivative
25801           gg(1) =  fac
25802           gg(2) =  fac
25803           gg(3) =  fac
25804 !          if (b2.gt.0.0) then
25805           fac = chis1 * sqom1 + chis2 * sqom2 &
25806           - 2.0d0 * chis12 * om1 * om2 * om12
25807 ! we will use pom later in Gcav, so dont mess with it!
25808           pom = 1.0d0 - chis1 * chis2 * sqom12
25809           Lambf = (1.0d0 - (fac / pom))
25810 !          print *,"fac,pom",fac,pom,Lambf
25811           Lambf = dsqrt(Lambf)
25812           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25813 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25814 !       write (*,*) "sparrow = ", sparrow
25815           Chif = Rtail * sparrow
25816 !           print *,"rij,sparrow",rij , sparrow
25817           ChiLambf = Chif * Lambf
25818           eagle = dsqrt(ChiLambf)
25819           bat = ChiLambf ** 11.0d0
25820           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25821           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25822           botsq = bot * bot
25823 !          print *,top,bot,"bot,top",ChiLambf,Chif
25824           Fcav = top / bot
25825
25826        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25827        dbot = 12.0d0 * b4cav * bat * Lambf
25828        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25829
25830           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25831           dbot = 12.0d0 * b4cav * bat * Chif
25832           eagle = Lambf * pom
25833           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25834           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25835           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25836               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25837
25838           dFdL = ((dtop * bot - top * dbot) / botsq)
25839 !       dFdL = 0.0d0
25840           dCAVdOM1  = dFdL * ( dFdOM1 )
25841           dCAVdOM2  = dFdL * ( dFdOM2 )
25842           dCAVdOM12 = dFdL * ( dFdOM12 )
25843
25844        DO k= 1, 3
25845         ertail(k) = Rtail_distance(k)/Rtail
25846        END DO
25847        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25848        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25849        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25850        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25851        DO k = 1, 3
25852 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25853 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25854         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25855         gvdwx(k,i) = gvdwx(k,i) &
25856                   - (( dFdR + gg(k) ) * pom)
25857 !c!     &             - ( dFdR * pom )
25858         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25859         gvdwx(k,j) = gvdwx(k,j)   &
25860                   + (( dFdR + gg(k) ) * pom)
25861 !c!     &             + ( dFdR * pom )
25862
25863         gvdwc(k,i) = gvdwc(k,i)  &
25864                   - (( dFdR + gg(k) ) * ertail(k))
25865 !c!     &             - ( dFdR * ertail(k))
25866
25867         gvdwc(k,j) = gvdwc(k,j) &
25868                   + (( dFdR + gg(k) ) * ertail(k))
25869 !c!     &             + ( dFdR * ertail(k))
25870
25871         gg(k) = 0.0d0
25872 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25873 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25874       END DO
25875
25876
25877 !c! Compute head-head and head-tail energies for each state
25878
25879           isel = iabs(Qi) + iabs(Qj)
25880 ! double charge for Phophorylated! itype - 25,27,27
25881 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25882 !            Qi=Qi*2
25883 !            Qij=Qij*2
25884 !           endif
25885 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25886 !            Qj=Qj*2
25887 !            Qij=Qij*2
25888 !           endif
25889
25890 !          isel=0
25891           IF (isel.eq.0) THEN
25892 !c! No charges - do nothing
25893            eheadtail = 0.0d0
25894
25895           ELSE IF (isel.eq.4) THEN
25896 !c! Calculate dipole-dipole interactions
25897            CALL edd(ecl)
25898            eheadtail = ECL
25899 !           eheadtail = 0.0d0
25900
25901           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25902 !c! Charge-nonpolar interactions
25903           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25904             Qi=Qi*2
25905             Qij=Qij*2
25906            endif
25907           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25908             Qj=Qj*2
25909             Qij=Qij*2
25910            endif
25911
25912            CALL eqn(epol)
25913            eheadtail = epol
25914 !           eheadtail = 0.0d0
25915
25916           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25917 !c! Nonpolar-charge interactions
25918           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25919             Qi=Qi*2
25920             Qij=Qij*2
25921            endif
25922           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25923             Qj=Qj*2
25924             Qij=Qij*2
25925            endif
25926
25927            CALL enq(epol)
25928            eheadtail = epol
25929 !           eheadtail = 0.0d0
25930
25931           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25932 !c! Charge-dipole interactions
25933           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25934             Qi=Qi*2
25935             Qij=Qij*2
25936            endif
25937           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25938             Qj=Qj*2
25939             Qij=Qij*2
25940            endif
25941
25942            CALL eqd(ecl, elj, epol)
25943            eheadtail = ECL + elj + epol
25944 !           eheadtail = 0.0d0
25945
25946           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25947 !c! Dipole-charge interactions
25948           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25949             Qi=Qi*2
25950             Qij=Qij*2
25951            endif
25952           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25953             Qj=Qj*2
25954             Qij=Qij*2
25955            endif
25956            CALL edq(ecl, elj, epol)
25957           eheadtail = ECL + elj + epol
25958 !           eheadtail = 0.0d0
25959
25960           ELSE IF ((isel.eq.2.and.   &
25961                iabs(Qi).eq.1).and.  &
25962                nstate(itypi,itypj).eq.1) THEN
25963 !c! Same charge-charge interaction ( +/+ or -/- )
25964           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25965             Qi=Qi*2
25966             Qij=Qij*2
25967            endif
25968           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25969             Qj=Qj*2
25970             Qij=Qij*2
25971            endif
25972
25973            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25974            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25975 !           eheadtail = 0.0d0
25976
25977           ELSE IF ((isel.eq.2.and.  &
25978                iabs(Qi).eq.1).and. &
25979                nstate(itypi,itypj).ne.1) THEN
25980 !c! Different charge-charge interaction ( +/- or -/+ )
25981           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25982             Qi=Qi*2
25983             Qij=Qij*2
25984            endif
25985           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25986             Qj=Qj*2
25987             Qij=Qij*2
25988            endif
25989
25990            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25991           END IF
25992        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25993       evdw = evdw  + Fcav + eheadtail
25994
25995        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25996         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25997         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25998         Equad,evdwij+Fcav+eheadtail,evdw
25999 !       evdw = evdw  + Fcav  + eheadtail
26000
26001         iF (nstate(itypi,itypj).eq.1) THEN
26002         CALL sc_grad
26003        END IF
26004 !c!-------------------------------------------------------------------
26005 !c! NAPISY KONCOWE
26006          END DO   ! j
26007         END DO    ! iint
26008        END DO     ! i
26009 !c      write (iout,*) "Number of loop steps in EGB:",ind
26010 !c      energy_dec=.false.
26011 !              print *,"EVDW KURW",evdw,nres
26012
26013        RETURN
26014       END SUBROUTINE emomo
26015 !C------------------------------------------------------------------------------------
26016       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26017       use calc_data
26018       use comm_momo
26019        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26020          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26021 !       integer :: k
26022 !c! Epol and Gpol analytical parameters
26023        alphapol1 = alphapol(itypi,itypj)
26024        alphapol2 = alphapol(itypj,itypi)
26025 !c! Fisocav and Gisocav analytical parameters
26026        al1  = alphiso(1,itypi,itypj)
26027        al2  = alphiso(2,itypi,itypj)
26028        al3  = alphiso(3,itypi,itypj)
26029        al4  = alphiso(4,itypi,itypj)
26030        csig = (1.0d0  &
26031            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26032            + sigiso2(itypi,itypj)**2.0d0))
26033 !c!
26034        pis  = sig0head(itypi,itypj)
26035        eps_head = epshead(itypi,itypj)
26036        Rhead_sq = Rhead * Rhead
26037 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26038 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26039        R1 = 0.0d0
26040        R2 = 0.0d0
26041        DO k = 1, 3
26042 !c! Calculate head-to-tail distances needed by Epol
26043         R1=R1+(ctail(k,2)-chead(k,1))**2
26044         R2=R2+(chead(k,2)-ctail(k,1))**2
26045        END DO
26046 !c! Pitagoras
26047        R1 = dsqrt(R1)
26048        R2 = dsqrt(R2)
26049
26050 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26051 !c!     &        +dhead(1,1,itypi,itypj))**2))
26052 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26053 !c!     &        +dhead(2,1,itypi,itypj))**2))
26054
26055 !c!-------------------------------------------------------------------
26056 !c! Coulomb electrostatic interaction
26057        Ecl = (332.0d0 * Qij) / Rhead
26058 !c! derivative of Ecl is Gcl...
26059        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26060        dGCLdOM1 = 0.0d0
26061        dGCLdOM2 = 0.0d0
26062        dGCLdOM12 = 0.0d0
26063        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26064        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26065        debkap=debaykap(itypi,itypj)
26066        Egb = -(332.0d0 * Qij *&
26067         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26068 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26069 !c! Derivative of Egb is Ggb...
26070        dGGBdFGB = -(-332.0d0 * Qij * &
26071        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26072        -(332.0d0 * Qij *&
26073         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26074        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26075        dGGBdR = dGGBdFGB * dFGBdR
26076 !c!-------------------------------------------------------------------
26077 !c! Fisocav - isotropic cavity creation term
26078 !c! or "how much energy it costs to put charged head in water"
26079        pom = Rhead * csig
26080        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26081        bot = (1.0d0 + al4 * pom**12.0d0)
26082        botsq = bot * bot
26083        FisoCav = top / bot
26084 !      write (*,*) "Rhead = ",Rhead
26085 !      write (*,*) "csig = ",csig
26086 !      write (*,*) "pom = ",pom
26087 !      write (*,*) "al1 = ",al1
26088 !      write (*,*) "al2 = ",al2
26089 !      write (*,*) "al3 = ",al3
26090 !      write (*,*) "al4 = ",al4
26091 !        write (*,*) "top = ",top
26092 !        write (*,*) "bot = ",bot
26093 !c! Derivative of Fisocav is GCV...
26094        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26095        dbot = 12.0d0 * al4 * pom ** 11.0d0
26096        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26097 !c!-------------------------------------------------------------------
26098 !c! Epol
26099 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26100        MomoFac1 = (1.0d0 - chi1 * sqom2)
26101        MomoFac2 = (1.0d0 - chi2 * sqom1)
26102        RR1  = ( R1 * R1 ) / MomoFac1
26103        RR2  = ( R2 * R2 ) / MomoFac2
26104        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26105        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26106        fgb1 = sqrt( RR1 + a12sq * ee1 )
26107        fgb2 = sqrt( RR2 + a12sq * ee2 )
26108        epol = 332.0d0 * eps_inout_fac * ( &
26109       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26110 !c!       epol = 0.0d0
26111        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26112                / (fgb1 ** 5.0d0)
26113        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26114                / (fgb2 ** 5.0d0)
26115        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26116              / ( 2.0d0 * fgb1 )
26117        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26118              / ( 2.0d0 * fgb2 )
26119        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26120                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26121        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26122                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26123        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26124 !c!       dPOLdR1 = 0.0d0
26125        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26126 !c!       dPOLdR2 = 0.0d0
26127        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26128 !c!       dPOLdOM1 = 0.0d0
26129        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26130 !c!       dPOLdOM2 = 0.0d0
26131 !c!-------------------------------------------------------------------
26132 !c! Elj
26133 !c! Lennard-Jones 6-12 interaction between heads
26134        pom = (pis / Rhead)**6.0d0
26135        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26136 !c! derivative of Elj is Glj
26137        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26138              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26139 !c!-------------------------------------------------------------------
26140 !c! Return the results
26141 !c! These things do the dRdX derivatives, that is
26142 !c! allow us to change what we see from function that changes with
26143 !c! distance to function that changes with LOCATION (of the interaction
26144 !c! site)
26145        DO k = 1, 3
26146         erhead(k) = Rhead_distance(k)/Rhead
26147         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26148         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26149        END DO
26150
26151        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26152        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26153        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26154        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26155        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26156        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26157        facd1 = d1 * vbld_inv(i+nres)
26158        facd2 = d2 * vbld_inv(j+nres)
26159        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26160        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26161
26162 !c! Now we add appropriate partial derivatives (one in each dimension)
26163        DO k = 1, 3
26164         hawk   = (erhead_tail(k,1) + &
26165         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26166         condor = (erhead_tail(k,2) + &
26167         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26168
26169         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26170         gvdwx(k,i) = gvdwx(k,i) &
26171                   - dGCLdR * pom&
26172                   - dGGBdR * pom&
26173                   - dGCVdR * pom&
26174                   - dPOLdR1 * hawk&
26175                   - dPOLdR2 * (erhead_tail(k,2)&
26176       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26177                   - dGLJdR * pom
26178
26179         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26180         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26181                    + dGGBdR * pom+ dGCVdR * pom&
26182                   + dPOLdR1 * (erhead_tail(k,1)&
26183       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26184                   + dPOLdR2 * condor + dGLJdR * pom
26185
26186         gvdwc(k,i) = gvdwc(k,i)  &
26187                   - dGCLdR * erhead(k)&
26188                   - dGGBdR * erhead(k)&
26189                   - dGCVdR * erhead(k)&
26190                   - dPOLdR1 * erhead_tail(k,1)&
26191                   - dPOLdR2 * erhead_tail(k,2)&
26192                   - dGLJdR * erhead(k)
26193
26194         gvdwc(k,j) = gvdwc(k,j)         &
26195                   + dGCLdR * erhead(k) &
26196                   + dGGBdR * erhead(k) &
26197                   + dGCVdR * erhead(k) &
26198                   + dPOLdR1 * erhead_tail(k,1) &
26199                   + dPOLdR2 * erhead_tail(k,2)&
26200                   + dGLJdR * erhead(k)
26201
26202        END DO
26203        RETURN
26204       END SUBROUTINE eqq
26205
26206       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26207       use calc_data
26208       use comm_momo
26209        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26210          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26211 !       integer :: k
26212 !c! Epol and Gpol analytical parameters
26213        alphapol1 = alphapolcat(itypi,itypj)
26214        alphapol2 = alphapolcat(itypj,itypi)
26215 !c! Fisocav and Gisocav analytical parameters
26216        al1  = alphisocat(1,itypi,itypj)
26217        al2  = alphisocat(2,itypi,itypj)
26218        al3  = alphisocat(3,itypi,itypj)
26219        al4  = alphisocat(4,itypi,itypj)
26220        csig = (1.0d0  &
26221            / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26222            + sigiso2cat(itypi,itypj)**2.0d0))
26223 !c!
26224        pis  = sig0headcat(itypi,itypj)
26225        eps_head = epsheadcat(itypi,itypj)
26226        Rhead_sq = Rhead * Rhead
26227 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26228 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26229        R1 = 0.0d0
26230        R2 = 0.0d0
26231        DO k = 1, 3
26232 !c! Calculate head-to-tail distances needed by Epol
26233         R1=R1+(ctail(k,2)-chead(k,1))**2
26234         R2=R2+(chead(k,2)-ctail(k,1))**2
26235        END DO
26236 !c! Pitagoras
26237        R1 = dsqrt(R1)
26238        R2 = dsqrt(R2)
26239
26240 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26241 !c!     &        +dhead(1,1,itypi,itypj))**2))
26242 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26243 !c!     &        +dhead(2,1,itypi,itypj))**2))
26244
26245 !c!-------------------------------------------------------------------
26246 !c! Coulomb electrostatic interaction
26247        Ecl = (332.0d0 * Qij) / Rhead
26248 !c! derivative of Ecl is Gcl...
26249        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26250        dGCLdOM1 = 0.0d0
26251        dGCLdOM2 = 0.0d0
26252        dGCLdOM12 = 0.0d0
26253        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26254        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26255        debkap=debaykapcat(itypi,itypj)
26256        Egb = -(332.0d0 * Qij *&
26257         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26258 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26259 !c! Derivative of Egb is Ggb...
26260        dGGBdFGB = -(-332.0d0 * Qij * &
26261        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26262        -(332.0d0 * Qij *&
26263         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26264        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26265        dGGBdR = dGGBdFGB * dFGBdR
26266 !c!-------------------------------------------------------------------
26267 !c! Fisocav - isotropic cavity creation term
26268 !c! or "how much energy it costs to put charged head in water"
26269        pom = Rhead * csig
26270        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26271        bot = (1.0d0 + al4 * pom**12.0d0)
26272        botsq = bot * bot
26273        FisoCav = top / bot
26274 !      write (*,*) "Rhead = ",Rhead
26275 !      write (*,*) "csig = ",csig
26276 !      write (*,*) "pom = ",pom
26277 !      write (*,*) "al1 = ",al1
26278 !      write (*,*) "al2 = ",al2
26279 !      write (*,*) "al3 = ",al3
26280 !      write (*,*) "al4 = ",al4
26281 !        write (*,*) "top = ",top
26282 !        write (*,*) "bot = ",bot
26283 !c! Derivative of Fisocav is GCV...
26284        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26285        dbot = 12.0d0 * al4 * pom ** 11.0d0
26286        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26287 !c!-------------------------------------------------------------------
26288 !c! Epol
26289 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26290        MomoFac1 = (1.0d0 - chi1 * sqom2)
26291        MomoFac2 = (1.0d0 - chi2 * sqom1)
26292        RR1  = ( R1 * R1 ) / MomoFac1
26293        RR2  = ( R2 * R2 ) / MomoFac2
26294        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26295        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26296        fgb1 = sqrt( RR1 + a12sq * ee1 )
26297        fgb2 = sqrt( RR2 + a12sq * ee2 )
26298        epol = 332.0d0 * eps_inout_fac * ( &
26299       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26300 !c!       epol = 0.0d0
26301        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26302                / (fgb1 ** 5.0d0)
26303        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26304                / (fgb2 ** 5.0d0)
26305        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26306              / ( 2.0d0 * fgb1 )
26307        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26308              / ( 2.0d0 * fgb2 )
26309        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26310                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26311        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26312                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26313        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26314 !c!       dPOLdR1 = 0.0d0
26315        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26316 !c!       dPOLdR2 = 0.0d0
26317        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26318 !c!       dPOLdOM1 = 0.0d0
26319        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26320 !c!       dPOLdOM2 = 0.0d0
26321 !c!-------------------------------------------------------------------
26322 !c! Elj
26323 !c! Lennard-Jones 6-12 interaction between heads
26324        pom = (pis / Rhead)**6.0d0
26325        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26326 !c! derivative of Elj is Glj
26327        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26328              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26329 !c!-------------------------------------------------------------------
26330 !c! Return the results
26331 !c! These things do the dRdX derivatives, that is
26332 !c! allow us to change what we see from function that changes with
26333 !c! distance to function that changes with LOCATION (of the interaction
26334 !c! site)
26335        DO k = 1, 3
26336         erhead(k) = Rhead_distance(k)/Rhead
26337         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26338         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26339        END DO
26340
26341        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26342        erdxj = scalar( erhead(1), dC_norm(1,j) )
26343        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26344        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26345        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26346        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26347        facd1 = d1 * vbld_inv(i+nres)
26348        facd2 = d2 * vbld_inv(j)
26349        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26350        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26351
26352 !c! Now we add appropriate partial derivatives (one in each dimension)
26353        DO k = 1, 3
26354         hawk   = (erhead_tail(k,1) + &
26355         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26356         condor = (erhead_tail(k,2) + &
26357         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26358
26359         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26360         gradpepcatx(k,i) = gradpepcatx(k,i) &
26361                   - dGCLdR * pom&
26362                   - dGGBdR * pom&
26363                   - dGCVdR * pom&
26364                   - dPOLdR1 * hawk&
26365                   - dPOLdR2 * (erhead_tail(k,2)&
26366       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26367                   - dGLJdR * pom
26368
26369         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26370         gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26371                    + dGGBdR * pom+ dGCVdR * pom&
26372                   + dPOLdR1 * (erhead_tail(k,1)&
26373       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26374                   + dPOLdR2 * condor + dGLJdR * pom
26375
26376         gradpepcat(k,i) = gradpepcat(k,i)  &
26377                   - dGCLdR * erhead(k)&
26378                   - dGGBdR * erhead(k)&
26379                   - dGCVdR * erhead(k)&
26380                   - dPOLdR1 * erhead_tail(k,1)&
26381                   - dPOLdR2 * erhead_tail(k,2)&
26382                   - dGLJdR * erhead(k)
26383
26384         gradpepcat(k,j) = gradpepcat(k,j)         &
26385                   + dGCLdR * erhead(k) &
26386                   + dGGBdR * erhead(k) &
26387                   + dGCVdR * erhead(k) &
26388                   + dPOLdR1 * erhead_tail(k,1) &
26389                   + dPOLdR2 * erhead_tail(k,2)&
26390                   + dGLJdR * erhead(k)
26391
26392        END DO
26393        RETURN
26394       END SUBROUTINE eqq_cat
26395 !c!-------------------------------------------------------------------
26396       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26397       use comm_momo
26398       use calc_data
26399
26400        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26401        double precision ener(4)
26402        double precision dcosom1(3),dcosom2(3)
26403 !c! used in Epol derivatives
26404        double precision facd3, facd4
26405        double precision federmaus, adler
26406        integer istate,ii,jj
26407        real (kind=8) :: Fgb
26408 !       print *,"CALLING EQUAD"
26409 !c! Epol and Gpol analytical parameters
26410        alphapol1 = alphapol(itypi,itypj)
26411        alphapol2 = alphapol(itypj,itypi)
26412 !c! Fisocav and Gisocav analytical parameters
26413        al1  = alphiso(1,itypi,itypj)
26414        al2  = alphiso(2,itypi,itypj)
26415        al3  = alphiso(3,itypi,itypj)
26416        al4  = alphiso(4,itypi,itypj)
26417        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26418             + sigiso2(itypi,itypj)**2.0d0))
26419 !c!
26420        w1   = wqdip(1,itypi,itypj)
26421        w2   = wqdip(2,itypi,itypj)
26422        pis  = sig0head(itypi,itypj)
26423        eps_head = epshead(itypi,itypj)
26424 !c! First things first:
26425 !c! We need to do sc_grad's job with GB and Fcav
26426        eom1  = eps2der * eps2rt_om1 &
26427              - 2.0D0 * alf1 * eps3der&
26428              + sigder * sigsq_om1&
26429              + dCAVdOM1
26430        eom2  = eps2der * eps2rt_om2 &
26431              + 2.0D0 * alf2 * eps3der&
26432              + sigder * sigsq_om2&
26433              + dCAVdOM2
26434        eom12 =  evdwij  * eps1_om12 &
26435              + eps2der * eps2rt_om12 &
26436              - 2.0D0 * alf12 * eps3der&
26437              + sigder *sigsq_om12&
26438              + dCAVdOM12
26439 !c! now some magical transformations to project gradient into
26440 !c! three cartesian vectors
26441        DO k = 1, 3
26442         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26443         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26444         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26445 !c! this acts on hydrophobic center of interaction
26446         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26447                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26448                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26449         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26450                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26451                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26452 !c! this acts on Calpha
26453         gvdwc(k,i)=gvdwc(k,i)-gg(k)
26454         gvdwc(k,j)=gvdwc(k,j)+gg(k)
26455        END DO
26456 !c! sc_grad is done, now we will compute
26457        eheadtail = 0.0d0
26458        eom1 = 0.0d0
26459        eom2 = 0.0d0
26460        eom12 = 0.0d0
26461        DO istate = 1, nstate(itypi,itypj)
26462 !c*************************************************************
26463         IF (istate.ne.1) THEN
26464          IF (istate.lt.3) THEN
26465           ii = 1
26466          ELSE
26467           ii = 2
26468          END IF
26469         jj = istate/ii
26470         d1 = dhead(1,ii,itypi,itypj)
26471         d2 = dhead(2,jj,itypi,itypj)
26472         DO k = 1,3
26473          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26474          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26475          Rhead_distance(k) = chead(k,2) - chead(k,1)
26476         END DO
26477 !c! pitagoras (root of sum of squares)
26478         Rhead = dsqrt( &
26479                (Rhead_distance(1)*Rhead_distance(1))  &
26480              + (Rhead_distance(2)*Rhead_distance(2))  &
26481              + (Rhead_distance(3)*Rhead_distance(3)))
26482         END IF
26483         Rhead_sq = Rhead * Rhead
26484
26485 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26486 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26487         R1 = 0.0d0
26488         R2 = 0.0d0
26489         DO k = 1, 3
26490 !c! Calculate head-to-tail distances
26491          R1=R1+(ctail(k,2)-chead(k,1))**2
26492          R2=R2+(chead(k,2)-ctail(k,1))**2
26493         END DO
26494 !c! Pitagoras
26495         R1 = dsqrt(R1)
26496         R2 = dsqrt(R2)
26497         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26498 !c!        Ecl = 0.0d0
26499 !c!        write (*,*) "Ecl = ", Ecl
26500 !c! derivative of Ecl is Gcl...
26501         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26502 !c!        dGCLdR = 0.0d0
26503         dGCLdOM1 = 0.0d0
26504         dGCLdOM2 = 0.0d0
26505         dGCLdOM12 = 0.0d0
26506 !c!-------------------------------------------------------------------
26507 !c! Generalised Born Solvent Polarization
26508         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26509         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26510         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26511 !c!        Egb = 0.0d0
26512 !c!      write (*,*) "a1*a2 = ", a12sq
26513 !c!      write (*,*) "Rhead = ", Rhead
26514 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26515 !c!      write (*,*) "ee = ", ee
26516 !c!      write (*,*) "Fgb = ", Fgb
26517 !c!      write (*,*) "fac = ", eps_inout_fac
26518 !c!      write (*,*) "Qij = ", Qij
26519 !c!      write (*,*) "Egb = ", Egb
26520 !c! Derivative of Egb is Ggb...
26521 !c! dFGBdR is used by Quad's later...
26522         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26523         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26524                / ( 2.0d0 * Fgb )
26525         dGGBdR = dGGBdFGB * dFGBdR
26526 !c!        dGGBdR = 0.0d0
26527 !c!-------------------------------------------------------------------
26528 !c! Fisocav - isotropic cavity creation term
26529         pom = Rhead * csig
26530         top = al1 * (dsqrt(pom) + al2 * pom - al3)
26531         bot = (1.0d0 + al4 * pom**12.0d0)
26532         botsq = bot * bot
26533         FisoCav = top / bot
26534         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26535         dbot = 12.0d0 * al4 * pom ** 11.0d0
26536         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26537 !c!        dGCVdR = 0.0d0
26538 !c!-------------------------------------------------------------------
26539 !c! Polarization energy
26540 !c! Epol
26541         MomoFac1 = (1.0d0 - chi1 * sqom2)
26542         MomoFac2 = (1.0d0 - chi2 * sqom1)
26543         RR1  = ( R1 * R1 ) / MomoFac1
26544         RR2  = ( R2 * R2 ) / MomoFac2
26545         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26546         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26547         fgb1 = sqrt( RR1 + a12sq * ee1 )
26548         fgb2 = sqrt( RR2 + a12sq * ee2 )
26549         epol = 332.0d0 * eps_inout_fac * (&
26550         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26551 !c!        epol = 0.0d0
26552 !c! derivative of Epol is Gpol...
26553         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26554                   / (fgb1 ** 5.0d0)
26555         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26556                   / (fgb2 ** 5.0d0)
26557         dFGBdR1 = ( (R1 / MomoFac1) &
26558                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
26559                 / ( 2.0d0 * fgb1 )
26560         dFGBdR2 = ( (R2 / MomoFac2) &
26561                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26562                 / ( 2.0d0 * fgb2 )
26563         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26564                  * ( 2.0d0 - 0.5d0 * ee1) ) &
26565                  / ( 2.0d0 * fgb1 )
26566         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26567                  * ( 2.0d0 - 0.5d0 * ee2) ) &
26568                  / ( 2.0d0 * fgb2 )
26569         dPOLdR1 = dPOLdFGB1 * dFGBdR1
26570 !c!        dPOLdR1 = 0.0d0
26571         dPOLdR2 = dPOLdFGB2 * dFGBdR2
26572 !c!        dPOLdR2 = 0.0d0
26573         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26574 !c!        dPOLdOM1 = 0.0d0
26575         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26576         pom = (pis / Rhead)**6.0d0
26577         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26578 !c!        Elj = 0.0d0
26579 !c! derivative of Elj is Glj
26580         dGLJdR = 4.0d0 * eps_head &
26581             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26582             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26583 !c!        dGLJdR = 0.0d0
26584 !c!-------------------------------------------------------------------
26585 !c! Equad
26586        IF (Wqd.ne.0.0d0) THEN
26587         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26588              - 37.5d0  * ( sqom1 + sqom2 ) &
26589              + 157.5d0 * ( sqom1 * sqom2 ) &
26590              - 45.0d0  * om1*om2*om12
26591         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26592         Equad = fac * Beta1
26593 !c!        Equad = 0.0d0
26594 !c! derivative of Equad...
26595         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26596 !c!        dQUADdR = 0.0d0
26597         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26598 !c!        dQUADdOM1 = 0.0d0
26599         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26600 !c!        dQUADdOM2 = 0.0d0
26601         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26602        ELSE
26603          Beta1 = 0.0d0
26604          Equad = 0.0d0
26605         END IF
26606 !c!-------------------------------------------------------------------
26607 !c! Return the results
26608 !c! Angular stuff
26609         eom1 = dPOLdOM1 + dQUADdOM1
26610         eom2 = dPOLdOM2 + dQUADdOM2
26611         eom12 = dQUADdOM12
26612 !c! now some magical transformations to project gradient into
26613 !c! three cartesian vectors
26614         DO k = 1, 3
26615          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26616          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26617          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26618         END DO
26619 !c! Radial stuff
26620         DO k = 1, 3
26621          erhead(k) = Rhead_distance(k)/Rhead
26622          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26623          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26624         END DO
26625         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26626         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26627         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26628         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26629         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26630         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26631         facd1 = d1 * vbld_inv(i+nres)
26632         facd2 = d2 * vbld_inv(j+nres)
26633         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26634         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26635         DO k = 1, 3
26636          hawk   = erhead_tail(k,1) + &
26637          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26638          condor = erhead_tail(k,2) + &
26639          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26640
26641          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26642 !c! this acts on hydrophobic center of interaction
26643          gheadtail(k,1,1) = gheadtail(k,1,1) &
26644                          - dGCLdR * pom &
26645                          - dGGBdR * pom &
26646                          - dGCVdR * pom &
26647                          - dPOLdR1 * hawk &
26648                          - dPOLdR2 * (erhead_tail(k,2) &
26649       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26650                          - dGLJdR * pom &
26651                          - dQUADdR * pom&
26652                          - tuna(k) &
26653                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26654                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26655
26656          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26657 !c! this acts on hydrophobic center of interaction
26658          gheadtail(k,2,1) = gheadtail(k,2,1)  &
26659                          + dGCLdR * pom      &
26660                          + dGGBdR * pom      &
26661                          + dGCVdR * pom      &
26662                          + dPOLdR1 * (erhead_tail(k,1) &
26663       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26664                          + dPOLdR2 * condor &
26665                          + dGLJdR * pom &
26666                          + dQUADdR * pom &
26667                          + tuna(k) &
26668                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26669                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26670
26671 !c! this acts on Calpha
26672          gheadtail(k,3,1) = gheadtail(k,3,1)  &
26673                          - dGCLdR * erhead(k)&
26674                          - dGGBdR * erhead(k)&
26675                          - dGCVdR * erhead(k)&
26676                          - dPOLdR1 * erhead_tail(k,1)&
26677                          - dPOLdR2 * erhead_tail(k,2)&
26678                          - dGLJdR * erhead(k) &
26679                          - dQUADdR * erhead(k)&
26680                          - tuna(k)
26681 !c! this acts on Calpha
26682          gheadtail(k,4,1) = gheadtail(k,4,1)   &
26683                           + dGCLdR * erhead(k) &
26684                           + dGGBdR * erhead(k) &
26685                           + dGCVdR * erhead(k) &
26686                           + dPOLdR1 * erhead_tail(k,1) &
26687                           + dPOLdR2 * erhead_tail(k,2) &
26688                           + dGLJdR * erhead(k) &
26689                           + dQUADdR * erhead(k)&
26690                           + tuna(k)
26691         END DO
26692         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26693         eheadtail = eheadtail &
26694                   + wstate(istate, itypi, itypj) &
26695                   * dexp(-betaT * ener(istate))
26696 !c! foreach cartesian dimension
26697         DO k = 1, 3
26698 !c! foreach of two gvdwx and gvdwc
26699          DO l = 1, 4
26700           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26701                            + wstate( istate, itypi, itypj ) &
26702                            * dexp(-betaT * ener(istate)) &
26703                            * gheadtail(k,l,1)
26704           gheadtail(k,l,1) = 0.0d0
26705          END DO
26706         END DO
26707        END DO
26708 !c! Here ended the gigantic DO istate = 1, 4, which starts
26709 !c! at the beggining of the subroutine
26710
26711        DO k = 1, 3
26712         DO l = 1, 4
26713          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26714         END DO
26715         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26716         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26717         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26718         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26719         DO l = 1, 4
26720          gheadtail(k,l,1) = 0.0d0
26721          gheadtail(k,l,2) = 0.0d0
26722         END DO
26723        END DO
26724        eheadtail = (-dlog(eheadtail)) / betaT
26725        dPOLdOM1 = 0.0d0
26726        dPOLdOM2 = 0.0d0
26727        dQUADdOM1 = 0.0d0
26728        dQUADdOM2 = 0.0d0
26729        dQUADdOM12 = 0.0d0
26730        RETURN
26731       END SUBROUTINE energy_quad
26732 !!-----------------------------------------------------------
26733       SUBROUTINE eqn(Epol)
26734       use comm_momo
26735       use calc_data
26736
26737       double precision  facd4, federmaus,epol
26738       alphapol1 = alphapol(itypi,itypj)
26739 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26740        R1 = 0.0d0
26741        DO k = 1, 3
26742 !c! Calculate head-to-tail distances
26743         R1=R1+(ctail(k,2)-chead(k,1))**2
26744        END DO
26745 !c! Pitagoras
26746        R1 = dsqrt(R1)
26747
26748 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26749 !c!     &        +dhead(1,1,itypi,itypj))**2))
26750 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26751 !c!     &        +dhead(2,1,itypi,itypj))**2))
26752 !c--------------------------------------------------------------------
26753 !c Polarization energy
26754 !c Epol
26755        MomoFac1 = (1.0d0 - chi1 * sqom2)
26756        RR1  = R1 * R1 / MomoFac1
26757        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26758        fgb1 = sqrt( RR1 + a12sq * ee1)
26759        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26760        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26761                / (fgb1 ** 5.0d0)
26762        dFGBdR1 = ( (R1 / MomoFac1) &
26763               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26764               / ( 2.0d0 * fgb1 )
26765        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26766                 * (2.0d0 - 0.5d0 * ee1) ) &
26767                 / (2.0d0 * fgb1)
26768        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26769 !c!       dPOLdR1 = 0.0d0
26770        dPOLdOM1 = 0.0d0
26771        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26772        DO k = 1, 3
26773         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26774        END DO
26775        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26776        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26777        facd1 = d1 * vbld_inv(i+nres)
26778        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26779
26780        DO k = 1, 3
26781         hawk = (erhead_tail(k,1) + &
26782         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26783
26784         gvdwx(k,i) = gvdwx(k,i) &
26785                    - dPOLdR1 * hawk
26786         gvdwx(k,j) = gvdwx(k,j) &
26787                    + dPOLdR1 * (erhead_tail(k,1) &
26788        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26789
26790         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26791         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26792
26793        END DO
26794        RETURN
26795       END SUBROUTINE eqn
26796       SUBROUTINE enq(Epol)
26797       use calc_data
26798       use comm_momo
26799        double precision facd3, adler,epol
26800        alphapol2 = alphapol(itypj,itypi)
26801 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26802        R2 = 0.0d0
26803        DO k = 1, 3
26804 !c! Calculate head-to-tail distances
26805         R2=R2+(chead(k,2)-ctail(k,1))**2
26806        END DO
26807 !c! Pitagoras
26808        R2 = dsqrt(R2)
26809
26810 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26811 !c!     &        +dhead(1,1,itypi,itypj))**2))
26812 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26813 !c!     &        +dhead(2,1,itypi,itypj))**2))
26814 !c------------------------------------------------------------------------
26815 !c Polarization energy
26816        MomoFac2 = (1.0d0 - chi2 * sqom1)
26817        RR2  = R2 * R2 / MomoFac2
26818        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26819        fgb2 = sqrt(RR2  + a12sq * ee2)
26820        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26821        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26822                 / (fgb2 ** 5.0d0)
26823        dFGBdR2 = ( (R2 / MomoFac2)  &
26824               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26825               / (2.0d0 * fgb2)
26826        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26827                 * (2.0d0 - 0.5d0 * ee2) ) &
26828                 / (2.0d0 * fgb2)
26829        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26830 !c!       dPOLdR2 = 0.0d0
26831        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26832 !c!       dPOLdOM1 = 0.0d0
26833        dPOLdOM2 = 0.0d0
26834 !c!-------------------------------------------------------------------
26835 !c! Return the results
26836 !c! (See comments in Eqq)
26837        DO k = 1, 3
26838         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26839        END DO
26840        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26841        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26842        facd2 = d2 * vbld_inv(j+nres)
26843        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26844        DO k = 1, 3
26845         condor = (erhead_tail(k,2) &
26846        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26847
26848         gvdwx(k,i) = gvdwx(k,i) &
26849                    - dPOLdR2 * (erhead_tail(k,2) &
26850        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26851         gvdwx(k,j) = gvdwx(k,j)   &
26852                    + dPOLdR2 * condor
26853
26854         gvdwc(k,i) = gvdwc(k,i) &
26855                    - dPOLdR2 * erhead_tail(k,2)
26856         gvdwc(k,j) = gvdwc(k,j) &
26857                    + dPOLdR2 * erhead_tail(k,2)
26858
26859        END DO
26860       RETURN
26861       END SUBROUTINE enq
26862
26863       SUBROUTINE enq_cat(Epol)
26864       use calc_data
26865       use comm_momo
26866        double precision facd3, adler,epol
26867        alphapol2 = alphapolcat(itypj,itypi)
26868 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26869        R2 = 0.0d0
26870        DO k = 1, 3
26871 !c! Calculate head-to-tail distances
26872         R2=R2+(chead(k,2)-ctail(k,1))**2
26873        END DO
26874 !c! Pitagoras
26875        R2 = dsqrt(R2)
26876
26877 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26878 !c!     &        +dhead(1,1,itypi,itypj))**2))
26879 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26880 !c!     &        +dhead(2,1,itypi,itypj))**2))
26881 !c------------------------------------------------------------------------
26882 !c Polarization energy
26883        MomoFac2 = (1.0d0 - chi2 * sqom1)
26884        RR2  = R2 * R2 / MomoFac2
26885        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26886        fgb2 = sqrt(RR2  + a12sq * ee2)
26887        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26888        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26889                 / (fgb2 ** 5.0d0)
26890        dFGBdR2 = ( (R2 / MomoFac2)  &
26891               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26892               / (2.0d0 * fgb2)
26893        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26894                 * (2.0d0 - 0.5d0 * ee2) ) &
26895                 / (2.0d0 * fgb2)
26896        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26897 !c!       dPOLdR2 = 0.0d0
26898        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26899 !c!       dPOLdOM1 = 0.0d0
26900        dPOLdOM2 = 0.0d0
26901
26902 !c!-------------------------------------------------------------------
26903 !c! Return the results
26904 !c! (See comments in Eqq)
26905        DO k = 1, 3
26906         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26907        END DO
26908        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26909        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26910        facd2 = d2 * vbld_inv(j+nres)
26911        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26912        DO k = 1, 3
26913         condor = (erhead_tail(k,2) &
26914        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26915
26916         gradpepcatx(k,i) = gradpepcatx(k,i) &
26917                    - dPOLdR2 * (erhead_tail(k,2) &
26918        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26919         gradpepcatx(k,j) = gradpepcatx(k,j)   &
26920                    + dPOLdR2 * condor
26921
26922         gradpepcat(k,i) = gradpepcat(k,i) &
26923                    - dPOLdR2 * erhead_tail(k,2)
26924         gradpepcat(k,j) = gradpepcat(k,j) &
26925                    + dPOLdR2 * erhead_tail(k,2)
26926
26927        END DO
26928       RETURN
26929       END SUBROUTINE enq_cat
26930
26931       SUBROUTINE eqd(Ecl,Elj,Epol)
26932       use calc_data
26933       use comm_momo
26934        double precision  facd4, federmaus,ecl,elj,epol
26935        alphapol1 = alphapol(itypi,itypj)
26936        w1        = wqdip(1,itypi,itypj)
26937        w2        = wqdip(2,itypi,itypj)
26938        pis       = sig0head(itypi,itypj)
26939        eps_head   = epshead(itypi,itypj)
26940 !c!-------------------------------------------------------------------
26941 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26942        R1 = 0.0d0
26943        DO k = 1, 3
26944 !c! Calculate head-to-tail distances
26945         R1=R1+(ctail(k,2)-chead(k,1))**2
26946        END DO
26947 !c! Pitagoras
26948        R1 = dsqrt(R1)
26949
26950 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26951 !c!     &        +dhead(1,1,itypi,itypj))**2))
26952 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26953 !c!     &        +dhead(2,1,itypi,itypj))**2))
26954
26955 !c!-------------------------------------------------------------------
26956 !c! ecl
26957        sparrow  = w1 * Qi * om1
26958        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26959        Ecl = sparrow / Rhead**2.0d0 &
26960            - hawk    / Rhead**4.0d0
26961        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26962                  + 4.0d0 * hawk    / Rhead**5.0d0
26963 !c! dF/dom1
26964        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26965 !c! dF/dom2
26966        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26967 !c--------------------------------------------------------------------
26968 !c Polarization energy
26969 !c Epol
26970        MomoFac1 = (1.0d0 - chi1 * sqom2)
26971        RR1  = R1 * R1 / MomoFac1
26972        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26973        fgb1 = sqrt( RR1 + a12sq * ee1)
26974        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26975 !c!       epol = 0.0d0
26976 !c!------------------------------------------------------------------
26977 !c! derivative of Epol is Gpol...
26978        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26979                / (fgb1 ** 5.0d0)
26980        dFGBdR1 = ( (R1 / MomoFac1)  &
26981              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26982              / ( 2.0d0 * fgb1 )
26983        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26984                * (2.0d0 - 0.5d0 * ee1) ) &
26985                / (2.0d0 * fgb1)
26986        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26987 !c!       dPOLdR1 = 0.0d0
26988        dPOLdOM1 = 0.0d0
26989        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26990 !c!       dPOLdOM2 = 0.0d0
26991 !c!-------------------------------------------------------------------
26992 !c! Elj
26993        pom = (pis / Rhead)**6.0d0
26994        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26995 !c! derivative of Elj is Glj
26996        dGLJdR = 4.0d0 * eps_head &
26997           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26998           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26999        DO k = 1, 3
27000         erhead(k) = Rhead_distance(k)/Rhead
27001         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27002        END DO
27003
27004        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27005        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27006        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27007        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27008        facd1 = d1 * vbld_inv(i+nres)
27009        facd2 = d2 * vbld_inv(j+nres)
27010        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27011
27012        DO k = 1, 3
27013         hawk = (erhead_tail(k,1) +  &
27014         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27015
27016         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27017         gvdwx(k,i) = gvdwx(k,i)  &
27018                    - dGCLdR * pom&
27019                    - dPOLdR1 * hawk &
27020                    - dGLJdR * pom
27021
27022         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27023         gvdwx(k,j) = gvdwx(k,j)    &
27024                    + dGCLdR * pom  &
27025                    + dPOLdR1 * (erhead_tail(k,1) &
27026        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27027                    + dGLJdR * pom
27028
27029
27030         gvdwc(k,i) = gvdwc(k,i)          &
27031                    - dGCLdR * erhead(k)  &
27032                    - dPOLdR1 * erhead_tail(k,1) &
27033                    - dGLJdR * erhead(k)
27034
27035         gvdwc(k,j) = gvdwc(k,j)          &
27036                    + dGCLdR * erhead(k)  &
27037                    + dPOLdR1 * erhead_tail(k,1) &
27038                    + dGLJdR * erhead(k)
27039
27040        END DO
27041        RETURN
27042       END SUBROUTINE eqd
27043       SUBROUTINE edq(Ecl,Elj,Epol)
27044 !       IMPLICIT NONE
27045        use comm_momo
27046       use calc_data
27047
27048       double precision  facd3, adler,ecl,elj,epol
27049        alphapol2 = alphapol(itypj,itypi)
27050        w1        = wqdip(1,itypi,itypj)
27051        w2        = wqdip(2,itypi,itypj)
27052        pis       = sig0head(itypi,itypj)
27053        eps_head  = epshead(itypi,itypj)
27054 !c!-------------------------------------------------------------------
27055 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27056        R2 = 0.0d0
27057        DO k = 1, 3
27058 !c! Calculate head-to-tail distances
27059         R2=R2+(chead(k,2)-ctail(k,1))**2
27060        END DO
27061 !c! Pitagoras
27062        R2 = dsqrt(R2)
27063
27064 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27065 !c!     &        +dhead(1,1,itypi,itypj))**2))
27066 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27067 !c!     &        +dhead(2,1,itypi,itypj))**2))
27068
27069
27070 !c!-------------------------------------------------------------------
27071 !c! ecl
27072        sparrow  = w1 * Qi * om1
27073        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27074        ECL = sparrow / Rhead**2.0d0 &
27075            - hawk    / Rhead**4.0d0
27076 !c!-------------------------------------------------------------------
27077 !c! derivative of ecl is Gcl
27078 !c! dF/dr part
27079        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27080                  + 4.0d0 * hawk    / Rhead**5.0d0
27081 !c! dF/dom1
27082        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27083 !c! dF/dom2
27084        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27085 !c--------------------------------------------------------------------
27086 !c Polarization energy
27087 !c Epol
27088        MomoFac2 = (1.0d0 - chi2 * sqom1)
27089        RR2  = R2 * R2 / MomoFac2
27090        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27091        fgb2 = sqrt(RR2  + a12sq * ee2)
27092        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27093        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27094                / (fgb2 ** 5.0d0)
27095        dFGBdR2 = ( (R2 / MomoFac2)  &
27096                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27097                / (2.0d0 * fgb2)
27098        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27099                 * (2.0d0 - 0.5d0 * ee2) ) &
27100                 / (2.0d0 * fgb2)
27101        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27102 !c!       dPOLdR2 = 0.0d0
27103        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27104 !c!       dPOLdOM1 = 0.0d0
27105        dPOLdOM2 = 0.0d0
27106 !c!-------------------------------------------------------------------
27107 !c! Elj
27108        pom = (pis / Rhead)**6.0d0
27109        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27110 !c! derivative of Elj is Glj
27111        dGLJdR = 4.0d0 * eps_head &
27112            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27113            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27114 !c!-------------------------------------------------------------------
27115 !c! Return the results
27116 !c! (see comments in Eqq)
27117        DO k = 1, 3
27118         erhead(k) = Rhead_distance(k)/Rhead
27119         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27120        END DO
27121        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27122        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27123        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27124        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27125        facd1 = d1 * vbld_inv(i+nres)
27126        facd2 = d2 * vbld_inv(j+nres)
27127        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27128        DO k = 1, 3
27129         condor = (erhead_tail(k,2) &
27130        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27131
27132         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27133         gvdwx(k,i) = gvdwx(k,i) &
27134                   - dGCLdR * pom &
27135                   - dPOLdR2 * (erhead_tail(k,2) &
27136        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27137                   - dGLJdR * pom
27138
27139         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27140         gvdwx(k,j) = gvdwx(k,j) &
27141                   + dGCLdR * pom &
27142                   + dPOLdR2 * condor &
27143                   + dGLJdR * pom
27144
27145
27146         gvdwc(k,i) = gvdwc(k,i) &
27147                   - dGCLdR * erhead(k) &
27148                   - dPOLdR2 * erhead_tail(k,2) &
27149                   - dGLJdR * erhead(k)
27150
27151         gvdwc(k,j) = gvdwc(k,j) &
27152                   + dGCLdR * erhead(k) &
27153                   + dPOLdR2 * erhead_tail(k,2) &
27154                   + dGLJdR * erhead(k)
27155
27156        END DO
27157        RETURN
27158       END SUBROUTINE edq
27159
27160       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27161       use comm_momo
27162       use calc_data
27163
27164       double precision  facd3, adler,ecl,elj,epol
27165        alphapol2 = alphapolcat(itypj,itypi)
27166        w1        = wqdipcat(1,itypi,itypj)
27167        w2        = wqdipcat(2,itypi,itypj)
27168        pis       = sig0headcat(itypi,itypj)
27169        eps_head  = epsheadcat(itypi,itypj)
27170 !c!-------------------------------------------------------------------
27171 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27172        R2 = 0.0d0
27173        DO k = 1, 3
27174 !c! Calculate head-to-tail distances
27175         R2=R2+(chead(k,2)-ctail(k,1))**2
27176        END DO
27177 !c! Pitagoras
27178        R2 = dsqrt(R2)
27179
27180 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27181 !c!     &        +dhead(1,1,itypi,itypj))**2))
27182 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27183 !c!     &        +dhead(2,1,itypi,itypj))**2))
27184
27185
27186 !c!-------------------------------------------------------------------
27187 !c! ecl
27188        sparrow  = w1 * Qi * om1
27189        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27190        ECL = sparrow / Rhead**2.0d0 &
27191            - hawk    / Rhead**4.0d0
27192 !c!-------------------------------------------------------------------
27193 !c! derivative of ecl is Gcl
27194 !c! dF/dr part
27195        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27196                  + 4.0d0 * hawk    / Rhead**5.0d0
27197 !c! dF/dom1
27198        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27199 !c! dF/dom2
27200        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27201 !c--------------------------------------------------------------------
27202 !c--------------------------------------------------------------------
27203 !c Polarization energy
27204 !c Epol
27205        MomoFac2 = (1.0d0 - chi2 * sqom1)
27206        RR2  = R2 * R2 / MomoFac2
27207        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27208        fgb2 = sqrt(RR2  + a12sq * ee2)
27209        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27210        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27211                / (fgb2 ** 5.0d0)
27212        dFGBdR2 = ( (R2 / MomoFac2)  &
27213                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27214                / (2.0d0 * fgb2)
27215        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27216                 * (2.0d0 - 0.5d0 * ee2) ) &
27217                 / (2.0d0 * fgb2)
27218        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27219 !c!       dPOLdR2 = 0.0d0
27220        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27221 !c!       dPOLdOM1 = 0.0d0
27222        dPOLdOM2 = 0.0d0
27223 !c!-------------------------------------------------------------------
27224 !c! Elj
27225        pom = (pis / Rhead)**6.0d0
27226        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27227 !c! derivative of Elj is Glj
27228        dGLJdR = 4.0d0 * eps_head &
27229            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27230            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27231 !c!-------------------------------------------------------------------
27232
27233 !c! Return the results
27234 !c! (see comments in Eqq)
27235        DO k = 1, 3
27236         erhead(k) = Rhead_distance(k)/Rhead
27237         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27238        END DO
27239        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27240        erdxj = scalar( erhead(1), dC_norm(1,j) )
27241        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27242        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27243        facd1 = d1 * vbld_inv(i+nres)
27244        facd2 = d2 * vbld_inv(j)
27245        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27246        DO k = 1, 3
27247         condor = (erhead_tail(k,2) &
27248        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27249
27250         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27251         gradpepcatx(k,i) = gradpepcatx(k,i) &
27252                   - dGCLdR * pom &
27253                   - dPOLdR2 * (erhead_tail(k,2) &
27254        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27255                   - dGLJdR * pom
27256
27257         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27258         gradpepcatx(k,j) = gradpepcatx(k,j) &
27259                   + dGCLdR * pom &
27260                   + dPOLdR2 * condor &
27261                   + dGLJdR * pom
27262
27263
27264         gradpepcat(k,i) = gradpepcat(k,i) &
27265                   - dGCLdR * erhead(k) &
27266                   - dPOLdR2 * erhead_tail(k,2) &
27267                   - dGLJdR * erhead(k)
27268
27269         gradpepcat(k,j) = gradpepcat(k,j) &
27270                   + dGCLdR * erhead(k) &
27271                   + dPOLdR2 * erhead_tail(k,2) &
27272                   + dGLJdR * erhead(k)
27273
27274        END DO
27275        RETURN
27276       END SUBROUTINE edq_cat
27277
27278
27279       SUBROUTINE edd(ECL)
27280 !       IMPLICIT NONE
27281        use comm_momo
27282       use calc_data
27283
27284        double precision ecl
27285 !c!       csig = sigiso(itypi,itypj)
27286        w1 = wqdip(1,itypi,itypj)
27287        w2 = wqdip(2,itypi,itypj)
27288 !c!-------------------------------------------------------------------
27289 !c! ECL
27290        fac = (om12 - 3.0d0 * om1 * om2)
27291        c1 = (w1 / (Rhead**3.0d0)) * fac
27292        c2 = (w2 / Rhead ** 6.0d0) &
27293           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27294        ECL = c1 - c2
27295 !c!       write (*,*) "w1 = ", w1
27296 !c!       write (*,*) "w2 = ", w2
27297 !c!       write (*,*) "om1 = ", om1
27298 !c!       write (*,*) "om2 = ", om2
27299 !c!       write (*,*) "om12 = ", om12
27300 !c!       write (*,*) "fac = ", fac
27301 !c!       write (*,*) "c1 = ", c1
27302 !c!       write (*,*) "c2 = ", c2
27303 !c!       write (*,*) "Ecl = ", Ecl
27304 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27305 !c!       write (*,*) "c2_2 = ",
27306 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27307 !c!-------------------------------------------------------------------
27308 !c! dervative of ECL is GCL...
27309 !c! dECL/dr
27310        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27311        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27312           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27313        dGCLdR = c1 - c2
27314 !c! dECL/dom1
27315        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27316        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27317           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27318        dGCLdOM1 = c1 - c2
27319 !c! dECL/dom2
27320        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27321        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27322           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27323        dGCLdOM2 = c1 - c2
27324 !c! dECL/dom12
27325        c1 = w1 / (Rhead ** 3.0d0)
27326        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27327        dGCLdOM12 = c1 - c2
27328 !c!-------------------------------------------------------------------
27329 !c! Return the results
27330 !c! (see comments in Eqq)
27331        DO k= 1, 3
27332         erhead(k) = Rhead_distance(k)/Rhead
27333        END DO
27334        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27335        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27336        facd1 = d1 * vbld_inv(i+nres)
27337        facd2 = d2 * vbld_inv(j+nres)
27338        DO k = 1, 3
27339
27340         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27341         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27342         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27343         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27344
27345         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27346         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27347        END DO
27348        RETURN
27349       END SUBROUTINE edd
27350       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27351 !       IMPLICIT NONE
27352        use comm_momo
27353       use calc_data
27354
27355        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27356        eps_out=80.0d0
27357        itypi = itype(i,1)
27358        itypj = itype(j,1)
27359 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27360 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27361 !c!       t_bath = 300
27362 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27363        Rb=0.001986d0
27364        BetaT = 1.0d0 / (298.0d0 * Rb)
27365 !c! Gay-berne var's
27366        sig0ij = sigma( itypi,itypj )
27367        chi1   = chi( itypi, itypj )
27368        chi2   = chi( itypj, itypi )
27369        chi12  = chi1 * chi2
27370        chip1  = chipp( itypi, itypj )
27371        chip2  = chipp( itypj, itypi )
27372        chip12 = chip1 * chip2
27373 !       chi1=0.0
27374 !       chi2=0.0
27375 !       chi12=0.0
27376 !       chip1=0.0
27377 !       chip2=0.0
27378 !       chip12=0.0
27379 !c! not used by momo potential, but needed by sc_angular which is shared
27380 !c! by all energy_potential subroutines
27381        alf1   = 0.0d0
27382        alf2   = 0.0d0
27383        alf12  = 0.0d0
27384 !c! location, location, location
27385 !       xj  = c( 1, nres+j ) - xi
27386 !       yj  = c( 2, nres+j ) - yi
27387 !       zj  = c( 3, nres+j ) - zi
27388        dxj = dc_norm( 1, nres+j )
27389        dyj = dc_norm( 2, nres+j )
27390        dzj = dc_norm( 3, nres+j )
27391 !c! distance from center of chain(?) to polar/charged head
27392 !c!       write (*,*) "istate = ", 1
27393 !c!       write (*,*) "ii = ", 1
27394 !c!       write (*,*) "jj = ", 1
27395        d1 = dhead(1, 1, itypi, itypj)
27396        d2 = dhead(2, 1, itypi, itypj)
27397 !c! ai*aj from Fgb
27398        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27399 !c!       a12sq = a12sq * a12sq
27400 !c! charge of amino acid itypi is...
27401        Qi  = icharge(itypi)
27402        Qj  = icharge(itypj)
27403        Qij = Qi * Qj
27404 !c! chis1,2,12
27405        chis1 = chis(itypi,itypj)
27406        chis2 = chis(itypj,itypi)
27407        chis12 = chis1 * chis2
27408        sig1 = sigmap1(itypi,itypj)
27409        sig2 = sigmap2(itypi,itypj)
27410 !c!       write (*,*) "sig1 = ", sig1
27411 !c!       write (*,*) "sig2 = ", sig2
27412 !c! alpha factors from Fcav/Gcav
27413        b1cav = alphasur(1,itypi,itypj)
27414 !       b1cav=0.0
27415        b2cav = alphasur(2,itypi,itypj)
27416        b3cav = alphasur(3,itypi,itypj)
27417        b4cav = alphasur(4,itypi,itypj)
27418        wqd = wquad(itypi, itypj)
27419 !c! used by Fgb
27420        eps_in = epsintab(itypi,itypj)
27421        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27422 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27423 !c!-------------------------------------------------------------------
27424 !c! tail location and distance calculations
27425        Rtail = 0.0d0
27426        DO k = 1, 3
27427         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27428         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27429        END DO
27430 !c! tail distances will be themselves usefull elswhere
27431 !c1 (in Gcav, for example)
27432        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27433        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27434        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27435        Rtail = dsqrt(  &
27436           (Rtail_distance(1)*Rtail_distance(1))  &
27437         + (Rtail_distance(2)*Rtail_distance(2))  &
27438         + (Rtail_distance(3)*Rtail_distance(3)))
27439 !c!-------------------------------------------------------------------
27440 !c! Calculate location and distance between polar heads
27441 !c! distance between heads
27442 !c! for each one of our three dimensional space...
27443        d1 = dhead(1, 1, itypi, itypj)
27444        d2 = dhead(2, 1, itypi, itypj)
27445
27446        DO k = 1,3
27447 !c! location of polar head is computed by taking hydrophobic centre
27448 !c! and moving by a d1 * dc_norm vector
27449 !c! see unres publications for very informative images
27450         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27451         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27452 !c! distance
27453 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27454 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27455         Rhead_distance(k) = chead(k,2) - chead(k,1)
27456        END DO
27457 !c! pitagoras (root of sum of squares)
27458        Rhead = dsqrt(   &
27459           (Rhead_distance(1)*Rhead_distance(1)) &
27460         + (Rhead_distance(2)*Rhead_distance(2)) &
27461         + (Rhead_distance(3)*Rhead_distance(3)))
27462 !c!-------------------------------------------------------------------
27463 !c! zero everything that should be zero'ed
27464        Egb = 0.0d0
27465        ECL = 0.0d0
27466        Elj = 0.0d0
27467        Equad = 0.0d0
27468        Epol = 0.0d0
27469        eheadtail = 0.0d0
27470        dGCLdOM1 = 0.0d0
27471        dGCLdOM2 = 0.0d0
27472        dGCLdOM12 = 0.0d0
27473        dPOLdOM1 = 0.0d0
27474        dPOLdOM2 = 0.0d0
27475        RETURN
27476       END SUBROUTINE elgrad_init
27477
27478
27479       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27480       use comm_momo
27481       use calc_data
27482        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27483        eps_out=80.0d0
27484        itypi = itype(i,1)
27485        itypj = itype(j,5)
27486 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27487 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27488 !c!       t_bath = 300
27489 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27490        Rb=0.001986d0
27491        BetaT = 1.0d0 / (298.0d0 * Rb)
27492 !c! Gay-berne var's
27493        sig0ij = sigmacat( itypi,itypj )
27494        chi1   = chicat( itypi, itypj )
27495 !       chi2   = chi( itypj, itypi )
27496        chi2   = 0.0d0
27497 !       chi12  = chi1 * chi2
27498        chi12  = 0.0d0
27499        chip1  = chippcat( itypi, itypj )
27500 !       chip2  = chipp( itypj, itypi )
27501        chip2  = 0.0d0
27502 !       chip12 = chip1 * chip2
27503        chip12 = 0.0d0
27504 !       chi1=0.0
27505 !       chi2=0.0
27506 !       chi12=0.0
27507 !       chip1=0.0
27508 !       chip2=0.0
27509 !       chip12=0.0
27510 !c! not used by momo potential, but needed by sc_angular which is shared
27511 !c! by all energy_potential subroutines
27512        alf1   = 0.0d0
27513        alf2   = 0.0d0
27514        alf12  = 0.0d0
27515 !c! location, location, location
27516 !       xj  = c( 1, nres+j ) - xi
27517 !       yj  = c( 2, nres+j ) - yi
27518 !       zj  = c( 3, nres+j ) - zi
27519        dxj = dc_norm( 1, nres+j )
27520        dyj = dc_norm( 2, nres+j )
27521        dzj = dc_norm( 3, nres+j )
27522 !c! distance from center of chain(?) to polar/charged head
27523        d1 = dheadcat(1, 1, itypi, itypj)
27524        d2 = dheadcat(2, 1, itypi, itypj)
27525 !c! ai*aj from Fgb
27526        a12sq = rborncat(itypi,itypj) * rborncat(itypj,itypi)
27527 !c!       a12sq = a12sq * a12sq
27528 !c! charge of amino acid itypi is...
27529        Qi  = icharge(itypi)
27530        Qj  = ichargecat(itypj)
27531        Qij = Qi * Qj
27532 !c! chis1,2,12
27533        chis1 = chiscat(itypi,itypj)
27534 !       chis2 = chis(itypj,itypi)
27535        chis2 = 0.0d0
27536 !       chis12 = chis1 * chis2
27537        chis12 = 0.0d0
27538        sig1 = sigmap1cat(itypi,itypj)
27539        sig2 = sigmap2cat(itypi,itypj)
27540 !c! alpha factors from Fcav/Gcav
27541        b1cav = alphasurcat(1,itypi,itypj)
27542 !       b1cav=0.0
27543        b2cav = alphasurcat(2,itypi,itypj)
27544        b3cav = alphasurcat(3,itypi,itypj)
27545        b4cav = alphasurcat(4,itypi,itypj)
27546        wqd = wquadcat(itypi, itypj)
27547 !c! used by Fgb
27548        eps_in = epsintabcat(itypi,itypj)
27549        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27550 !c!-------------------------------------------------------------------
27551 !c! tail location and distance calculations
27552        Rtail = 0.0d0
27553        DO k = 1, 3
27554         ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27555         ctail(k,2)=c(k,j+nres)-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27556        END DO
27557 !c! tail distances will be themselves usefull elswhere
27558 !c1 (in Gcav, for example)
27559        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27560        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27561        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27562        Rtail = dsqrt(  &
27563           (Rtail_distance(1)*Rtail_distance(1))  &
27564         + (Rtail_distance(2)*Rtail_distance(2))  &
27565         + (Rtail_distance(3)*Rtail_distance(3)))
27566 !c!-------------------------------------------------------------------
27567 !c! Calculate location and distance between polar heads
27568 !c! distance between heads
27569 !c! for each one of our three dimensional space...
27570        d1 = dheadcat(1, 1, itypi, itypj)
27571        d2 = dheadcat(2, 1, itypi, itypj)
27572
27573        DO k = 1,3
27574 !c! location of polar head is computed by taking hydrophobic centre
27575 !c! and moving by a d1 * dc_norm vector
27576 !c! see unres publications for very informative images
27577         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27578         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27579 !c! distance
27580 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27581 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27582         Rhead_distance(k) = chead(k,2) - chead(k,1)
27583        END DO
27584 !c! pitagoras (root of sum of squares)
27585        Rhead = dsqrt(   &
27586           (Rhead_distance(1)*Rhead_distance(1)) &
27587         + (Rhead_distance(2)*Rhead_distance(2)) &
27588         + (Rhead_distance(3)*Rhead_distance(3)))
27589 !c!-------------------------------------------------------------------
27590 !c! zero everything that should be zero'ed
27591        Egb = 0.0d0
27592        ECL = 0.0d0
27593        Elj = 0.0d0
27594        Equad = 0.0d0
27595        Epol = 0.0d0
27596        eheadtail = 0.0d0
27597        dGCLdOM1 = 0.0d0
27598        dGCLdOM2 = 0.0d0
27599        dGCLdOM12 = 0.0d0
27600        dPOLdOM1 = 0.0d0
27601        dPOLdOM2 = 0.0d0
27602        RETURN
27603       END SUBROUTINE elgrad_init_cat
27604
27605
27606       double precision function tschebyshev(m,n,x,y)
27607       implicit none
27608       integer i,m,n
27609       double precision x(n),y,yy(0:maxvar),aux
27610 !c Tschebyshev polynomial. Note that the first term is omitted
27611 !c m=0: the constant term is included
27612 !c m=1: the constant term is not included
27613       yy(0)=1.0d0
27614       yy(1)=y
27615       do i=2,n
27616         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27617       enddo
27618       aux=0.0d0
27619       do i=m,n
27620         aux=aux+x(i)*yy(i)
27621       enddo
27622       tschebyshev=aux
27623       return
27624       end function tschebyshev
27625 !C--------------------------------------------------------------------------
27626       double precision function gradtschebyshev(m,n,x,y)
27627       implicit none
27628       integer i,m,n
27629       double precision x(n+1),y,yy(0:maxvar),aux
27630 !c Tschebyshev polynomial. Note that the first term is omitted
27631 !c m=0: the constant term is included
27632 !c m=1: the constant term is not included
27633       yy(0)=1.0d0
27634       yy(1)=2.0d0*y
27635       do i=2,n
27636         yy(i)=2*y*yy(i-1)-yy(i-2)
27637       enddo
27638       aux=0.0d0
27639       do i=m,n
27640         aux=aux+x(i+1)*yy(i)*(i+1)
27641 !C        print *, x(i+1),yy(i),i
27642       enddo
27643       gradtschebyshev=aux
27644       return
27645       end function gradtschebyshev
27646
27647
27648
27649
27650
27651       end module energy