source/unres/energy.F90

   1               module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33 !      integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der,gUb2      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(4) :: gmuij,gmuij1,gmuij2,gmuji1,gmuji2
  91       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  92        costab2,sintab2      !(maxres)
  93 ! This common block contains dipole-interaction matrices and their
  94 ! Cartesian derivatives.
  95 !      common /dipmat/
  96       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  97       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  98 !      common /diploc/
  99       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
 100        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 101       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 102        ADtEA1derg,AEAb2derg
 103       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 104        AECAderx,ADtEAderx,ADtEA1derx
 105       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 106       real(kind=8),dimension(3,2) :: g_contij
 107       real(kind=8) :: ekont
 108 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 109 !   RE: Parallelization of 4th and higher order loc-el correlations
 110 !      common /contdistrib/
 111       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 112 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 113 !-----------------------------------------------------------------------------
 114 ! commom.deriv;
 115 !      common /derivat/
 116 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 117 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 118 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 119       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 120         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 121         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 122         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 123         gliptranx, &
 124         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 125         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 126         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 127         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 128         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 129 !-----------------------------NUCLEIC GRADIENT
 130       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 131         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 132         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 133         gvdwpp_nucl
 134 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 135       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 136          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 137          gvdwc_peppho
 138 !------------------------------IONS GRADIENT
 139         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 140           gradpepcat,gradpepcatx
 141 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 142
 143
 144       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 145         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 146       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 147         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 148         g_corr6_loc      !(maxvar)
 149       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 150       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 151 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 152       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 153 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 154       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 155          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 156 !      integer :: nfl,icg
 157 !      common /deriv_loc/
 158       real(kind=8), dimension(:),allocatable :: fac_shield
 159       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 160 !      common /deriv_scloc/
 161       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 162        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 163        dZZ_XYZtab      !(3,maxres)
 164 !-----------------------------------------------------------------------------
 165 ! common.maxgrad
 166 !      common /maxgrad/
 167       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 168        gradb_max,ghpbc_max,&
 169        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 170        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 171        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 172        gsccorx_max,gsclocx_max
 173 !-----------------------------------------------------------------------------
 174 ! common.MD
 175 !      common /back_constr/
 176       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 177       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 178 !      common /qmeas/
 179       real(kind=8) :: Ucdfrag,Ucdpair
 180       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 181        dqwol,dxqwol      !(3,0:MAXRES)
 182 !-----------------------------------------------------------------------------
 183 ! common.sbridge
 184 !      common /dyn_ssbond/
 185       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 186 !-----------------------------------------------------------------------------
 187 ! common.sccor
 188 ! Parameters of the SCCOR term
 189 !      common/sccor/
 190       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 191        dcosomicron,domicron      !(3,3,3,maxres2)
 192 !-----------------------------------------------------------------------------
 193 ! common.vectors
 194 !      common /vectors/
 195       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 196       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 197 !-----------------------------------------------------------------------------
 198 ! common /przechowalnia/
 199       real(kind=8),dimension(:,:,:),allocatable :: zapas
 200       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 201       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 202 !-----------------------------------------------------------------------------
 203 !-----------------------------------------------------------------------------
 204 !
 205 !
 206 !-----------------------------------------------------------------------------
 207       contains
 208 !-----------------------------------------------------------------------------
 209 ! energy_p_new_barrier.F
 210 !-----------------------------------------------------------------------------
 211       subroutine etotal(energia)
 212 !      implicit real*8 (a-h,o-z)
 213 !      include 'DIMENSIONS'
 214       use MD_data
 215 #ifndef ISNAN
 216       external proc_proc
 217 #ifdef WINPGI
 218 !MS$ATTRIBUTES C ::  proc_proc
 219 #endif
 220 #endif
 221 #ifdef MPI
 222       include "mpif.h"
 223 #endif
 224 !      include 'COMMON.SETUP'
 225 !      include 'COMMON.IOUNITS'
 226       real(kind=8),dimension(0:n_ene) :: energia
 227 !      include 'COMMON.LOCAL'
 228 !      include 'COMMON.FFIELD'
 229 !      include 'COMMON.DERIV'
 230 !      include 'COMMON.INTERACT'
 231 !      include 'COMMON.SBRIDGE'
 232 !      include 'COMMON.CHAIN'
 233 !      include 'COMMON.VAR'
 234 !      include 'COMMON.MD'
 235 !      include 'COMMON.CONTROL'
 236 !      include 'COMMON.TIME1'
 237       real(kind=8) :: time00
 238 !el local variables
 239       integer :: n_corr,n_corr1,ierror
 240       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 241       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 242       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 243                       Eafmforce,ethetacnstr
 244       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 245 ! now energies for nulceic alone parameters
 246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 248                       ecorr3_nucl
 249 ! energies for ions
 250       real(kind=8) :: ecation_prot,ecationcation
 251 ! energies for protein nucleic acid interaction
 252       real(kind=8) :: escbase,epepbase,escpho,epeppho
 253
 254 #ifdef MPI
 255       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 256 ! shielding effect varibles for MPI
 257       real(kind=8) ::  fac_shieldbuf(nres), &
 258       grad_shield_locbuf1(3*maxcontsshi*nres), &
 259       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 260       grad_shield_locbuf2(3*maxcontsshi*nres), &
 261       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 262       grad_shieldbuf1(3*nres), &
 263       grad_shieldbuf2(3*nres)
 264
 265        integer ishield_listbuf(-1:nres), &
 266        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 267
 268
 269 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 270 !      real(kind=8), dimension(:,:,:),allocatable:: &
 271 !       grad_shield_locbuf,grad_shield_sidebuf
 272 !      real(kind=8), dimension(:,:),allocatable:: &
 273 !        grad_shieldbuf
 274 !       integer, dimension(:),allocatable:: &
 275 !       ishield_listbuf
 276 !       integer, dimension(:,:),allocatable::  shield_listbuf
 277 !       integer :: k,j,i
 278 !      if (.not.allocated(fac_shieldbuf)) then
 279 !          allocate(fac_shieldbuf(nres))
 280 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 281 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 282 !          allocate(grad_shieldbuf(3,-1:nres))
 283 !          allocate(ishield_listbuf(nres))
 284 !          allocate(shield_listbuf(maxcontsshi,nres))
 285 !       endif
 286
 287 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 288 !     & " nfgtasks",nfgtasks
 289       if (nfgtasks.gt.1) then
 290         time00=MPI_Wtime()
 291 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 292         if (fg_rank.eq.0) then
 293           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 294 !          print *,"Processor",myrank," BROADCAST iorder"
 295 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 296 ! FG slaves as WEIGHTS array.
 297           weights_(1)=wsc
 298           weights_(2)=wscp
 299           weights_(3)=welec
 300           weights_(4)=wcorr
 301           weights_(5)=wcorr5
 302           weights_(6)=wcorr6
 303           weights_(7)=wel_loc
 304           weights_(8)=wturn3
 305           weights_(9)=wturn4
 306           weights_(10)=wturn6
 307           weights_(11)=wang
 308           weights_(12)=wscloc
 309           weights_(13)=wtor
 310           weights_(14)=wtor_d
 311           weights_(15)=wstrain
 312           weights_(16)=wvdwpp
 313           weights_(17)=wbond
 314           weights_(18)=scal14
 315           weights_(21)=wsccor
 316           weights_(26)=wvdwpp_nucl
 317           weights_(27)=welpp
 318           weights_(28)=wvdwpsb
 319           weights_(29)=welpsb
 320           weights_(30)=wvdwsb
 321           weights_(31)=welsb
 322           weights_(32)=wbond_nucl
 323           weights_(33)=wang_nucl
 324           weights_(34)=wsbloc
 325           weights_(35)=wtor_nucl
 326           weights_(36)=wtor_d_nucl
 327           weights_(37)=wcorr_nucl
 328           weights_(38)=wcorr3_nucl
 329           weights_(41)=wcatcat
 330           weights_(42)=wcatprot
 331           weights_(46)=wscbase
 332           weights_(47)=wscpho
 333           weights_(48)=wpeppho
 334 !          wcatcat= weights(41)
 335 !          wcatprot=weights(42)
 336
 337 ! FG Master broadcasts the WEIGHTS_ array
 338           call MPI_Bcast(weights_(1),n_ene,&
 339              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 340         else
 341 ! FG slaves receive the WEIGHTS array
 342           call MPI_Bcast(weights(1),n_ene,&
 343               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 344           wsc=weights(1)
 345           wscp=weights(2)
 346           welec=weights(3)
 347           wcorr=weights(4)
 348           wcorr5=weights(5)
 349           wcorr6=weights(6)
 350           wel_loc=weights(7)
 351           wturn3=weights(8)
 352           wturn4=weights(9)
 353           wturn6=weights(10)
 354           wang=weights(11)
 355           wscloc=weights(12)
 356           wtor=weights(13)
 357           wtor_d=weights(14)
 358           wstrain=weights(15)
 359           wvdwpp=weights(16)
 360           wbond=weights(17)
 361           scal14=weights(18)
 362           wsccor=weights(21)
 363           wvdwpp_nucl =weights(26)
 364           welpp  =weights(27)
 365           wvdwpsb=weights(28)
 366           welpsb =weights(29)
 367           wvdwsb =weights(30)
 368           welsb  =weights(31)
 369           wbond_nucl  =weights(32)
 370           wang_nucl   =weights(33)
 371           wsbloc =weights(34)
 372           wtor_nucl   =weights(35)
 373           wtor_d_nucl =weights(36)
 374           wcorr_nucl  =weights(37)
 375           wcorr3_nucl =weights(38)
 376           wcatcat= weights(41)
 377           wcatprot=weights(42)
 378           wscbase=weights(46)
 379           wscpho=weights(47)
 380           wpeppho=weights(48)
 381         endif
 382         time_Bcast=time_Bcast+MPI_Wtime()-time00
 383         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 384 !        call chainbuild_cart
 385       endif
 386 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 387 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 388 #else
 389 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 390 !        call int_from_cart1(.false.)
 391 !      endif
 392 #endif
 393 #ifdef TIMING
 394       time00=MPI_Wtime()
 395 #endif
 396 !
 397 ! Compute the side-chain and electrostatic interaction energy
 398 !        print *, "Before EVDW"
 399 !      goto (101,102,103,104,105,106) ipot
 400       select case(ipot)
 401 ! Lennard-Jones potential.
 402 !  101 call elj(evdw)
 403        case (1)
 404          call elj(evdw)
 405 !d    print '(a)','Exit ELJcall el'
 406 !      goto 107
 407 ! Lennard-Jones-Kihara potential (shifted).
 408 !  102 call eljk(evdw)
 409        case (2)
 410          call eljk(evdw)
 411 !      goto 107
 412 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 413 !  103 call ebp(evdw)
 414        case (3)
 415          call ebp(evdw)
 416 !      goto 107
 417 ! Gay-Berne potential (shifted LJ, angular dependence).
 418 !  104 call egb(evdw)
 419        case (4)
 420 !       print *,"MOMO",scelemode
 421         if (scelemode.eq.0) then
 422          call egb(evdw)
 423         else
 424          call emomo(evdw)
 425         endif
 426 !      goto 107
 427 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 428 !  105 call egbv(evdw)
 429        case (5)
 430          call egbv(evdw)
 431 !      goto 107
 432 ! Soft-sphere potential
 433 !  106 call e_softsphere(evdw)
 434        case (6)
 435          call e_softsphere(evdw)
 436 !
 437 ! Calculate electrostatic (H-bonding) energy of the main chain.
 438 !
 439 !  107 continue
 440        case default
 441          write(iout,*)"Wrong ipot"
 442 !         return
 443 !   50 continue
 444       end select
 445 !      continue
 446 !        print *,"after EGB"
 447 ! shielding effect
 448        if (shield_mode.eq.2) then
 449                  call set_shield_fac2
 450
 451       if (nfgtasks.gt.1) then
 452       grad_shield_sidebuf1(:)=0.0d0
 453       grad_shield_locbuf1(:)=0.0d0
 454       grad_shield_sidebuf2(:)=0.0d0
 455       grad_shield_locbuf2(:)=0.0d0
 456       grad_shieldbuf1(:)=0.0d0
 457       grad_shieldbuf2(:)=0.0d0
 458 !#define DEBUG
 459 #ifdef DEBUG
 460        write(iout,*) "befor reduce fac_shield reduce"
 461        do i=1,nres
 462         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 463         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 464        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 465        enddo
 466 #endif
 467         iii=0
 468         jjj=0
 469         do i=1,nres
 470         ishield_listbuf(i)=0
 471         do k=1,3
 472         iii=iii+1
 473         grad_shieldbuf1(iii)=grad_shield(k,i)
 474         enddo
 475         enddo
 476         do i=1,nres
 477          do j=1,maxcontsshi
 478           do k=1,3
 479               jjj=jjj+1
 480               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 481               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 482            enddo
 483           enddo
 484          enddo
 485         call MPI_Allgatherv(fac_shield(ivec_start), &
 486         ivec_count(fg_rank1), &
 487         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 488         ivec_displ(0), &
 489         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 490         call MPI_Allgatherv(shield_list(1,ivec_start), &
 491         ivec_count(fg_rank1), &
 492         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 493         ivec_displ(0), &
 494         MPI_I50,FG_COMM,IERROR)
 495 !        write(2,*) "After I50"
 496 !        call flush(iout)
 497         call MPI_Allgatherv(ishield_list(ivec_start), &
 498         ivec_count(fg_rank1), &
 499         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 500         ivec_displ(0), &
 501         MPI_INTEGER,FG_COMM,IERROR)
 502 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 503
 504 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 505 !        write (2,*) "before"
 506 !        write(2,*) grad_shieldbuf1
 507 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 508 !        ivec_count(fg_rank1)*3, &
 509 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 510 !        ivec_count(0), &
 511 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 512         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 513         nres*3, &
 514         MPI_DOUBLE_PRECISION, &
 515         MPI_SUM, &
 516         FG_COMM,IERROR)
 517         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 518         nres*3*maxcontsshi, &
 519         MPI_DOUBLE_PRECISION, &
 520         MPI_SUM, &
 521         FG_COMM,IERROR)
 522
 523         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 524         nres*3*maxcontsshi, &
 525         MPI_DOUBLE_PRECISION, &
 526         MPI_SUM, &
 527         FG_COMM,IERROR)
 528
 529 !        write(2,*) "after"
 530 !        write(2,*) grad_shieldbuf2
 531
 532 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 533 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 534 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 535 !        ivec_displ(0)*3*maxcontsshi, &
 536 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 537 !        write(2,*) "After grad_shield_side"
 538 !        call flush(iout)
 539 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 540 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 541 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 542 !        ivec_displ(0)*3*maxcontsshi, &
 543 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 544 !        write(2,*) "After MPI_SHI"
 545 !        call flush(iout)
 546         iii=0
 547         jjj=0
 548         do i=1,nres
 549          fac_shield(i)=fac_shieldbuf(i)
 550          ishield_list(i)=ishield_listbuf(i)
 551 !         write(iout,*) i,fac_shield(i)
 552          do j=1,3
 553          iii=iii+1
 554          grad_shield(j,i)=grad_shieldbuf2(iii)
 555          enddo !j
 556          do j=1,ishield_list(i)
 557 !          write (iout,*) "ishild", ishield_list(i),i
 558            shield_list(j,i)=shield_listbuf(j,i)
 559           enddo
 560           do j=1,maxcontsshi
 561           do k=1,3
 562            jjj=jjj+1
 563           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 564           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 565           enddo !k
 566         enddo !j
 567        enddo !i
 568        endif
 569 #ifdef DEBUG
 570        write(iout,*) "after reduce fac_shield reduce"
 571        do i=1,nres
 572         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 573         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 574         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 575        enddo
 576 #endif
 577 #undef DEBUG
 578        endif
 579
 580
 581
 582 !       print *,"AFTER EGB",ipot,evdw
 583 !mc
 584 !mc Sep-06: egb takes care of dynamic ss bonds too
 585 !mc
 586 !      if (dyn_ss) call dyn_set_nss
 587 !      print *,"Processor",myrank," computed USCSC"
 588 #ifdef TIMING
 589       time01=MPI_Wtime()
 590 #endif
 591       call vec_and_deriv
 592 #ifdef TIMING
 593       time_vec=time_vec+MPI_Wtime()-time01
 594 #endif
 595
 596
 597
 598
 599 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 600       if (ipot.lt.6) then
 601 #ifdef SPLITELE
 602 !         print *,"after ipot if", ipot
 603          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 604              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 605              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 606              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 607 #else
 608          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 609              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 610              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 611              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 612 #endif
 613 !            print *,"just befor eelec call"
 614             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 615 !            print *, "ELEC calc"
 616          else
 617             ees=0.0d0
 618             evdw1=0.0d0
 619             eel_loc=0.0d0
 620             eello_turn3=0.0d0
 621             eello_turn4=0.0d0
 622          endif
 623       else
 624 !        write (iout,*) "Soft-spheer ELEC potential"
 625         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 626          eello_turn4)
 627       endif
 628 !      print *,"Processor",myrank," computed UELEC"
 629 !
 630 ! Calculate excluded-volume interaction energy between peptide groups
 631 ! and side chains.
 632 !
 633 !       write(iout,*) "in etotal calc exc;luded",ipot
 634
 635       if (ipot.lt.6) then
 636        if(wscp.gt.0d0) then
 637         call escp(evdw2,evdw2_14)
 638        else
 639         evdw2=0
 640         evdw2_14=0
 641        endif
 642       else
 643 !        write (iout,*) "Soft-sphere SCP potential"
 644         call escp_soft_sphere(evdw2,evdw2_14)
 645       endif
 646 !        write(iout,*) "in etotal before ebond",ipot
 647
 648 !
 649 ! Calculate the bond-stretching energy
 650 !
 651       call ebond(estr)
 652 !       print *,"EBOND",estr
 653 !       write(iout,*) "in etotal afer ebond",ipot
 654
 655 !
 656 ! Calculate the disulfide-bridge and other energy and the contributions
 657 ! from other distance constraints.
 658 !      print *,'Calling EHPB'
 659       call edis(ehpb)
 660 !elwrite(iout,*) "in etotal afer edis",ipot
 661 !      print *,'EHPB exitted succesfully.'
 662 !
 663 ! Calculate the virtual-bond-angle energy.
 664 !       write(iout,*) "in etotal afer edis",ipot
 665
 666 !      if (wang.gt.0.0d0) then
 667 !        call ebend(ebe,ethetacnstr)
 668 !      else
 669 !        ebe=0
 670 !        ethetacnstr=0
 671 !      endif
 672       if (wang.gt.0d0) then
 673        if (tor_mode.eq.0) then
 674          call ebend(ebe)
 675        else
 676 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 677 !C energy function
 678          call ebend_kcc(ebe)
 679        endif
 680       else
 681         ebe=0.0d0
 682       endif
 683       ethetacnstr=0.0d0
 684       if (with_theta_constr) call etheta_constr(ethetacnstr)
 685
 686 !       write(iout,*) "in etotal afer ebe",ipot
 687
 688 !      print *,"Processor",myrank," computed UB"
 689 !
 690 ! Calculate the SC local energy.
 691 !
 692       call esc(escloc)
 693 !elwrite(iout,*) "in etotal afer esc",ipot
 694 !      print *,"Processor",myrank," computed USC"
 695 !
 696 ! Calculate the virtual-bond torsional energy.
 697 !
 698 !d    print *,'nterm=',nterm
 699 !      if (wtor.gt.0) then
 700 !       call etor(etors,edihcnstr)
 701 !      else
 702 !       etors=0
 703 !       edihcnstr=0
 704 !      endif
 705       if (wtor.gt.0.0d0) then
 706          if (tor_mode.eq.0) then
 707            call etor(etors)
 708          else
 709 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 710 !C energy function
 711            call etor_kcc(etors)
 712          endif
 713       else
 714         etors=0.0d0
 715       endif
 716       edihcnstr=0.0d0
 717       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 718 !c      print *,"Processor",myrank," computed Utor"
 719
 720 !      print *,"Processor",myrank," computed Utor"
 721
 722 !
 723 ! 6/23/01 Calculate double-torsional energy
 724 !
 725 !elwrite(iout,*) "in etotal",ipot
 726       if (wtor_d.gt.0) then
 727        call etor_d(etors_d)
 728       else
 729        etors_d=0
 730       endif
 731 !      print *,"Processor",myrank," computed Utord"
 732 !
 733 ! 21/5/07 Calculate local sicdechain correlation energy
 734 !
 735       if (wsccor.gt.0.0d0) then
 736         call eback_sc_corr(esccor)
 737       else
 738         esccor=0.0d0
 739       endif
 740
 741 !      write(iout,*) "before multibody"
 742       call flush(iout)
 743 !      print *,"Processor",myrank," computed Usccorr"
 744 !
 745 ! 12/1/95 Multi-body terms
 746 !
 747       n_corr=0
 748       n_corr1=0
 749       call flush(iout)
 750       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 751           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 752          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 753 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 754 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 755       else
 756          ecorr=0.0d0
 757          ecorr5=0.0d0
 758          ecorr6=0.0d0
 759          eturn6=0.0d0
 760       endif
 761 !elwrite(iout,*) "in etotal",ipot
 762       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 763          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 764 !d         write (iout,*) "multibody_hb ecorr",ecorr
 765       endif
 766 !      write(iout,*) "afeter  multibody hb"
 767
 768 !      print *,"Processor",myrank," computed Ucorr"
 769 !
 770 ! If performing constraint dynamics, call the constraint energy
 771 !  after the equilibration time
 772       if(usampl.and.totT.gt.eq_time) then
 773 !elwrite(iout,*) "afeter  multibody hb"
 774          call EconstrQ
 775 !elwrite(iout,*) "afeter  multibody hb"
 776          call Econstr_back
 777 !elwrite(iout,*) "afeter  multibody hb"
 778       else
 779          Uconst=0.0d0
 780          Uconst_back=0.0d0
 781       endif
 782       call flush(iout)
 783 !         write(iout,*) "after Econstr"
 784
 785       if (wliptran.gt.0) then
 786 !        print *,"PRZED WYWOLANIEM"
 787         call Eliptransfer(eliptran)
 788       else
 789        eliptran=0.0d0
 790       endif
 791       if (fg_rank.eq.0) then
 792       if (AFMlog.gt.0) then
 793         call AFMforce(Eafmforce)
 794       else if (selfguide.gt.0) then
 795         call AFMvel(Eafmforce)
 796       else
 797         Eafmforce=0.0d0
 798       endif
 799       endif
 800       if (tubemode.eq.1) then
 801        call calctube(etube)
 802       else if (tubemode.eq.2) then
 803        call calctube2(etube)
 804       elseif (tubemode.eq.3) then
 805        call calcnano(etube)
 806       else
 807        etube=0.0d0
 808       endif
 809 !--------------------------------------------------------
 810 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 811 !      print *,"before",ees,evdw1,ecorr
 812 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 813       if (nres_molec(2).gt.0) then
 814       call ebond_nucl(estr_nucl)
 815       call ebend_nucl(ebe_nucl)
 816       call etor_nucl(etors_nucl)
 817       call esb_gb(evdwsb,eelsb)
 818       call epp_nucl_sub(evdwpp,eespp)
 819       call epsb(evdwpsb,eelpsb)
 820       call esb(esbloc)
 821       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 822       else
 823        etors_nucl=0.0d0
 824        estr_nucl=0.0d0
 825        ecorr3_nucl=0.0d0
 826        ebe_nucl=0.0d0
 827        evdwsb=0.0d0
 828        eelsb=0.0d0
 829        esbloc=0.0d0
 830        evdwpsb=0.0d0
 831        eelpsb=0.0d0
 832        evdwpp=0.0d0
 833        eespp=0.0d0
 834       endif
 835 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 836 !      print *,"before ecatcat",wcatcat
 837       if (nfgtasks.gt.1) then
 838       if (fg_rank.eq.0) then
 839       call ecatcat(ecationcation)
 840       endif
 841       else
 842       call ecatcat(ecationcation)
 843       endif
 844       call ecat_prot(ecation_prot)
 845       if (nres_molec(2).gt.0) then
 846       call eprot_sc_base(escbase)
 847       call epep_sc_base(epepbase)
 848       call eprot_sc_phosphate(escpho)
 849       call eprot_pep_phosphate(epeppho)
 850       else
 851       epepbase=0.0
 852       escbase=0.0
 853       escpho=0.0
 854       epeppho=0.0
 855       endif
 856 !      call ecatcat(ecationcation)
 857 !      print *,"after ebend", ebe_nucl
 858 #ifdef TIMING
 859       time_enecalc=time_enecalc+MPI_Wtime()-time00
 860 #endif
 861 !      print *,"Processor",myrank," computed Uconstr"
 862 #ifdef TIMING
 863       time00=MPI_Wtime()
 864 #endif
 865 !
 866 ! Sum the energies
 867 !
 868       energia(1)=evdw
 869 #ifdef SCP14
 870       energia(2)=evdw2-evdw2_14
 871       energia(18)=evdw2_14
 872 #else
 873       energia(2)=evdw2
 874       energia(18)=0.0d0
 875 #endif
 876 #ifdef SPLITELE
 877       energia(3)=ees
 878       energia(16)=evdw1
 879 #else
 880       energia(3)=ees+evdw1
 881       energia(16)=0.0d0
 882 #endif
 883       energia(4)=ecorr
 884       energia(5)=ecorr5
 885       energia(6)=ecorr6
 886       energia(7)=eel_loc
 887       energia(8)=eello_turn3
 888       energia(9)=eello_turn4
 889       energia(10)=eturn6
 890       energia(11)=ebe
 891       energia(12)=escloc
 892       energia(13)=etors
 893       energia(14)=etors_d
 894       energia(15)=ehpb
 895       energia(19)=edihcnstr
 896       energia(17)=estr
 897       energia(20)=Uconst+Uconst_back
 898       energia(21)=esccor
 899       energia(22)=eliptran
 900       energia(23)=Eafmforce
 901       energia(24)=ethetacnstr
 902       energia(25)=etube
 903 !---------------------------------------------------------------
 904       energia(26)=evdwpp
 905       energia(27)=eespp
 906       energia(28)=evdwpsb
 907       energia(29)=eelpsb
 908       energia(30)=evdwsb
 909       energia(31)=eelsb
 910       energia(32)=estr_nucl
 911       energia(33)=ebe_nucl
 912       energia(34)=esbloc
 913       energia(35)=etors_nucl
 914       energia(36)=etors_d_nucl
 915       energia(37)=ecorr_nucl
 916       energia(38)=ecorr3_nucl
 917 !----------------------------------------------------------------------
 918 !    Here are the energies showed per procesor if the are more processors
 919 !    per molecule then we sum it up in sum_energy subroutine
 920 !      print *," Processor",myrank," calls SUM_ENERGY"
 921       energia(42)=ecation_prot
 922       energia(41)=ecationcation
 923       energia(46)=escbase
 924       energia(47)=epepbase
 925       energia(48)=escpho
 926       energia(49)=epeppho
 927       call sum_energy(energia,.true.)
 928       if (dyn_ss) call dyn_set_nss
 929 !      print *," Processor",myrank," left SUM_ENERGY"
 930 #ifdef TIMING
 931       time_sumene=time_sumene+MPI_Wtime()-time00
 932 #endif
 933 !        call enerprint(energia)
 934 !elwrite(iout,*)"finish etotal"
 935       return
 936       end subroutine etotal
 937 !-----------------------------------------------------------------------------
 938       subroutine sum_energy(energia,reduce)
 939 !      implicit real*8 (a-h,o-z)
 940 !      include 'DIMENSIONS'
 941 #ifndef ISNAN
 942       external proc_proc
 943 #ifdef WINPGI
 944 !MS$ATTRIBUTES C ::  proc_proc
 945 #endif
 946 #endif
 947 #ifdef MPI
 948       include "mpif.h"
 949 #endif
 950 !      include 'COMMON.SETUP'
 951 !      include 'COMMON.IOUNITS'
 952       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 953 !      include 'COMMON.FFIELD'
 954 !      include 'COMMON.DERIV'
 955 !      include 'COMMON.INTERACT'
 956 !      include 'COMMON.SBRIDGE'
 957 !      include 'COMMON.CHAIN'
 958 !      include 'COMMON.VAR'
 959 !      include 'COMMON.CONTROL'
 960 !      include 'COMMON.TIME1'
 961       logical :: reduce
 962       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 963       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 964       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 965         eliptran,etube, Eafmforce,ethetacnstr
 966       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 967                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 968                       ecorr3_nucl
 969       real(kind=8) :: ecation_prot,ecationcation
 970       real(kind=8) :: escbase,epepbase,escpho,epeppho
 971       integer :: i
 972 #ifdef MPI
 973       integer :: ierr
 974       real(kind=8) :: time00
 975       if (nfgtasks.gt.1 .and. reduce) then
 976
 977 #ifdef DEBUG
 978         write (iout,*) "energies before REDUCE"
 979         call enerprint(energia)
 980         call flush(iout)
 981 #endif
 982         do i=0,n_ene
 983           enebuff(i)=energia(i)
 984         enddo
 985         time00=MPI_Wtime()
 986         call MPI_Barrier(FG_COMM,IERR)
 987         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 988         time00=MPI_Wtime()
 989         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 990           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 991 #ifdef DEBUG
 992         write (iout,*) "energies after REDUCE"
 993         call enerprint(energia)
 994         call flush(iout)
 995 #endif
 996         time_Reduce=time_Reduce+MPI_Wtime()-time00
 997       endif
 998       if (fg_rank.eq.0) then
 999 #endif
1000       evdw=energia(1)
1001 #ifdef SCP14
1002       evdw2=energia(2)+energia(18)
1003       evdw2_14=energia(18)
1004 #else
1005       evdw2=energia(2)
1006 #endif
1007 #ifdef SPLITELE
1008       ees=energia(3)
1009       evdw1=energia(16)
1010 #else
1011       ees=energia(3)
1012       evdw1=0.0d0
1013 #endif
1014       ecorr=energia(4)
1015       ecorr5=energia(5)
1016       ecorr6=energia(6)
1017       eel_loc=energia(7)
1018       eello_turn3=energia(8)
1019       eello_turn4=energia(9)
1020       eturn6=energia(10)
1021       ebe=energia(11)
1022       escloc=energia(12)
1023       etors=energia(13)
1024       etors_d=energia(14)
1025       ehpb=energia(15)
1026       edihcnstr=energia(19)
1027       estr=energia(17)
1028       Uconst=energia(20)
1029       esccor=energia(21)
1030       eliptran=energia(22)
1031       Eafmforce=energia(23)
1032       ethetacnstr=energia(24)
1033       etube=energia(25)
1034       evdwpp=energia(26)
1035       eespp=energia(27)
1036       evdwpsb=energia(28)
1037       eelpsb=energia(29)
1038       evdwsb=energia(30)
1039       eelsb=energia(31)
1040       estr_nucl=energia(32)
1041       ebe_nucl=energia(33)
1042       esbloc=energia(34)
1043       etors_nucl=energia(35)
1044       etors_d_nucl=energia(36)
1045       ecorr_nucl=energia(37)
1046       ecorr3_nucl=energia(38)
1047       ecation_prot=energia(42)
1048       ecationcation=energia(41)
1049       escbase=energia(46)
1050       epepbase=energia(47)
1051       escpho=energia(48)
1052       epeppho=energia(49)
1053 !      energia(41)=ecation_prot
1054 !      energia(42)=ecationcation
1055
1056
1057 #ifdef SPLITELE
1058       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1059        +wang*ebe+wtor*etors+wscloc*escloc &
1060        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1061        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1062        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1063        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1064        +Eafmforce+ethetacnstr  &
1065        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1066        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1067        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1068        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1069        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1070        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1071 #else
1072       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1073        +wang*ebe+wtor*etors+wscloc*escloc &
1074        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1075        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1076        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1077        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1078        +Eafmforce+ethetacnstr &
1079        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1080        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1081        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1082        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1083        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1084        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1085 #endif
1086       energia(0)=etot
1087 ! detecting NaNQ
1088 #ifdef ISNAN
1089 #ifdef AIX
1090       if (isnan(etot).ne.0) energia(0)=1.0d+99
1091 #else
1092       if (isnan(etot)) energia(0)=1.0d+99
1093 #endif
1094 #else
1095       i=0
1096 #ifdef WINPGI
1097       idumm=proc_proc(etot,i)
1098 #else
1099       call proc_proc(etot,i)
1100 #endif
1101       if(i.eq.1)energia(0)=1.0d+99
1102 #endif
1103 #ifdef MPI
1104       endif
1105 #endif
1106 !      call enerprint(energia)
1107       call flush(iout)
1108       return
1109       end subroutine sum_energy
1110 !-----------------------------------------------------------------------------
1111       subroutine rescale_weights(t_bath)
1112 !      implicit real*8 (a-h,o-z)
1113 #ifdef MPI
1114       include 'mpif.h'
1115 #endif
1116 !      include 'DIMENSIONS'
1117 !      include 'COMMON.IOUNITS'
1118 !      include 'COMMON.FFIELD'
1119 !      include 'COMMON.SBRIDGE'
1120       real(kind=8) :: kfac=2.4d0
1121       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1122 !el local variables
1123       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1124       real(kind=8) :: T0=3.0d2
1125       integer :: ierror
1126 !      facT=temp0/t_bath
1127 !      facT=2*temp0/(t_bath+temp0)
1128       if (rescale_mode.eq.0) then
1129         facT(1)=1.0d0
1130         facT(2)=1.0d0
1131         facT(3)=1.0d0
1132         facT(4)=1.0d0
1133         facT(5)=1.0d0
1134         facT(6)=1.0d0
1135       else if (rescale_mode.eq.1) then
1136         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1137         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1138         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1139         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1140         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1141 #ifdef WHAM_RUN
1142 !#if defined(WHAM_RUN) || defined(CLUSTER)
1143 #if defined(FUNCTH)
1144 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1145         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1146 #elif defined(FUNCT)
1147         facT(6)=t_bath/T0
1148 #else
1149         facT(6)=1.0d0
1150 #endif
1151 #endif
1152       else if (rescale_mode.eq.2) then
1153         x=t_bath/temp0
1154         x2=x*x
1155         x3=x2*x
1156         x4=x3*x
1157         x5=x4*x
1158         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1159         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1160         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1161         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1162         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1163 #ifdef WHAM_RUN
1164 !#if defined(WHAM_RUN) || defined(CLUSTER)
1165 #if defined(FUNCTH)
1166         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1167 #elif defined(FUNCT)
1168         facT(6)=t_bath/T0
1169 #else
1170         facT(6)=1.0d0
1171 #endif
1172 #endif
1173       else
1174         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1175         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1176 #ifdef MPI
1177        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1178 #endif
1179        stop 555
1180       endif
1181       welec=weights(3)*fact(1)
1182       wcorr=weights(4)*fact(3)
1183       wcorr5=weights(5)*fact(4)
1184       wcorr6=weights(6)*fact(5)
1185       wel_loc=weights(7)*fact(2)
1186       wturn3=weights(8)*fact(2)
1187       wturn4=weights(9)*fact(3)
1188       wturn6=weights(10)*fact(5)
1189       wtor=weights(13)*fact(1)
1190       wtor_d=weights(14)*fact(2)
1191       wsccor=weights(21)*fact(1)
1192
1193       return
1194       end subroutine rescale_weights
1195 !-----------------------------------------------------------------------------
1196       subroutine enerprint(energia)
1197 !      implicit real*8 (a-h,o-z)
1198 !      include 'DIMENSIONS'
1199 !      include 'COMMON.IOUNITS'
1200 !      include 'COMMON.FFIELD'
1201 !      include 'COMMON.SBRIDGE'
1202 !      include 'COMMON.MD'
1203       real(kind=8) :: energia(0:n_ene)
1204 !el local variables
1205       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1206       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1207       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1208        etube,ethetacnstr,Eafmforce
1209       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1210                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1211                       ecorr3_nucl
1212       real(kind=8) :: ecation_prot,ecationcation
1213       real(kind=8) :: escbase,epepbase,escpho,epeppho
1214
1215       etot=energia(0)
1216       evdw=energia(1)
1217       evdw2=energia(2)
1218 #ifdef SCP14
1219       evdw2=energia(2)+energia(18)
1220 #else
1221       evdw2=energia(2)
1222 #endif
1223       ees=energia(3)
1224 #ifdef SPLITELE
1225       evdw1=energia(16)
1226 #endif
1227       ecorr=energia(4)
1228       ecorr5=energia(5)
1229       ecorr6=energia(6)
1230       eel_loc=energia(7)
1231       eello_turn3=energia(8)
1232       eello_turn4=energia(9)
1233       eello_turn6=energia(10)
1234       ebe=energia(11)
1235       escloc=energia(12)
1236       etors=energia(13)
1237       etors_d=energia(14)
1238       ehpb=energia(15)
1239       edihcnstr=energia(19)
1240       estr=energia(17)
1241       Uconst=energia(20)
1242       esccor=energia(21)
1243       eliptran=energia(22)
1244       Eafmforce=energia(23)
1245       ethetacnstr=energia(24)
1246       etube=energia(25)
1247       evdwpp=energia(26)
1248       eespp=energia(27)
1249       evdwpsb=energia(28)
1250       eelpsb=energia(29)
1251       evdwsb=energia(30)
1252       eelsb=energia(31)
1253       estr_nucl=energia(32)
1254       ebe_nucl=energia(33)
1255       esbloc=energia(34)
1256       etors_nucl=energia(35)
1257       etors_d_nucl=energia(36)
1258       ecorr_nucl=energia(37)
1259       ecorr3_nucl=energia(38)
1260       ecation_prot=energia(42)
1261       ecationcation=energia(41)
1262       escbase=energia(46)
1263       epepbase=energia(47)
1264       escpho=energia(48)
1265       epeppho=energia(49)
1266 #ifdef SPLITELE
1267       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1268         estr,wbond,ebe,wang,&
1269         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1270         ecorr,wcorr,&
1271         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1272         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1273         edihcnstr,ethetacnstr,ebr*nss,&
1274         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1275         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1276         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1277         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1278         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1279         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1280         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1281         etot
1282    10 format (/'Virtual-chain energies:'// &
1283        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1284        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1285        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1286        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1287        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1288        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1289        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1290        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1291        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1292        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1293        ' (SS bridges & dist. cnstr.)'/ &
1294        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1295        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1296        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1297        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1298        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1299        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1300        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1301        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1302        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1303        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1304        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1305        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1306        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1307        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1308        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1309        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1310        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1311        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1312        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1313        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1314        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1315        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1316        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1317        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1318        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1319        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1320        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1321        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1322        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1323        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1324        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1325        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1326        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1327        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1328        'ETOT=  ',1pE16.6,' (total)')
1329 #else
1330       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1331         estr,wbond,ebe,wang,&
1332         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1333         ecorr,wcorr,&
1334         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1335         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1336         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1337         etube,wtube, &
1338         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1339         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1340         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1341         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1342         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1343         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1344         etot
1345    10 format (/'Virtual-chain energies:'// &
1346        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1347        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1348        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1349        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1350        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1351        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1352        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1353        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1354        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1355        ' (SS bridges & dist. cnstr.)'/ &
1356        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1357        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1358        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1359        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1360        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1361        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1362        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1363        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1364        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1365        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1366        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1367        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1368        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1369        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1370        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1371        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1372        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1373        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1374        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1375        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1376        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1377        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1378        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1379        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1380        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1381        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1382        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1383        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1384        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1385        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1386        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1387        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1388        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1389        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1390        'ETOT=  ',1pE16.6,' (total)')
1391 #endif
1392       return
1393       end subroutine enerprint
1394 !-----------------------------------------------------------------------------
1395       subroutine elj(evdw)
1396 !
1397 ! This subroutine calculates the interaction energy of nonbonded side chains
1398 ! assuming the LJ potential of interaction.
1399 !
1400 !      implicit real*8 (a-h,o-z)
1401 !      include 'DIMENSIONS'
1402       real(kind=8),parameter :: accur=1.0d-10
1403 !      include 'COMMON.GEO'
1404 !      include 'COMMON.VAR'
1405 !      include 'COMMON.LOCAL'
1406 !      include 'COMMON.CHAIN'
1407 !      include 'COMMON.DERIV'
1408 !      include 'COMMON.INTERACT'
1409 !      include 'COMMON.TORSION'
1410 !      include 'COMMON.SBRIDGE'
1411 !      include 'COMMON.NAMES'
1412 !      include 'COMMON.IOUNITS'
1413 !      include 'COMMON.CONTACTS'
1414       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1415       integer :: num_conti
1416 !el local variables
1417       integer :: i,itypi,iint,j,itypi1,itypj,k
1418       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1419       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1420       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1421
1422 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1423       evdw=0.0D0
1424 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1425 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1426 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1427 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1428
1429       do i=iatsc_s,iatsc_e
1430         itypi=iabs(itype(i,1))
1431         if (itypi.eq.ntyp1) cycle
1432         itypi1=iabs(itype(i+1,1))
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436 ! Change 12/1/95
1437         num_conti=0
1438 !
1439 ! Calculate SC interaction energy.
1440 !
1441         do iint=1,nint_gr(i)
1442 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1443 !d   &                  'iend=',iend(i,iint)
1444           do j=istart(i,iint),iend(i,iint)
1445             itypj=iabs(itype(j,1))
1446             if (itypj.eq.ntyp1) cycle
1447             xj=c(1,nres+j)-xi
1448             yj=c(2,nres+j)-yi
1449             zj=c(3,nres+j)-zi
1450 ! Change 12/1/95 to calculate four-body interactions
1451             rij=xj*xj+yj*yj+zj*zj
1452             rrij=1.0D0/rij
1453 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1454             eps0ij=eps(itypi,itypj)
1455             fac=rrij**expon2
1456             e1=fac*fac*aa_aq(itypi,itypj)
1457             e2=fac*bb_aq(itypi,itypj)
1458             evdwij=e1+e2
1459 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1460 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1461 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1462 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1463 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1464 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1465             evdw=evdw+evdwij
1466 !
1467 ! Calculate the components of the gradient in DC and X
1468 !
1469             fac=-rrij*(e1+evdwij)
1470             gg(1)=xj*fac
1471             gg(2)=yj*fac
1472             gg(3)=zj*fac
1473             do k=1,3
1474               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1475               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1476               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1477               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1478             enddo
1479 !grad            do k=i,j-1
1480 !grad              do l=1,3
1481 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1482 !grad              enddo
1483 !grad            enddo
1484 !
1485 ! 12/1/95, revised on 5/20/97
1486 !
1487 ! Calculate the contact function. The ith column of the array JCONT will
1488 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1489 ! greater than I). The arrays FACONT and GACONT will contain the values of
1490 ! the contact function and its derivative.
1491 !
1492 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1493 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1494 ! Uncomment next line, if the correlation interactions are contact function only
1495             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1496               rij=dsqrt(rij)
1497               sigij=sigma(itypi,itypj)
1498               r0ij=rs0(itypi,itypj)
1499 !
1500 ! Check whether the SC's are not too far to make a contact.
1501 !
1502               rcut=1.5d0*r0ij
1503               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1504 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1505 !
1506               if (fcont.gt.0.0D0) then
1507 ! If the SC-SC distance if close to sigma, apply spline.
1508 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1509 !Adam &             fcont1,fprimcont1)
1510 !Adam           fcont1=1.0d0-fcont1
1511 !Adam           if (fcont1.gt.0.0d0) then
1512 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1513 !Adam             fcont=fcont*fcont1
1514 !Adam           endif
1515 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1516 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1517 !ga             do k=1,3
1518 !ga               gg(k)=gg(k)*eps0ij
1519 !ga             enddo
1520 !ga             eps0ij=-evdwij*eps0ij
1521 ! Uncomment for AL's type of SC correlation interactions.
1522 !adam           eps0ij=-evdwij
1523                 num_conti=num_conti+1
1524                 jcont(num_conti,i)=j
1525                 facont(num_conti,i)=fcont*eps0ij
1526                 fprimcont=eps0ij*fprimcont/rij
1527                 fcont=expon*fcont
1528 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1529 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1530 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1531 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1532                 gacont(1,num_conti,i)=-fprimcont*xj
1533                 gacont(2,num_conti,i)=-fprimcont*yj
1534                 gacont(3,num_conti,i)=-fprimcont*zj
1535 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1536 !d              write (iout,'(2i3,3f10.5)')
1537 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1538               endif
1539             endif
1540           enddo      ! j
1541         enddo        ! iint
1542 ! Change 12/1/95
1543         num_cont(i)=num_conti
1544       enddo          ! i
1545       do i=1,nct
1546         do j=1,3
1547           gvdwc(j,i)=expon*gvdwc(j,i)
1548           gvdwx(j,i)=expon*gvdwx(j,i)
1549         enddo
1550       enddo
1551 !******************************************************************************
1552 !
1553 !                              N O T E !!!
1554 !
1555 ! To save time, the factor of EXPON has been extracted from ALL components
1556 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1557 ! use!
1558 !
1559 !******************************************************************************
1560       return
1561       end subroutine elj
1562 !-----------------------------------------------------------------------------
1563       subroutine eljk(evdw)
1564 !
1565 ! This subroutine calculates the interaction energy of nonbonded side chains
1566 ! assuming the LJK potential of interaction.
1567 !
1568 !      implicit real*8 (a-h,o-z)
1569 !      include 'DIMENSIONS'
1570 !      include 'COMMON.GEO'
1571 !      include 'COMMON.VAR'
1572 !      include 'COMMON.LOCAL'
1573 !      include 'COMMON.CHAIN'
1574 !      include 'COMMON.DERIV'
1575 !      include 'COMMON.INTERACT'
1576 !      include 'COMMON.IOUNITS'
1577 !      include 'COMMON.NAMES'
1578       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1579       logical :: scheck
1580 !el local variables
1581       integer :: i,iint,j,itypi,itypi1,k,itypj
1582       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1583       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1584
1585 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1586       evdw=0.0D0
1587       do i=iatsc_s,iatsc_e
1588         itypi=iabs(itype(i,1))
1589         if (itypi.eq.ntyp1) cycle
1590         itypi1=iabs(itype(i+1,1))
1591         xi=c(1,nres+i)
1592         yi=c(2,nres+i)
1593         zi=c(3,nres+i)
1594 !
1595 ! Calculate SC interaction energy.
1596 !
1597         do iint=1,nint_gr(i)
1598           do j=istart(i,iint),iend(i,iint)
1599             itypj=iabs(itype(j,1))
1600             if (itypj.eq.ntyp1) cycle
1601             xj=c(1,nres+j)-xi
1602             yj=c(2,nres+j)-yi
1603             zj=c(3,nres+j)-zi
1604             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1605             fac_augm=rrij**expon
1606             e_augm=augm(itypi,itypj)*fac_augm
1607             r_inv_ij=dsqrt(rrij)
1608             rij=1.0D0/r_inv_ij
1609             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1610             fac=r_shift_inv**expon
1611             e1=fac*fac*aa_aq(itypi,itypj)
1612             e2=fac*bb_aq(itypi,itypj)
1613             evdwij=e_augm+e1+e2
1614 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1615 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1616 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1617 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1618 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1619 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1620 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1621             evdw=evdw+evdwij
1622 !
1623 ! Calculate the components of the gradient in DC and X
1624 !
1625             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1626             gg(1)=xj*fac
1627             gg(2)=yj*fac
1628             gg(3)=zj*fac
1629             do k=1,3
1630               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1631               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1632               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1633               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1634             enddo
1635 !grad            do k=i,j-1
1636 !grad              do l=1,3
1637 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1638 !grad              enddo
1639 !grad            enddo
1640           enddo      ! j
1641         enddo        ! iint
1642       enddo          ! i
1643       do i=1,nct
1644         do j=1,3
1645           gvdwc(j,i)=expon*gvdwc(j,i)
1646           gvdwx(j,i)=expon*gvdwx(j,i)
1647         enddo
1648       enddo
1649       return
1650       end subroutine eljk
1651 !-----------------------------------------------------------------------------
1652       subroutine ebp(evdw)
1653 !
1654 ! This subroutine calculates the interaction energy of nonbonded side chains
1655 ! assuming the Berne-Pechukas potential of interaction.
1656 !
1657       use comm_srutu
1658       use calc_data
1659 !      implicit real*8 (a-h,o-z)
1660 !      include 'DIMENSIONS'
1661 !      include 'COMMON.GEO'
1662 !      include 'COMMON.VAR'
1663 !      include 'COMMON.LOCAL'
1664 !      include 'COMMON.CHAIN'
1665 !      include 'COMMON.DERIV'
1666 !      include 'COMMON.NAMES'
1667 !      include 'COMMON.INTERACT'
1668 !      include 'COMMON.IOUNITS'
1669 !      include 'COMMON.CALC'
1670       use comm_srutu
1671 !el      integer :: icall
1672 !el      common /srutu/ icall
1673 !     double precision rrsave(maxdim)
1674       logical :: lprn
1675 !el local variables
1676       integer :: iint,itypi,itypi1,itypj
1677       real(kind=8) :: rrij,xi,yi,zi
1678       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1679
1680 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1681       evdw=0.0D0
1682 !     if (icall.eq.0) then
1683 !       lprn=.true.
1684 !     else
1685         lprn=.false.
1686 !     endif
1687 !el      ind=0
1688       do i=iatsc_s,iatsc_e
1689         itypi=iabs(itype(i,1))
1690         if (itypi.eq.ntyp1) cycle
1691         itypi1=iabs(itype(i+1,1))
1692         xi=c(1,nres+i)
1693         yi=c(2,nres+i)
1694         zi=c(3,nres+i)
1695         dxi=dc_norm(1,nres+i)
1696         dyi=dc_norm(2,nres+i)
1697         dzi=dc_norm(3,nres+i)
1698 !        dsci_inv=dsc_inv(itypi)
1699         dsci_inv=vbld_inv(i+nres)
1700 !
1701 ! Calculate SC interaction energy.
1702 !
1703         do iint=1,nint_gr(i)
1704           do j=istart(i,iint),iend(i,iint)
1705 !el            ind=ind+1
1706             itypj=iabs(itype(j,1))
1707             if (itypj.eq.ntyp1) cycle
1708 !            dscj_inv=dsc_inv(itypj)
1709             dscj_inv=vbld_inv(j+nres)
1710             chi1=chi(itypi,itypj)
1711             chi2=chi(itypj,itypi)
1712             chi12=chi1*chi2
1713             chip1=chip(itypi)
1714             chip2=chip(itypj)
1715             chip12=chip1*chip2
1716             alf1=alp(itypi)
1717             alf2=alp(itypj)
1718             alf12=0.5D0*(alf1+alf2)
1719 ! For diagnostics only!!!
1720 !           chi1=0.0D0
1721 !           chi2=0.0D0
1722 !           chi12=0.0D0
1723 !           chip1=0.0D0
1724 !           chip2=0.0D0
1725 !           chip12=0.0D0
1726 !           alf1=0.0D0
1727 !           alf2=0.0D0
1728 !           alf12=0.0D0
1729             xj=c(1,nres+j)-xi
1730             yj=c(2,nres+j)-yi
1731             zj=c(3,nres+j)-zi
1732             dxj=dc_norm(1,nres+j)
1733             dyj=dc_norm(2,nres+j)
1734             dzj=dc_norm(3,nres+j)
1735             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1736 !d          if (icall.eq.0) then
1737 !d            rrsave(ind)=rrij
1738 !d          else
1739 !d            rrij=rrsave(ind)
1740 !d          endif
1741             rij=dsqrt(rrij)
1742 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1743             call sc_angular
1744 ! Calculate whole angle-dependent part of epsilon and contributions
1745 ! to its derivatives
1746             fac=(rrij*sigsq)**expon2
1747             e1=fac*fac*aa_aq(itypi,itypj)
1748             e2=fac*bb_aq(itypi,itypj)
1749             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1750             eps2der=evdwij*eps3rt
1751             eps3der=evdwij*eps2rt
1752             evdwij=evdwij*eps2rt*eps3rt
1753             evdw=evdw+evdwij
1754             if (lprn) then
1755             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1756             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1757 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1758 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1759 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1760 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1761 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1762 !d     &        evdwij
1763             endif
1764 ! Calculate gradient components.
1765             e1=e1*eps1*eps2rt**2*eps3rt**2
1766             fac=-expon*(e1+evdwij)
1767             sigder=fac/sigsq
1768             fac=rrij*fac
1769 ! Calculate radial part of the gradient
1770             gg(1)=xj*fac
1771             gg(2)=yj*fac
1772             gg(3)=zj*fac
1773 ! Calculate the angular part of the gradient and sum add the contributions
1774 ! to the appropriate components of the Cartesian gradient.
1775             call sc_grad
1776           enddo      ! j
1777         enddo        ! iint
1778       enddo          ! i
1779 !     stop
1780       return
1781       end subroutine ebp
1782 !-----------------------------------------------------------------------------
1783       subroutine egb(evdw)
1784 !
1785 ! This subroutine calculates the interaction energy of nonbonded side chains
1786 ! assuming the Gay-Berne potential of interaction.
1787 !
1788       use calc_data
1789 !      implicit real*8 (a-h,o-z)
1790 !      include 'DIMENSIONS'
1791 !      include 'COMMON.GEO'
1792 !      include 'COMMON.VAR'
1793 !      include 'COMMON.LOCAL'
1794 !      include 'COMMON.CHAIN'
1795 !      include 'COMMON.DERIV'
1796 !      include 'COMMON.NAMES'
1797 !      include 'COMMON.INTERACT'
1798 !      include 'COMMON.IOUNITS'
1799 !      include 'COMMON.CALC'
1800 !      include 'COMMON.CONTROL'
1801 !      include 'COMMON.SBRIDGE'
1802       logical :: lprn
1803 !el local variables
1804       integer :: iint,itypi,itypi1,itypj,subchap
1805       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1806       real(kind=8) :: evdw,sig0ij
1807       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1808                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1809                     sslipi,sslipj,faclip
1810       integer :: ii
1811       real(kind=8) :: fracinbuf
1812
1813 !cccc      energy_dec=.false.
1814 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1815       evdw=0.0D0
1816       lprn=.false.
1817 !     if (icall.eq.0) lprn=.false.
1818 !el      ind=0
1819       dCAVdOM2=0.0d0
1820       dGCLdOM2=0.0d0
1821       dPOLdOM2=0.0d0
1822       dCAVdOM1=0.0d0
1823       dGCLdOM1=0.0d0
1824       dPOLdOM1=0.0d0
1825
1826
1827       do i=iatsc_s,iatsc_e
1828 !C        print *,"I am in EVDW",i
1829         itypi=iabs(itype(i,1))
1830 !        if (i.ne.47) cycle
1831         if (itypi.eq.ntyp1) cycle
1832         itypi1=iabs(itype(i+1,1))
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836           xi=dmod(xi,boxxsize)
1837           if (xi.lt.0) xi=xi+boxxsize
1838           yi=dmod(yi,boxysize)
1839           if (yi.lt.0) yi=yi+boxysize
1840           zi=dmod(zi,boxzsize)
1841           if (zi.lt.0) zi=zi+boxzsize
1842
1843        if ((zi.gt.bordlipbot)  &
1844         .and.(zi.lt.bordliptop)) then
1845 !C the energy transfer exist
1846         if (zi.lt.buflipbot) then
1847 !C what fraction I am in
1848          fracinbuf=1.0d0-  &
1849               ((zi-bordlipbot)/lipbufthick)
1850 !C lipbufthick is thickenes of lipid buffore
1851          sslipi=sscalelip(fracinbuf)
1852          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1853         elseif (zi.gt.bufliptop) then
1854          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1855          sslipi=sscalelip(fracinbuf)
1856          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1857         else
1858          sslipi=1.0d0
1859          ssgradlipi=0.0
1860         endif
1861        else
1862          sslipi=0.0d0
1863          ssgradlipi=0.0
1864        endif
1865 !       print *, sslipi,ssgradlipi
1866         dxi=dc_norm(1,nres+i)
1867         dyi=dc_norm(2,nres+i)
1868         dzi=dc_norm(3,nres+i)
1869 !        dsci_inv=dsc_inv(itypi)
1870         dsci_inv=vbld_inv(i+nres)
1871 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1872 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1873 !
1874 ! Calculate SC interaction energy.
1875 !
1876         do iint=1,nint_gr(i)
1877           do j=istart(i,iint),iend(i,iint)
1878             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1879               call dyn_ssbond_ene(i,j,evdwij)
1880               evdw=evdw+evdwij
1881               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1882                               'evdw',i,j,evdwij,' ss'
1883 !              if (energy_dec) write (iout,*) &
1884 !                              'evdw',i,j,evdwij,' ss'
1885              do k=j+1,iend(i,iint)
1886 !C search over all next residues
1887               if (dyn_ss_mask(k)) then
1888 !C check if they are cysteins
1889 !C              write(iout,*) 'k=',k
1890
1891 !c              write(iout,*) "PRZED TRI", evdwij
1892 !               evdwij_przed_tri=evdwij
1893               call triple_ssbond_ene(i,j,k,evdwij)
1894 !c               if(evdwij_przed_tri.ne.evdwij) then
1895 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1896 !c               endif
1897
1898 !c              write(iout,*) "PO TRI", evdwij
1899 !C call the energy function that removes the artifical triple disulfide
1900 !C bond the soubroutine is located in ssMD.F
1901               evdw=evdw+evdwij
1902               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1903                             'evdw',i,j,evdwij,'tss'
1904               endif!dyn_ss_mask(k)
1905              enddo! k
1906             ELSE
1907 !el            ind=ind+1
1908             itypj=iabs(itype(j,1))
1909             if (itypj.eq.ntyp1) cycle
1910 !             if (j.ne.78) cycle
1911 !            dscj_inv=dsc_inv(itypj)
1912             dscj_inv=vbld_inv(j+nres)
1913 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1914 !              1.0d0/vbld(j+nres) !d
1915 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1916             sig0ij=sigma(itypi,itypj)
1917             chi1=chi(itypi,itypj)
1918             chi2=chi(itypj,itypi)
1919             chi12=chi1*chi2
1920             chip1=chip(itypi)
1921             chip2=chip(itypj)
1922             chip12=chip1*chip2
1923             alf1=alp(itypi)
1924             alf2=alp(itypj)
1925             alf12=0.5D0*(alf1+alf2)
1926 ! For diagnostics only!!!
1927 !           chi1=0.0D0
1928 !           chi2=0.0D0
1929 !           chi12=0.0D0
1930 !           chip1=0.0D0
1931 !           chip2=0.0D0
1932 !           chip12=0.0D0
1933 !           alf1=0.0D0
1934 !           alf2=0.0D0
1935 !           alf12=0.0D0
1936            xj=c(1,nres+j)
1937            yj=c(2,nres+j)
1938            zj=c(3,nres+j)
1939           xj=dmod(xj,boxxsize)
1940           if (xj.lt.0) xj=xj+boxxsize
1941           yj=dmod(yj,boxysize)
1942           if (yj.lt.0) yj=yj+boxysize
1943           zj=dmod(zj,boxzsize)
1944           if (zj.lt.0) zj=zj+boxzsize
1945 !          print *,"tu",xi,yi,zi,xj,yj,zj
1946 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1947 ! this fragment set correct epsilon for lipid phase
1948        if ((zj.gt.bordlipbot)  &
1949        .and.(zj.lt.bordliptop)) then
1950 !C the energy transfer exist
1951         if (zj.lt.buflipbot) then
1952 !C what fraction I am in
1953          fracinbuf=1.0d0-     &
1954              ((zj-bordlipbot)/lipbufthick)
1955 !C lipbufthick is thickenes of lipid buffore
1956          sslipj=sscalelip(fracinbuf)
1957          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1958         elseif (zj.gt.bufliptop) then
1959          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1960          sslipj=sscalelip(fracinbuf)
1961          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1962         else
1963          sslipj=1.0d0
1964          ssgradlipj=0.0
1965         endif
1966        else
1967          sslipj=0.0d0
1968          ssgradlipj=0.0
1969        endif
1970       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1971        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1972       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1973        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1974 !------------------------------------------------
1975       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1976       xj_safe=xj
1977       yj_safe=yj
1978       zj_safe=zj
1979       subchap=0
1980       do xshift=-1,1
1981       do yshift=-1,1
1982       do zshift=-1,1
1983           xj=xj_safe+xshift*boxxsize
1984           yj=yj_safe+yshift*boxysize
1985           zj=zj_safe+zshift*boxzsize
1986           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1987           if(dist_temp.lt.dist_init) then
1988             dist_init=dist_temp
1989             xj_temp=xj
1990             yj_temp=yj
1991             zj_temp=zj
1992             subchap=1
1993           endif
1994        enddo
1995        enddo
1996        enddo
1997        if (subchap.eq.1) then
1998           xj=xj_temp-xi
1999           yj=yj_temp-yi
2000           zj=zj_temp-zi
2001        else
2002           xj=xj_safe-xi
2003           yj=yj_safe-yi
2004           zj=zj_safe-zi
2005        endif
2006             dxj=dc_norm(1,nres+j)
2007             dyj=dc_norm(2,nres+j)
2008             dzj=dc_norm(3,nres+j)
2009 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2010 !            write (iout,*) "j",j," dc_norm",& !d
2011 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2012 !          write(iout,*)"rrij ",rrij
2013 !          write(iout,*)"xj yj zj ", xj, yj, zj
2014 !          write(iout,*)"xi yi zi ", xi, yi, zi
2015 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2016             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2017             rij=dsqrt(rrij)
2018             sss_ele_cut=sscale_ele(1.0d0/(rij))
2019             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2020 !            print *,sss_ele_cut,sss_ele_grad,&
2021 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2022             if (sss_ele_cut.le.0.0) cycle
2023 ! Calculate angle-dependent terms of energy and contributions to their
2024 ! derivatives.
2025             call sc_angular
2026             sigsq=1.0D0/sigsq
2027             sig=sig0ij*dsqrt(sigsq)
2028             rij_shift=1.0D0/rij-sig+sig0ij
2029 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2030 !            "sig0ij",sig0ij
2031 ! for diagnostics; uncomment
2032 !            rij_shift=1.2*sig0ij
2033 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2034             if (rij_shift.le.0.0D0) then
2035               evdw=1.0D20
2036 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2037 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2038 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2039               return
2040             endif
2041             sigder=-sig*sigsq
2042 !---------------------------------------------------------------
2043             rij_shift=1.0D0/rij_shift
2044             fac=rij_shift**expon
2045             faclip=fac
2046             e1=fac*fac*aa!(itypi,itypj)
2047             e2=fac*bb!(itypi,itypj)
2048             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2049             eps2der=evdwij*eps3rt
2050             eps3der=evdwij*eps2rt
2051 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2052 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2053 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2054             evdwij=evdwij*eps2rt*eps3rt
2055             evdw=evdw+evdwij*sss_ele_cut
2056             if (lprn) then
2057             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2058             epsi=bb**2/aa!(itypi,itypj)
2059             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2060               restyp(itypi,1),i,restyp(itypj,1),j, &
2061               epsi,sigm,chi1,chi2,chip1,chip2, &
2062               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2063               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2064               evdwij
2065             endif
2066
2067             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2068                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2069 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2070 !            if (energy_dec) write (iout,*) &
2071 !                             'evdw',i,j,evdwij
2072 !                       print *,"ZALAMKA", evdw
2073
2074 ! Calculate gradient components.
2075             e1=e1*eps1*eps2rt**2*eps3rt**2
2076             fac=-expon*(e1+evdwij)*rij_shift
2077             sigder=fac*sigder
2078             fac=rij*fac
2079 !            print *,'before fac',fac,rij,evdwij
2080             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2081             *rij
2082 !            print *,'grad part scale',fac,   &
2083 !             evdwij*sss_ele_grad/sss_ele_cut &
2084 !            /sigma(itypi,itypj)*rij
2085 !            fac=0.0d0
2086 ! Calculate the radial part of the gradient
2087             gg(1)=xj*fac
2088             gg(2)=yj*fac
2089             gg(3)=zj*fac
2090 !C Calculate the radial part of the gradient
2091             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2092        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2093         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2094        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2095             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2096             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2097
2098 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2099 ! Calculate angular part of the gradient.
2100             call sc_grad
2101             ENDIF    ! dyn_ss
2102           enddo      ! j
2103         enddo        ! iint
2104       enddo          ! i
2105 !       print *,"ZALAMKA", evdw
2106 !      write (iout,*) "Number of loop steps in EGB:",ind
2107 !ccc      energy_dec=.false.
2108       return
2109       end subroutine egb
2110 !-----------------------------------------------------------------------------
2111       subroutine egbv(evdw)
2112 !
2113 ! This subroutine calculates the interaction energy of nonbonded side chains
2114 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2115 !
2116       use comm_srutu
2117       use calc_data
2118 !      implicit real*8 (a-h,o-z)
2119 !      include 'DIMENSIONS'
2120 !      include 'COMMON.GEO'
2121 !      include 'COMMON.VAR'
2122 !      include 'COMMON.LOCAL'
2123 !      include 'COMMON.CHAIN'
2124 !      include 'COMMON.DERIV'
2125 !      include 'COMMON.NAMES'
2126 !      include 'COMMON.INTERACT'
2127 !      include 'COMMON.IOUNITS'
2128 !      include 'COMMON.CALC'
2129       use comm_srutu
2130 !el      integer :: icall
2131 !el      common /srutu/ icall
2132       logical :: lprn
2133 !el local variables
2134       integer :: iint,itypi,itypi1,itypj
2135       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2136       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2137
2138 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2139       evdw=0.0D0
2140       lprn=.false.
2141 !     if (icall.eq.0) lprn=.true.
2142 !el      ind=0
2143       do i=iatsc_s,iatsc_e
2144         itypi=iabs(itype(i,1))
2145         if (itypi.eq.ntyp1) cycle
2146         itypi1=iabs(itype(i+1,1))
2147         xi=c(1,nres+i)
2148         yi=c(2,nres+i)
2149         zi=c(3,nres+i)
2150         dxi=dc_norm(1,nres+i)
2151         dyi=dc_norm(2,nres+i)
2152         dzi=dc_norm(3,nres+i)
2153 !        dsci_inv=dsc_inv(itypi)
2154         dsci_inv=vbld_inv(i+nres)
2155 !
2156 ! Calculate SC interaction energy.
2157 !
2158         do iint=1,nint_gr(i)
2159           do j=istart(i,iint),iend(i,iint)
2160 !el            ind=ind+1
2161             itypj=iabs(itype(j,1))
2162             if (itypj.eq.ntyp1) cycle
2163 !            dscj_inv=dsc_inv(itypj)
2164             dscj_inv=vbld_inv(j+nres)
2165             sig0ij=sigma(itypi,itypj)
2166             r0ij=r0(itypi,itypj)
2167             chi1=chi(itypi,itypj)
2168             chi2=chi(itypj,itypi)
2169             chi12=chi1*chi2
2170             chip1=chip(itypi)
2171             chip2=chip(itypj)
2172             chip12=chip1*chip2
2173             alf1=alp(itypi)
2174             alf2=alp(itypj)
2175             alf12=0.5D0*(alf1+alf2)
2176 ! For diagnostics only!!!
2177 !           chi1=0.0D0
2178 !           chi2=0.0D0
2179 !           chi12=0.0D0
2180 !           chip1=0.0D0
2181 !           chip2=0.0D0
2182 !           chip12=0.0D0
2183 !           alf1=0.0D0
2184 !           alf2=0.0D0
2185 !           alf12=0.0D0
2186             xj=c(1,nres+j)-xi
2187             yj=c(2,nres+j)-yi
2188             zj=c(3,nres+j)-zi
2189             dxj=dc_norm(1,nres+j)
2190             dyj=dc_norm(2,nres+j)
2191             dzj=dc_norm(3,nres+j)
2192             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2193             rij=dsqrt(rrij)
2194 ! Calculate angle-dependent terms of energy and contributions to their
2195 ! derivatives.
2196             call sc_angular
2197             sigsq=1.0D0/sigsq
2198             sig=sig0ij*dsqrt(sigsq)
2199             rij_shift=1.0D0/rij-sig+r0ij
2200 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2201             if (rij_shift.le.0.0D0) then
2202               evdw=1.0D20
2203               return
2204             endif
2205             sigder=-sig*sigsq
2206 !---------------------------------------------------------------
2207             rij_shift=1.0D0/rij_shift
2208             fac=rij_shift**expon
2209             e1=fac*fac*aa_aq(itypi,itypj)
2210             e2=fac*bb_aq(itypi,itypj)
2211             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2212             eps2der=evdwij*eps3rt
2213             eps3der=evdwij*eps2rt
2214             fac_augm=rrij**expon
2215             e_augm=augm(itypi,itypj)*fac_augm
2216             evdwij=evdwij*eps2rt*eps3rt
2217             evdw=evdw+evdwij+e_augm
2218             if (lprn) then
2219             sigm=dabs(aa_aq(itypi,itypj)/&
2220             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2221             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2222             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2223               restyp(itypi,1),i,restyp(itypj,1),j,&
2224               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2225               chi1,chi2,chip1,chip2,&
2226               eps1,eps2rt**2,eps3rt**2,&
2227               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2228               evdwij+e_augm
2229             endif
2230 ! Calculate gradient components.
2231             e1=e1*eps1*eps2rt**2*eps3rt**2
2232             fac=-expon*(e1+evdwij)*rij_shift
2233             sigder=fac*sigder
2234             fac=rij*fac-2*expon*rrij*e_augm
2235 ! Calculate the radial part of the gradient
2236             gg(1)=xj*fac
2237             gg(2)=yj*fac
2238             gg(3)=zj*fac
2239 ! Calculate angular part of the gradient.
2240             call sc_grad
2241           enddo      ! j
2242         enddo        ! iint
2243       enddo          ! i
2244       end subroutine egbv
2245 !-----------------------------------------------------------------------------
2246 !el      subroutine sc_angular in module geometry
2247 !-----------------------------------------------------------------------------
2248       subroutine e_softsphere(evdw)
2249 !
2250 ! This subroutine calculates the interaction energy of nonbonded side chains
2251 ! assuming the LJ potential of interaction.
2252 !
2253 !      implicit real*8 (a-h,o-z)
2254 !      include 'DIMENSIONS'
2255       real(kind=8),parameter :: accur=1.0d-10
2256 !      include 'COMMON.GEO'
2257 !      include 'COMMON.VAR'
2258 !      include 'COMMON.LOCAL'
2259 !      include 'COMMON.CHAIN'
2260 !      include 'COMMON.DERIV'
2261 !      include 'COMMON.INTERACT'
2262 !      include 'COMMON.TORSION'
2263 !      include 'COMMON.SBRIDGE'
2264 !      include 'COMMON.NAMES'
2265 !      include 'COMMON.IOUNITS'
2266 !      include 'COMMON.CONTACTS'
2267       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2268 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2269 !el local variables
2270       integer :: i,iint,j,itypi,itypi1,itypj,k
2271       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2272       real(kind=8) :: fac
2273
2274       evdw=0.0D0
2275       do i=iatsc_s,iatsc_e
2276         itypi=iabs(itype(i,1))
2277         if (itypi.eq.ntyp1) cycle
2278         itypi1=iabs(itype(i+1,1))
2279         xi=c(1,nres+i)
2280         yi=c(2,nres+i)
2281         zi=c(3,nres+i)
2282 !
2283 ! Calculate SC interaction energy.
2284 !
2285         do iint=1,nint_gr(i)
2286 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2287 !d   &                  'iend=',iend(i,iint)
2288           do j=istart(i,iint),iend(i,iint)
2289             itypj=iabs(itype(j,1))
2290             if (itypj.eq.ntyp1) cycle
2291             xj=c(1,nres+j)-xi
2292             yj=c(2,nres+j)-yi
2293             zj=c(3,nres+j)-zi
2294             rij=xj*xj+yj*yj+zj*zj
2295 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2296             r0ij=r0(itypi,itypj)
2297             r0ijsq=r0ij*r0ij
2298 !            print *,i,j,r0ij,dsqrt(rij)
2299             if (rij.lt.r0ijsq) then
2300               evdwij=0.25d0*(rij-r0ijsq)**2
2301               fac=rij-r0ijsq
2302             else
2303               evdwij=0.0d0
2304               fac=0.0d0
2305             endif
2306             evdw=evdw+evdwij
2307 !
2308 ! Calculate the components of the gradient in DC and X
2309 !
2310             gg(1)=xj*fac
2311             gg(2)=yj*fac
2312             gg(3)=zj*fac
2313             do k=1,3
2314               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2315               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2316               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2317               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2318             enddo
2319 !grad            do k=i,j-1
2320 !grad              do l=1,3
2321 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2322 !grad              enddo
2323 !grad            enddo
2324           enddo ! j
2325         enddo ! iint
2326       enddo ! i
2327       return
2328       end subroutine e_softsphere
2329 !-----------------------------------------------------------------------------
2330       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2331 !
2332 ! Soft-sphere potential of p-p interaction
2333 !
2334 !      implicit real*8 (a-h,o-z)
2335 !      include 'DIMENSIONS'
2336 !      include 'COMMON.CONTROL'
2337 !      include 'COMMON.IOUNITS'
2338 !      include 'COMMON.GEO'
2339 !      include 'COMMON.VAR'
2340 !      include 'COMMON.LOCAL'
2341 !      include 'COMMON.CHAIN'
2342 !      include 'COMMON.DERIV'
2343 !      include 'COMMON.INTERACT'
2344 !      include 'COMMON.CONTACTS'
2345 !      include 'COMMON.TORSION'
2346 !      include 'COMMON.VECTORS'
2347 !      include 'COMMON.FFIELD'
2348       real(kind=8),dimension(3) :: ggg
2349 !d      write(iout,*) 'In EELEC_soft_sphere'
2350 !el local variables
2351       integer :: i,j,k,num_conti,iteli,itelj
2352       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2353       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2354       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2355
2356       ees=0.0D0
2357       evdw1=0.0D0
2358       eel_loc=0.0d0
2359       eello_turn3=0.0d0
2360       eello_turn4=0.0d0
2361 !el      ind=0
2362       do i=iatel_s,iatel_e
2363         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2364         dxi=dc(1,i)
2365         dyi=dc(2,i)
2366         dzi=dc(3,i)
2367         xmedi=c(1,i)+0.5d0*dxi
2368         ymedi=c(2,i)+0.5d0*dyi
2369         zmedi=c(3,i)+0.5d0*dzi
2370         num_conti=0
2371 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2372         do j=ielstart(i),ielend(i)
2373           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2374 !el          ind=ind+1
2375           iteli=itel(i)
2376           itelj=itel(j)
2377           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2378           r0ij=rpp(iteli,itelj)
2379           r0ijsq=r0ij*r0ij
2380           dxj=dc(1,j)
2381           dyj=dc(2,j)
2382           dzj=dc(3,j)
2383           xj=c(1,j)+0.5D0*dxj-xmedi
2384           yj=c(2,j)+0.5D0*dyj-ymedi
2385           zj=c(3,j)+0.5D0*dzj-zmedi
2386           rij=xj*xj+yj*yj+zj*zj
2387           if (rij.lt.r0ijsq) then
2388             evdw1ij=0.25d0*(rij-r0ijsq)**2
2389             fac=rij-r0ijsq
2390           else
2391             evdw1ij=0.0d0
2392             fac=0.0d0
2393           endif
2394           evdw1=evdw1+evdw1ij
2395 !
2396 ! Calculate contributions to the Cartesian gradient.
2397 !
2398           ggg(1)=fac*xj
2399           ggg(2)=fac*yj
2400           ggg(3)=fac*zj
2401           do k=1,3
2402             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2403             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2404           enddo
2405 !
2406 ! Loop over residues i+1 thru j-1.
2407 !
2408 !grad          do k=i+1,j-1
2409 !grad            do l=1,3
2410 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2411 !grad            enddo
2412 !grad          enddo
2413         enddo ! j
2414       enddo   ! i
2415 !grad      do i=nnt,nct-1
2416 !grad        do k=1,3
2417 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2418 !grad        enddo
2419 !grad        do j=i+1,nct-1
2420 !grad          do k=1,3
2421 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2422 !grad          enddo
2423 !grad        enddo
2424 !grad      enddo
2425       return
2426       end subroutine eelec_soft_sphere
2427 !-----------------------------------------------------------------------------
2428       subroutine vec_and_deriv
2429 !      implicit real*8 (a-h,o-z)
2430 !      include 'DIMENSIONS'
2431 #ifdef MPI
2432       include 'mpif.h'
2433 #endif
2434 !      include 'COMMON.IOUNITS'
2435 !      include 'COMMON.GEO'
2436 !      include 'COMMON.VAR'
2437 !      include 'COMMON.LOCAL'
2438 !      include 'COMMON.CHAIN'
2439 !      include 'COMMON.VECTORS'
2440 !      include 'COMMON.SETUP'
2441 !      include 'COMMON.TIME1'
2442       real(kind=8),dimension(3,3,2) :: uyder,uzder
2443       real(kind=8),dimension(2) :: vbld_inv_temp
2444 ! Compute the local reference systems. For reference system (i), the
2445 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2446 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2447 !el local variables
2448       integer :: i,j,k,l
2449       real(kind=8) :: facy,fac,costh
2450
2451 #ifdef PARVEC
2452       do i=ivec_start,ivec_end
2453 #else
2454       do i=1,nres-1
2455 #endif
2456           if (i.eq.nres-1) then
2457 ! Case of the last full residue
2458 ! Compute the Z-axis
2459             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2460             costh=dcos(pi-theta(nres))
2461             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2462             do k=1,3
2463               uz(k,i)=fac*uz(k,i)
2464             enddo
2465 ! Compute the derivatives of uz
2466             uzder(1,1,1)= 0.0d0
2467             uzder(2,1,1)=-dc_norm(3,i-1)
2468             uzder(3,1,1)= dc_norm(2,i-1)
2469             uzder(1,2,1)= dc_norm(3,i-1)
2470             uzder(2,2,1)= 0.0d0
2471             uzder(3,2,1)=-dc_norm(1,i-1)
2472             uzder(1,3,1)=-dc_norm(2,i-1)
2473             uzder(2,3,1)= dc_norm(1,i-1)
2474             uzder(3,3,1)= 0.0d0
2475             uzder(1,1,2)= 0.0d0
2476             uzder(2,1,2)= dc_norm(3,i)
2477             uzder(3,1,2)=-dc_norm(2,i)
2478             uzder(1,2,2)=-dc_norm(3,i)
2479             uzder(2,2,2)= 0.0d0
2480             uzder(3,2,2)= dc_norm(1,i)
2481             uzder(1,3,2)= dc_norm(2,i)
2482             uzder(2,3,2)=-dc_norm(1,i)
2483             uzder(3,3,2)= 0.0d0
2484 ! Compute the Y-axis
2485             facy=fac
2486             do k=1,3
2487               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2488             enddo
2489 ! Compute the derivatives of uy
2490             do j=1,3
2491               do k=1,3
2492                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2493                               -dc_norm(k,i)*dc_norm(j,i-1)
2494                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2495               enddo
2496               uyder(j,j,1)=uyder(j,j,1)-costh
2497               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2498             enddo
2499             do j=1,2
2500               do k=1,3
2501                 do l=1,3
2502                   uygrad(l,k,j,i)=uyder(l,k,j)
2503                   uzgrad(l,k,j,i)=uzder(l,k,j)
2504                 enddo
2505               enddo
2506             enddo
2507             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2508             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2509             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2510             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2511           else
2512 ! Other residues
2513 ! Compute the Z-axis
2514             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2515             costh=dcos(pi-theta(i+2))
2516             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2517             do k=1,3
2518               uz(k,i)=fac*uz(k,i)
2519             enddo
2520 ! Compute the derivatives of uz
2521             uzder(1,1,1)= 0.0d0
2522             uzder(2,1,1)=-dc_norm(3,i+1)
2523             uzder(3,1,1)= dc_norm(2,i+1)
2524             uzder(1,2,1)= dc_norm(3,i+1)
2525             uzder(2,2,1)= 0.0d0
2526             uzder(3,2,1)=-dc_norm(1,i+1)
2527             uzder(1,3,1)=-dc_norm(2,i+1)
2528             uzder(2,3,1)= dc_norm(1,i+1)
2529             uzder(3,3,1)= 0.0d0
2530             uzder(1,1,2)= 0.0d0
2531             uzder(2,1,2)= dc_norm(3,i)
2532             uzder(3,1,2)=-dc_norm(2,i)
2533             uzder(1,2,2)=-dc_norm(3,i)
2534             uzder(2,2,2)= 0.0d0
2535             uzder(3,2,2)= dc_norm(1,i)
2536             uzder(1,3,2)= dc_norm(2,i)
2537             uzder(2,3,2)=-dc_norm(1,i)
2538             uzder(3,3,2)= 0.0d0
2539 ! Compute the Y-axis
2540             facy=fac
2541             do k=1,3
2542               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2543             enddo
2544 ! Compute the derivatives of uy
2545             do j=1,3
2546               do k=1,3
2547                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2548                               -dc_norm(k,i)*dc_norm(j,i+1)
2549                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2550               enddo
2551               uyder(j,j,1)=uyder(j,j,1)-costh
2552               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2553             enddo
2554             do j=1,2
2555               do k=1,3
2556                 do l=1,3
2557                   uygrad(l,k,j,i)=uyder(l,k,j)
2558                   uzgrad(l,k,j,i)=uzder(l,k,j)
2559                 enddo
2560               enddo
2561             enddo
2562             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2563             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2564             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2565             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2566           endif
2567       enddo
2568       do i=1,nres-1
2569         vbld_inv_temp(1)=vbld_inv(i+1)
2570         if (i.lt.nres-1) then
2571           vbld_inv_temp(2)=vbld_inv(i+2)
2572           else
2573           vbld_inv_temp(2)=vbld_inv(i)
2574           endif
2575         do j=1,2
2576           do k=1,3
2577             do l=1,3
2578               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2579               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2580             enddo
2581           enddo
2582         enddo
2583       enddo
2584 #if defined(PARVEC) && defined(MPI)
2585       if (nfgtasks1.gt.1) then
2586         time00=MPI_Wtime()
2587 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2588 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2589 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2590         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2591          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2592          FG_COMM1,IERR)
2593         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2594          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2595          FG_COMM1,IERR)
2596         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2597          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2598          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2599         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2600          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2601          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2602         time_gather=time_gather+MPI_Wtime()-time00
2603       endif
2604 !      if (fg_rank.eq.0) then
2605 !        write (iout,*) "Arrays UY and UZ"
2606 !        do i=1,nres-1
2607 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2608 !     &     (uz(k,i),k=1,3)
2609 !        enddo
2610 !      endif
2611 #endif
2612       return
2613       end subroutine vec_and_deriv
2614 !-----------------------------------------------------------------------------
2615       subroutine check_vecgrad
2616 !      implicit real*8 (a-h,o-z)
2617 !      include 'DIMENSIONS'
2618 !      include 'COMMON.IOUNITS'
2619 !      include 'COMMON.GEO'
2620 !      include 'COMMON.VAR'
2621 !      include 'COMMON.LOCAL'
2622 !      include 'COMMON.CHAIN'
2623 !      include 'COMMON.VECTORS'
2624       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2625       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2626       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2627       real(kind=8),dimension(3) :: erij
2628       real(kind=8) :: delta=1.0d-7
2629 !el local variables
2630       integer :: i,j,k,l
2631
2632       call vec_and_deriv
2633 !d      do i=1,nres
2634 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2635 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2636 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2637 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2638 !d     &     (dc_norm(if90,i),if90=1,3)
2639 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2640 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2641 !d          write(iout,'(a)')
2642 !d      enddo
2643       do i=1,nres
2644         do j=1,2
2645           do k=1,3
2646             do l=1,3
2647               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2648               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2649             enddo
2650           enddo
2651         enddo
2652       enddo
2653       call vec_and_deriv
2654       do i=1,nres
2655         do j=1,3
2656           uyt(j,i)=uy(j,i)
2657           uzt(j,i)=uz(j,i)
2658         enddo
2659       enddo
2660       do i=1,nres
2661 !d        write (iout,*) 'i=',i
2662         do k=1,3
2663           erij(k)=dc_norm(k,i)
2664         enddo
2665         do j=1,3
2666           do k=1,3
2667             dc_norm(k,i)=erij(k)
2668           enddo
2669           dc_norm(j,i)=dc_norm(j,i)+delta
2670 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2671 !          do k=1,3
2672 !            dc_norm(k,i)=dc_norm(k,i)/fac
2673 !          enddo
2674 !          write (iout,*) (dc_norm(k,i),k=1,3)
2675 !          write (iout,*) (erij(k),k=1,3)
2676           call vec_and_deriv
2677           do k=1,3
2678             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2679             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2680             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2681             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2682           enddo
2683 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2684 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2685 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2686         enddo
2687         do k=1,3
2688           dc_norm(k,i)=erij(k)
2689         enddo
2690 !d        do k=1,3
2691 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2692 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2693 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2694 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2695 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2696 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2697 !d          write (iout,'(a)')
2698 !d        enddo
2699       enddo
2700       return
2701       end subroutine check_vecgrad
2702 !-----------------------------------------------------------------------------
2703       subroutine set_matrices
2704 !      implicit real*8 (a-h,o-z)
2705 !      include 'DIMENSIONS'
2706 #ifdef MPI
2707       include "mpif.h"
2708 !      include "COMMON.SETUP"
2709       integer :: IERR
2710       integer :: status(MPI_STATUS_SIZE)
2711 #endif
2712 !      include 'COMMON.IOUNITS'
2713 !      include 'COMMON.GEO'
2714 !      include 'COMMON.VAR'
2715 !      include 'COMMON.LOCAL'
2716 !      include 'COMMON.CHAIN'
2717 !      include 'COMMON.DERIV'
2718 !      include 'COMMON.INTERACT'
2719 !      include 'COMMON.CONTACTS'
2720 !      include 'COMMON.TORSION'
2721 !      include 'COMMON.VECTORS'
2722 !      include 'COMMON.FFIELD'
2723       real(kind=8) :: auxvec(2),auxmat(2,2)
2724       integer :: i,iti1,iti,k,l
2725       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2726        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2727 !       print *,"in set matrices"
2728 !
2729 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2730 ! to calculate the el-loc multibody terms of various order.
2731 !
2732 !AL el      mu=0.0d0
2733
2734 #ifdef PARMAT
2735       do i=ivec_start+2,ivec_end+2
2736 #else
2737       do i=3,nres+1
2738 #endif
2739         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2740           if (itype(i-2,1).eq.0) then
2741           iti = nloctyp
2742           else
2743           iti = itype2loc(itype(i-2,1))
2744           endif
2745         else
2746           iti=nloctyp
2747         endif
2748 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2749         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2750           iti1 = itype2loc(itype(i-1,1))
2751         else
2752           iti1=nloctyp
2753         endif
2754 !        print *,i,itype(i-2,1),iti
2755 #ifdef NEWCORR
2756         cost1=dcos(theta(i-1))
2757         sint1=dsin(theta(i-1))
2758         sint1sq=sint1*sint1
2759         sint1cub=sint1sq*sint1
2760         sint1cost1=2*sint1*cost1
2761 !        print *,"cost1",cost1,theta(i-1)
2762 !c        write (iout,*) "bnew1",i,iti
2763 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2764 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2765 !c        write (iout,*) "bnew2",i,iti
2766 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2767 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2768         k=1
2769 !        print *,bnew1(1,k,iti),"bnew1"
2770         do k=1,2
2771           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2772 !          print *,b1k
2773 !          write(*,*) shape(b1)
2774 !          if(.not.allocated(b1)) print *, "WTF?"
2775           b1(k,i-2)=sint1*b1k
2776 !
2777 !             print *,b1(k,i-2)
2778
2779           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2780                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2781 !             print *,gtb1(k,i-2)
2782
2783           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2784           b2(k,i-2)=sint1*b2k
2785 !             print *,b2(k,i-2)
2786
2787           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2788                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2789 !             print *,gtb2(k,i-2)
2790
2791         enddo
2792 !        print *,b1k,b2k
2793         do k=1,2
2794           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2795           cc(1,k,i-2)=sint1sq*aux
2796           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2797                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2798           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2799           dd(1,k,i-2)=sint1sq*aux
2800           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2801                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2802         enddo
2803 !        print *,"after cc"
2804         cc(2,1,i-2)=cc(1,2,i-2)
2805         cc(2,2,i-2)=-cc(1,1,i-2)
2806         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2807         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2808         dd(2,1,i-2)=dd(1,2,i-2)
2809         dd(2,2,i-2)=-dd(1,1,i-2)
2810         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2811         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2812 !        print *,"after dd"
2813
2814         do k=1,2
2815           do l=1,2
2816             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2817             EE(l,k,i-2)=sint1sq*aux
2818             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2819           enddo
2820         enddo
2821         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2822         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2823         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2824         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2825         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2826         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2827         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2828 !        print *,"after ee"
2829
2830 !c        b1tilde(1,i-2)=b1(1,i-2)
2831 !c        b1tilde(2,i-2)=-b1(2,i-2)
2832 !c        b2tilde(1,i-2)=b2(1,i-2)
2833 !c        b2tilde(2,i-2)=-b2(2,i-2)
2834 #ifdef DEBUG
2835         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2836         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2837         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2838         write (iout,*) 'theta=', theta(i-1)
2839 #endif
2840 #else
2841         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2842           iti = itype2loc(itype(i-2,1))
2843         else
2844           iti=nloctyp
2845         endif
2846 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2847 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2848         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2849           iti1 = itype2loc(itype(i-1,1))
2850         else
2851           iti1=nloctyp
2852         endif
2853 !        print *,i,iti
2854         b1(1,i-2)=b(3,iti)
2855         b1(2,i-2)=b(5,iti)
2856         b2(1,i-2)=b(2,iti)
2857         b2(2,i-2)=b(4,iti)
2858         do k=1,2
2859           do l=1,2
2860            CC(k,l,i-2)=ccold(k,l,iti)
2861            DD(k,l,i-2)=ddold(k,l,iti)
2862            EE(k,l,i-2)=eeold(k,l,iti)
2863           enddo
2864         enddo
2865 #endif
2866         b1tilde(1,i-2)= b1(1,i-2)
2867         b1tilde(2,i-2)=-b1(2,i-2)
2868         b2tilde(1,i-2)= b2(1,i-2)
2869         b2tilde(2,i-2)=-b2(2,i-2)
2870 !c
2871         Ctilde(1,1,i-2)= CC(1,1,i-2)
2872         Ctilde(1,2,i-2)= CC(1,2,i-2)
2873         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2874         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2875 !c
2876         Dtilde(1,1,i-2)= DD(1,1,i-2)
2877         Dtilde(1,2,i-2)= DD(1,2,i-2)
2878         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2879         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2880       enddo
2881 #ifdef PARMAT
2882       do i=ivec_start+2,ivec_end+2
2883 #else
2884       do i=3,nres+1
2885 #endif
2886
2887 !      print *,i,"i"
2888         if (i .lt. nres+1) then
2889           sin1=dsin(phi(i))
2890           cos1=dcos(phi(i))
2891           sintab(i-2)=sin1
2892           costab(i-2)=cos1
2893           obrot(1,i-2)=cos1
2894           obrot(2,i-2)=sin1
2895           sin2=dsin(2*phi(i))
2896           cos2=dcos(2*phi(i))
2897           sintab2(i-2)=sin2
2898           costab2(i-2)=cos2
2899           obrot2(1,i-2)=cos2
2900           obrot2(2,i-2)=sin2
2901           Ug(1,1,i-2)=-cos1
2902           Ug(1,2,i-2)=-sin1
2903           Ug(2,1,i-2)=-sin1
2904           Ug(2,2,i-2)= cos1
2905           Ug2(1,1,i-2)=-cos2
2906           Ug2(1,2,i-2)=-sin2
2907           Ug2(2,1,i-2)=-sin2
2908           Ug2(2,2,i-2)= cos2
2909         else
2910           costab(i-2)=1.0d0
2911           sintab(i-2)=0.0d0
2912           obrot(1,i-2)=1.0d0
2913           obrot(2,i-2)=0.0d0
2914           obrot2(1,i-2)=0.0d0
2915           obrot2(2,i-2)=0.0d0
2916           Ug(1,1,i-2)=1.0d0
2917           Ug(1,2,i-2)=0.0d0
2918           Ug(2,1,i-2)=0.0d0
2919           Ug(2,2,i-2)=1.0d0
2920           Ug2(1,1,i-2)=0.0d0
2921           Ug2(1,2,i-2)=0.0d0
2922           Ug2(2,1,i-2)=0.0d0
2923           Ug2(2,2,i-2)=0.0d0
2924         endif
2925         if (i .gt. 3 .and. i .lt. nres+1) then
2926           obrot_der(1,i-2)=-sin1
2927           obrot_der(2,i-2)= cos1
2928           Ugder(1,1,i-2)= sin1
2929           Ugder(1,2,i-2)=-cos1
2930           Ugder(2,1,i-2)=-cos1
2931           Ugder(2,2,i-2)=-sin1
2932           dwacos2=cos2+cos2
2933           dwasin2=sin2+sin2
2934           obrot2_der(1,i-2)=-dwasin2
2935           obrot2_der(2,i-2)= dwacos2
2936           Ug2der(1,1,i-2)= dwasin2
2937           Ug2der(1,2,i-2)=-dwacos2
2938           Ug2der(2,1,i-2)=-dwacos2
2939           Ug2der(2,2,i-2)=-dwasin2
2940         else
2941           obrot_der(1,i-2)=0.0d0
2942           obrot_der(2,i-2)=0.0d0
2943           Ugder(1,1,i-2)=0.0d0
2944           Ugder(1,2,i-2)=0.0d0
2945           Ugder(2,1,i-2)=0.0d0
2946           Ugder(2,2,i-2)=0.0d0
2947           obrot2_der(1,i-2)=0.0d0
2948           obrot2_der(2,i-2)=0.0d0
2949           Ug2der(1,1,i-2)=0.0d0
2950           Ug2der(1,2,i-2)=0.0d0
2951           Ug2der(2,1,i-2)=0.0d0
2952           Ug2der(2,2,i-2)=0.0d0
2953         endif
2954 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2955         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2956            if (itype(i-2,1).eq.0) then
2957           iti=ntortyp+1
2958            else
2959           iti = itype2loc(itype(i-2,1))
2960            endif
2961         else
2962           iti=nloctyp
2963         endif
2964 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2965         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2966            if (itype(i-1,1).eq.0) then
2967           iti1=nloctyp
2968            else
2969           iti1 = itype2loc(itype(i-1,1))
2970            endif
2971         else
2972           iti1=nloctyp
2973         endif
2974 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2975 !d        write (iout,*) '*******i',i,' iti1',iti
2976 !        write (iout,*) 'b1',b1(:,iti)
2977 !        write (iout,*) 'b2',b2(:,i-2)
2978 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2979 !        if (i .gt. iatel_s+2) then
2980         if (i .gt. nnt+2) then
2981           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2982 #ifdef NEWCORR
2983           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2984 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2985 #endif
2986
2987           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2988           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2989           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2990           then
2991           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2992           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2993           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2994           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2995           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2996           endif
2997         else
2998           do k=1,2
2999             Ub2(k,i-2)=0.0d0
3000             Ctobr(k,i-2)=0.0d0
3001             Dtobr2(k,i-2)=0.0d0
3002             do l=1,2
3003               EUg(l,k,i-2)=0.0d0
3004               CUg(l,k,i-2)=0.0d0
3005               DUg(l,k,i-2)=0.0d0
3006               DtUg2(l,k,i-2)=0.0d0
3007             enddo
3008           enddo
3009         endif
3010         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3011         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3012         do k=1,2
3013           muder(k,i-2)=Ub2der(k,i-2)
3014         enddo
3015 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3016         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3017           if (itype(i-1,1).eq.0) then
3018            iti1=ntortyp+1
3019           elseif (itype(i-1,1).le.ntyp) then
3020             iti1 = itype2loc(itype(i-1,1))
3021           else
3022             iti1=nloctyp
3023           endif
3024         else
3025           iti1=nloctyp
3026         endif
3027         do k=1,2
3028           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3029         enddo
3030         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3031         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3032         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3033 !d        write (iout,*) 'mu1',mu1(:,i-2)
3034 !d        write (iout,*) 'mu2',mu2(:,i-2)
3035         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3036         then
3037         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3038         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3039         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3040         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3041         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3042 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3043         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3044         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3045         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3046         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3047         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3048         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3049         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3050         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3051         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3052         endif
3053       enddo
3054 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3055 ! The order of matrices is from left to right.
3056       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3057       then
3058 !      do i=max0(ivec_start,2),ivec_end
3059       do i=2,nres-1
3060         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3061         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3062         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3063         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3064         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3065         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3066         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3067         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3068       enddo
3069       endif
3070 #if defined(MPI) && defined(PARMAT)
3071 #ifdef DEBUG
3072 !      if (fg_rank.eq.0) then
3073         write (iout,*) "Arrays UG and UGDER before GATHER"
3074         do i=1,nres-1
3075           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3076            ((ug(l,k,i),l=1,2),k=1,2),&
3077            ((ugder(l,k,i),l=1,2),k=1,2)
3078         enddo
3079         write (iout,*) "Arrays UG2 and UG2DER"
3080         do i=1,nres-1
3081           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3082            ((ug2(l,k,i),l=1,2),k=1,2),&
3083            ((ug2der(l,k,i),l=1,2),k=1,2)
3084         enddo
3085         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3086         do i=1,nres-1
3087           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3088            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3089            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3090         enddo
3091         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3092         do i=1,nres-1
3093           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3094            costab(i),sintab(i),costab2(i),sintab2(i)
3095         enddo
3096         write (iout,*) "Array MUDER"
3097         do i=1,nres-1
3098           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3099         enddo
3100 !      endif
3101 #endif
3102       if (nfgtasks.gt.1) then
3103         time00=MPI_Wtime()
3104 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3105 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3106 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3107 #ifdef MATGATHER
3108         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3109          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3110          FG_COMM1,IERR)
3111         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3112          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3113          FG_COMM1,IERR)
3114         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3115          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3116          FG_COMM1,IERR)
3117         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3118          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3119          FG_COMM1,IERR)
3120         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3121          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3122          FG_COMM1,IERR)
3123         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3124          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3125          FG_COMM1,IERR)
3126         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3127          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3128          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3129         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3130          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3131          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3132         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3133          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3134          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3135         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3136          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3137          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3138         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3139         then
3140         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3141          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3142          FG_COMM1,IERR)
3143         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3144          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3145          FG_COMM1,IERR)
3146         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3147          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3148          FG_COMM1,IERR)
3149        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3150          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3151          FG_COMM1,IERR)
3152         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3153          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3154          FG_COMM1,IERR)
3155         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3156          ivec_count(fg_rank1),&
3157          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3158          FG_COMM1,IERR)
3159         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3160          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3161          FG_COMM1,IERR)
3162         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3163          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3164          FG_COMM1,IERR)
3165         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3166          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3167          FG_COMM1,IERR)
3168         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3172          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3173          FG_COMM1,IERR)
3174         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3175          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3176          FG_COMM1,IERR)
3177         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3178          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3179          FG_COMM1,IERR)
3180         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3181          ivec_count(fg_rank1),&
3182          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3183          FG_COMM1,IERR)
3184         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3186          FG_COMM1,IERR)
3187        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3189          FG_COMM1,IERR)
3190         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3192          FG_COMM1,IERR)
3193        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3197          ivec_count(fg_rank1),&
3198          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3199          FG_COMM1,IERR)
3200         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3201          ivec_count(fg_rank1),&
3202          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3203          FG_COMM1,IERR)
3204         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3205          ivec_count(fg_rank1),&
3206          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3207          MPI_MAT2,FG_COMM1,IERR)
3208         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3209          ivec_count(fg_rank1),&
3210          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3211          MPI_MAT2,FG_COMM1,IERR)
3212         endif
3213 #else
3214 ! Passes matrix info through the ring
3215       isend=fg_rank1
3216       irecv=fg_rank1-1
3217       if (irecv.lt.0) irecv=nfgtasks1-1
3218       iprev=irecv
3219       inext=fg_rank1+1
3220       if (inext.ge.nfgtasks1) inext=0
3221       do i=1,nfgtasks1-1
3222 !        write (iout,*) "isend",isend," irecv",irecv
3223 !        call flush(iout)
3224         lensend=lentyp(isend)
3225         lenrecv=lentyp(irecv)
3226 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3227 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3228 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3229 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3230 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3231 !        write (iout,*) "Gather ROTAT1"
3232 !        call flush(iout)
3233 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3234 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3235 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3236 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3237 !        write (iout,*) "Gather ROTAT2"
3238 !        call flush(iout)
3239         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3240          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3241          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3242          iprev,4400+irecv,FG_COMM,status,IERR)
3243 !        write (iout,*) "Gather ROTAT_OLD"
3244 !        call flush(iout)
3245         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3246          MPI_PRECOMP11(lensend),inext,5500+isend,&
3247          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3248          iprev,5500+irecv,FG_COMM,status,IERR)
3249 !        write (iout,*) "Gather PRECOMP11"
3250 !        call flush(iout)
3251         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3252          MPI_PRECOMP12(lensend),inext,6600+isend,&
3253          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3254          iprev,6600+irecv,FG_COMM,status,IERR)
3255 !        write (iout,*) "Gather PRECOMP12"
3256 !        call flush(iout)
3257         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3258         then
3259         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3260          MPI_ROTAT2(lensend),inext,7700+isend,&
3261          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3262          iprev,7700+irecv,FG_COMM,status,IERR)
3263 !        write (iout,*) "Gather PRECOMP21"
3264 !        call flush(iout)
3265         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3266          MPI_PRECOMP22(lensend),inext,8800+isend,&
3267          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3268          iprev,8800+irecv,FG_COMM,status,IERR)
3269 !        write (iout,*) "Gather PRECOMP22"
3270 !        call flush(iout)
3271         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3272          MPI_PRECOMP23(lensend),inext,9900+isend,&
3273          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3274          MPI_PRECOMP23(lenrecv),&
3275          iprev,9900+irecv,FG_COMM,status,IERR)
3276 !        write (iout,*) "Gather PRECOMP23"
3277 !        call flush(iout)
3278         endif
3279         isend=irecv
3280         irecv=irecv-1
3281         if (irecv.lt.0) irecv=nfgtasks1-1
3282       enddo
3283 #endif
3284         time_gather=time_gather+MPI_Wtime()-time00
3285       endif
3286 #ifdef DEBUG
3287 !      if (fg_rank.eq.0) then
3288         write (iout,*) "Arrays UG and UGDER"
3289         do i=1,nres-1
3290           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3291            ((ug(l,k,i),l=1,2),k=1,2),&
3292            ((ugder(l,k,i),l=1,2),k=1,2)
3293         enddo
3294         write (iout,*) "Arrays UG2 and UG2DER"
3295         do i=1,nres-1
3296           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3297            ((ug2(l,k,i),l=1,2),k=1,2),&
3298            ((ug2der(l,k,i),l=1,2),k=1,2)
3299         enddo
3300         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3301         do i=1,nres-1
3302           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3303            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3304            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3305         enddo
3306         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3307         do i=1,nres-1
3308           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3309            costab(i),sintab(i),costab2(i),sintab2(i)
3310         enddo
3311         write (iout,*) "Array MUDER"
3312         do i=1,nres-1
3313           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3314         enddo
3315 !      endif
3316 #endif
3317 #endif
3318 !d      do i=1,nres
3319 !d        iti = itortyp(itype(i,1))
3320 !d        write (iout,*) i
3321 !d        do j=1,2
3322 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3323 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3324 !d        enddo
3325 !d      enddo
3326       return
3327       end subroutine set_matrices
3328 !-----------------------------------------------------------------------------
3329       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3330 !
3331 ! This subroutine calculates the average interaction energy and its gradient
3332 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3333 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3334 ! The potential depends both on the distance of peptide-group centers and on
3335 ! the orientation of the CA-CA virtual bonds.
3336 !
3337       use comm_locel
3338 !      implicit real*8 (a-h,o-z)
3339 #ifdef MPI
3340       include 'mpif.h'
3341 #endif
3342 !      include 'DIMENSIONS'
3343 !      include 'COMMON.CONTROL'
3344 !      include 'COMMON.SETUP'
3345 !      include 'COMMON.IOUNITS'
3346 !      include 'COMMON.GEO'
3347 !      include 'COMMON.VAR'
3348 !      include 'COMMON.LOCAL'
3349 !      include 'COMMON.CHAIN'
3350 !      include 'COMMON.DERIV'
3351 !      include 'COMMON.INTERACT'
3352 !      include 'COMMON.CONTACTS'
3353 !      include 'COMMON.TORSION'
3354 !      include 'COMMON.VECTORS'
3355 !      include 'COMMON.FFIELD'
3356 !      include 'COMMON.TIME1'
3357       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3358       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3359       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3360 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3361       real(kind=8),dimension(4) :: muij
3362 !el      integer :: num_conti,j1,j2
3363 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3364 !el        dz_normi,xmedi,ymedi,zmedi
3365
3366 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3367 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3368 !el          num_conti,j1,j2
3369
3370 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3371 #ifdef MOMENT
3372       real(kind=8) :: scal_el=1.0d0
3373 #else
3374       real(kind=8) :: scal_el=0.5d0
3375 #endif
3376 ! 12/13/98
3377 ! 13-go grudnia roku pamietnego...
3378       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3379                                              0.0d0,1.0d0,0.0d0,&
3380                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3381 !el local variables
3382       integer :: i,k,j
3383       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3384       real(kind=8) :: fac,t_eelecij,fracinbuf
3385
3386
3387 !d      write(iout,*) 'In EELEC'
3388 !        print *,"IN EELEC"
3389 !d      do i=1,nloctyp
3390 !d        write(iout,*) 'Type',i
3391 !d        write(iout,*) 'B1',B1(:,i)
3392 !d        write(iout,*) 'B2',B2(:,i)
3393 !d        write(iout,*) 'CC',CC(:,:,i)
3394 !d        write(iout,*) 'DD',DD(:,:,i)
3395 !d        write(iout,*) 'EE',EE(:,:,i)
3396 !d      enddo
3397 !d      call check_vecgrad
3398 !d      stop
3399 !      ees=0.0d0  !AS
3400 !      evdw1=0.0d0
3401 !      eel_loc=0.0d0
3402 !      eello_turn3=0.0d0
3403 !      eello_turn4=0.0d0
3404       t_eelecij=0.0d0
3405       ees=0.0D0
3406       evdw1=0.0D0
3407       eel_loc=0.0d0
3408       eello_turn3=0.0d0
3409       eello_turn4=0.0d0
3410 !
3411
3412       if (icheckgrad.eq.1) then
3413 !el
3414 !        do i=0,2*nres+2
3415 !          dc_norm(1,i)=0.0d0
3416 !          dc_norm(2,i)=0.0d0
3417 !          dc_norm(3,i)=0.0d0
3418 !        enddo
3419         do i=1,nres-1
3420           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3421           do k=1,3
3422             dc_norm(k,i)=dc(k,i)*fac
3423           enddo
3424 !          write (iout,*) 'i',i,' fac',fac
3425         enddo
3426       endif
3427 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3428 !        wturn6
3429       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3430           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3431           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3432 !        call vec_and_deriv
3433 #ifdef TIMING
3434         time01=MPI_Wtime()
3435 #endif
3436 !        print *, "before set matrices"
3437         call set_matrices
3438 !        print *, "after set matrices"
3439
3440 #ifdef TIMING
3441         time_mat=time_mat+MPI_Wtime()-time01
3442 #endif
3443       endif
3444 !       print *, "after set matrices"
3445 !d      do i=1,nres-1
3446 !d        write (iout,*) 'i=',i
3447 !d        do k=1,3
3448 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3449 !d        enddo
3450 !d        do k=1,3
3451 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3452 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3453 !d        enddo
3454 !d      enddo
3455       t_eelecij=0.0d0
3456       ees=0.0D0
3457       evdw1=0.0D0
3458       eel_loc=0.0d0
3459       eello_turn3=0.0d0
3460       eello_turn4=0.0d0
3461 !el      ind=0
3462       do i=1,nres
3463         num_cont_hb(i)=0
3464       enddo
3465 !d      print '(a)','Enter EELEC'
3466 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3467 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3468 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3469       do i=1,nres
3470         gel_loc_loc(i)=0.0d0
3471         gcorr_loc(i)=0.0d0
3472       enddo
3473 !
3474 !
3475 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3476 !
3477 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3478 !
3479
3480
3481 !        print *,"before iturn3 loop"
3482       do i=iturn3_start,iturn3_end
3483         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3484         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3485         dxi=dc(1,i)
3486         dyi=dc(2,i)
3487         dzi=dc(3,i)
3488         dx_normi=dc_norm(1,i)
3489         dy_normi=dc_norm(2,i)
3490         dz_normi=dc_norm(3,i)
3491         xmedi=c(1,i)+0.5d0*dxi
3492         ymedi=c(2,i)+0.5d0*dyi
3493         zmedi=c(3,i)+0.5d0*dzi
3494           xmedi=dmod(xmedi,boxxsize)
3495           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3496           ymedi=dmod(ymedi,boxysize)
3497           if (ymedi.lt.0) ymedi=ymedi+boxysize
3498           zmedi=dmod(zmedi,boxzsize)
3499           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3500         num_conti=0
3501        if ((zmedi.gt.bordlipbot) &
3502         .and.(zmedi.lt.bordliptop)) then
3503 !C the energy transfer exist
3504         if (zmedi.lt.buflipbot) then
3505 !C what fraction I am in
3506          fracinbuf=1.0d0- &
3507                ((zmedi-bordlipbot)/lipbufthick)
3508 !C lipbufthick is thickenes of lipid buffore
3509          sslipi=sscalelip(fracinbuf)
3510          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3511         elseif (zmedi.gt.bufliptop) then
3512          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3513          sslipi=sscalelip(fracinbuf)
3514          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3515         else
3516          sslipi=1.0d0
3517          ssgradlipi=0.0
3518         endif
3519        else
3520          sslipi=0.0d0
3521          ssgradlipi=0.0
3522        endif
3523 !       print *,i,sslipi,ssgradlipi
3524        call eelecij(i,i+2,ees,evdw1,eel_loc)
3525         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3526         num_cont_hb(i)=num_conti
3527       enddo
3528       do i=iturn4_start,iturn4_end
3529         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3530           .or. itype(i+3,1).eq.ntyp1 &
3531           .or. itype(i+4,1).eq.ntyp1) cycle
3532 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3533         dxi=dc(1,i)
3534         dyi=dc(2,i)
3535         dzi=dc(3,i)
3536         dx_normi=dc_norm(1,i)
3537         dy_normi=dc_norm(2,i)
3538         dz_normi=dc_norm(3,i)
3539         xmedi=c(1,i)+0.5d0*dxi
3540         ymedi=c(2,i)+0.5d0*dyi
3541         zmedi=c(3,i)+0.5d0*dzi
3542           xmedi=dmod(xmedi,boxxsize)
3543           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3544           ymedi=dmod(ymedi,boxysize)
3545           if (ymedi.lt.0) ymedi=ymedi+boxysize
3546           zmedi=dmod(zmedi,boxzsize)
3547           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3548        if ((zmedi.gt.bordlipbot)  &
3549        .and.(zmedi.lt.bordliptop)) then
3550 !C the energy transfer exist
3551         if (zmedi.lt.buflipbot) then
3552 !C what fraction I am in
3553          fracinbuf=1.0d0- &
3554              ((zmedi-bordlipbot)/lipbufthick)
3555 !C lipbufthick is thickenes of lipid buffore
3556          sslipi=sscalelip(fracinbuf)
3557          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3558         elseif (zmedi.gt.bufliptop) then
3559          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3560          sslipi=sscalelip(fracinbuf)
3561          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3562         else
3563          sslipi=1.0d0
3564          ssgradlipi=0.0
3565         endif
3566        else
3567          sslipi=0.0d0
3568          ssgradlipi=0.0
3569        endif
3570
3571         num_conti=num_cont_hb(i)
3572         call eelecij(i,i+3,ees,evdw1,eel_loc)
3573         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3574          call eturn4(i,eello_turn4)
3575 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3576         num_cont_hb(i)=num_conti
3577       enddo   ! i
3578 !
3579 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3580 !
3581 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3582       do i=iatel_s,iatel_e
3583         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3584         dxi=dc(1,i)
3585         dyi=dc(2,i)
3586         dzi=dc(3,i)
3587         dx_normi=dc_norm(1,i)
3588         dy_normi=dc_norm(2,i)
3589         dz_normi=dc_norm(3,i)
3590         xmedi=c(1,i)+0.5d0*dxi
3591         ymedi=c(2,i)+0.5d0*dyi
3592         zmedi=c(3,i)+0.5d0*dzi
3593           xmedi=dmod(xmedi,boxxsize)
3594           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3595           ymedi=dmod(ymedi,boxysize)
3596           if (ymedi.lt.0) ymedi=ymedi+boxysize
3597           zmedi=dmod(zmedi,boxzsize)
3598           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3599        if ((zmedi.gt.bordlipbot)  &
3600         .and.(zmedi.lt.bordliptop)) then
3601 !C the energy transfer exist
3602         if (zmedi.lt.buflipbot) then
3603 !C what fraction I am in
3604          fracinbuf=1.0d0- &
3605              ((zmedi-bordlipbot)/lipbufthick)
3606 !C lipbufthick is thickenes of lipid buffore
3607          sslipi=sscalelip(fracinbuf)
3608          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3609         elseif (zmedi.gt.bufliptop) then
3610          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3611          sslipi=sscalelip(fracinbuf)
3612          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3613         else
3614          sslipi=1.0d0
3615          ssgradlipi=0.0
3616         endif
3617        else
3618          sslipi=0.0d0
3619          ssgradlipi=0.0
3620        endif
3621
3622 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3623         num_conti=num_cont_hb(i)
3624         do j=ielstart(i),ielend(i)
3625 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3626           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3627           call eelecij(i,j,ees,evdw1,eel_loc)
3628         enddo ! j
3629         num_cont_hb(i)=num_conti
3630       enddo   ! i
3631 !      write (iout,*) "Number of loop steps in EELEC:",ind
3632 !d      do i=1,nres
3633 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3634 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3635 !d      enddo
3636 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3637 !cc      eel_loc=eel_loc+eello_turn3
3638 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3639       return
3640       end subroutine eelec
3641 !-----------------------------------------------------------------------------
3642       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3643
3644       use comm_locel
3645 !      implicit real*8 (a-h,o-z)
3646 !      include 'DIMENSIONS'
3647 #ifdef MPI
3648       include "mpif.h"
3649 #endif
3650 !      include 'COMMON.CONTROL'
3651 !      include 'COMMON.IOUNITS'
3652 !      include 'COMMON.GEO'
3653 !      include 'COMMON.VAR'
3654 !      include 'COMMON.LOCAL'
3655 !      include 'COMMON.CHAIN'
3656 !      include 'COMMON.DERIV'
3657 !      include 'COMMON.INTERACT'
3658 !      include 'COMMON.CONTACTS'
3659 !      include 'COMMON.TORSION'
3660 !      include 'COMMON.VECTORS'
3661 !      include 'COMMON.FFIELD'
3662 !      include 'COMMON.TIME1'
3663       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3664       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3665       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3666 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3667       real(kind=8),dimension(4) :: muij
3668       real(kind=8) :: geel_loc_ij,geel_loc_ji
3669       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3670                     dist_temp, dist_init,rlocshield,fracinbuf
3671       integer xshift,yshift,zshift,ilist,iresshield
3672 !el      integer :: num_conti,j1,j2
3673 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3674 !el        dz_normi,xmedi,ymedi,zmedi
3675
3676 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3677 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3678 !el          num_conti,j1,j2
3679
3680 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3681 #ifdef MOMENT
3682       real(kind=8) :: scal_el=1.0d0
3683 #else
3684       real(kind=8) :: scal_el=0.5d0
3685 #endif
3686 ! 12/13/98
3687 ! 13-go grudnia roku pamietnego...
3688       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3689                                              0.0d0,1.0d0,0.0d0,&
3690                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3691 !      integer :: maxconts=nres/4
3692 !el local variables
3693       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3694       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3695       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3696       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3697                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3698                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3699                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3700                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3701                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3702                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3703                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3704 !      maxconts=nres/4
3705 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3706 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3707
3708 !          time00=MPI_Wtime()
3709 !d      write (iout,*) "eelecij",i,j
3710 !          ind=ind+1
3711           iteli=itel(i)
3712           itelj=itel(j)
3713           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3714           aaa=app(iteli,itelj)
3715           bbb=bpp(iteli,itelj)
3716           ael6i=ael6(iteli,itelj)
3717           ael3i=ael3(iteli,itelj)
3718           dxj=dc(1,j)
3719           dyj=dc(2,j)
3720           dzj=dc(3,j)
3721           dx_normj=dc_norm(1,j)
3722           dy_normj=dc_norm(2,j)
3723           dz_normj=dc_norm(3,j)
3724 !          xj=c(1,j)+0.5D0*dxj-xmedi
3725 !          yj=c(2,j)+0.5D0*dyj-ymedi
3726 !          zj=c(3,j)+0.5D0*dzj-zmedi
3727           xj=c(1,j)+0.5D0*dxj
3728           yj=c(2,j)+0.5D0*dyj
3729           zj=c(3,j)+0.5D0*dzj
3730           xj=mod(xj,boxxsize)
3731           if (xj.lt.0) xj=xj+boxxsize
3732           yj=mod(yj,boxysize)
3733           if (yj.lt.0) yj=yj+boxysize
3734           zj=mod(zj,boxzsize)
3735           if (zj.lt.0) zj=zj+boxzsize
3736        if ((zj.gt.bordlipbot)  &
3737        .and.(zj.lt.bordliptop)) then
3738 !C the energy transfer exist
3739         if (zj.lt.buflipbot) then
3740 !C what fraction I am in
3741          fracinbuf=1.0d0-     &
3742              ((zj-bordlipbot)/lipbufthick)
3743 !C lipbufthick is thickenes of lipid buffore
3744          sslipj=sscalelip(fracinbuf)
3745          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3746         elseif (zj.gt.bufliptop) then
3747          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3748          sslipj=sscalelip(fracinbuf)
3749          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3750         else
3751          sslipj=1.0d0
3752          ssgradlipj=0.0
3753         endif
3754        else
3755          sslipj=0.0d0
3756          ssgradlipj=0.0
3757        endif
3758
3759       isubchap=0
3760       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3761       xj_safe=xj
3762       yj_safe=yj
3763       zj_safe=zj
3764       do xshift=-1,1
3765       do yshift=-1,1
3766       do zshift=-1,1
3767           xj=xj_safe+xshift*boxxsize
3768           yj=yj_safe+yshift*boxysize
3769           zj=zj_safe+zshift*boxzsize
3770           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3771           if(dist_temp.lt.dist_init) then
3772             dist_init=dist_temp
3773             xj_temp=xj
3774             yj_temp=yj
3775             zj_temp=zj
3776             isubchap=1
3777           endif
3778        enddo
3779        enddo
3780        enddo
3781        if (isubchap.eq.1) then
3782 !C          print *,i,j
3783           xj=xj_temp-xmedi
3784           yj=yj_temp-ymedi
3785           zj=zj_temp-zmedi
3786        else
3787           xj=xj_safe-xmedi
3788           yj=yj_safe-ymedi
3789           zj=zj_safe-zmedi
3790        endif
3791
3792           rij=xj*xj+yj*yj+zj*zj
3793           rrmij=1.0D0/rij
3794           rij=dsqrt(rij)
3795 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3796             sss_ele_cut=sscale_ele(rij)
3797             sss_ele_grad=sscagrad_ele(rij)
3798 !             sss_ele_cut=1.0d0
3799 !             sss_ele_grad=0.0d0
3800 !            print *,sss_ele_cut,sss_ele_grad,&
3801 !            (rij),r_cut_ele,rlamb_ele
3802 !            if (sss_ele_cut.le.0.0) go to 128
3803
3804           rmij=1.0D0/rij
3805           r3ij=rrmij*rmij
3806           r6ij=r3ij*r3ij
3807           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3808           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3809           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3810           fac=cosa-3.0D0*cosb*cosg
3811           ev1=aaa*r6ij*r6ij
3812 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3813           if (j.eq.i+2) ev1=scal_el*ev1
3814           ev2=bbb*r6ij
3815           fac3=ael6i*r6ij
3816           fac4=ael3i*r3ij
3817           evdwij=ev1+ev2
3818           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3819           el2=fac4*fac
3820 !          eesij=el1+el2
3821           if (shield_mode.gt.0) then
3822 !C          fac_shield(i)=0.4
3823 !C          fac_shield(j)=0.6
3824           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3825           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3826           eesij=(el1+el2)
3827           ees=ees+eesij*sss_ele_cut
3828 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3829 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3830           else
3831           fac_shield(i)=1.0
3832           fac_shield(j)=1.0
3833           eesij=(el1+el2)
3834           ees=ees+eesij   &
3835             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3836 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3837           endif
3838
3839 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3840           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3841 !          ees=ees+eesij*sss_ele_cut
3842           evdw1=evdw1+evdwij*sss_ele_cut  &
3843            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3844 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3845 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3846 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3847 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3848
3849           if (energy_dec) then
3850 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3851 !                  'evdw1',i,j,evdwij,&
3852 !                  iteli,itelj,aaa,evdw1
3853               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3854               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3855           endif
3856 !
3857 ! Calculate contributions to the Cartesian gradient.
3858 !
3859 #ifdef SPLITELE
3860           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3861               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3862           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3863              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3864           fac1=fac
3865           erij(1)=xj*rmij
3866           erij(2)=yj*rmij
3867           erij(3)=zj*rmij
3868 !
3869 ! Radial derivatives. First process both termini of the fragment (i,j)
3870 !
3871           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3872           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3873           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3874            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3875           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3876             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3877
3878           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3879           (shield_mode.gt.0)) then
3880 !C          print *,i,j
3881           do ilist=1,ishield_list(i)
3882            iresshield=shield_list(ilist,i)
3883            do k=1,3
3884            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3885            *2.0*sss_ele_cut
3886            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3887                    rlocshield &
3888             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3889             *sss_ele_cut
3890             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3891            enddo
3892           enddo
3893           do ilist=1,ishield_list(j)
3894            iresshield=shield_list(ilist,j)
3895            do k=1,3
3896            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3897           *2.0*sss_ele_cut
3898            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3899                    rlocshield &
3900            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3901            *sss_ele_cut
3902            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3903            enddo
3904           enddo
3905           do k=1,3
3906             gshieldc(k,i)=gshieldc(k,i)+ &
3907                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3908            *sss_ele_cut
3909
3910             gshieldc(k,j)=gshieldc(k,j)+ &
3911                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3912            *sss_ele_cut
3913
3914             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3915                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3916            *sss_ele_cut
3917
3918             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3919                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3920            *sss_ele_cut
3921
3922            enddo
3923            endif
3924
3925
3926 !          do k=1,3
3927 !            ghalf=0.5D0*ggg(k)
3928 !            gelc(k,i)=gelc(k,i)+ghalf
3929 !            gelc(k,j)=gelc(k,j)+ghalf
3930 !          enddo
3931 ! 9/28/08 AL Gradient compotents will be summed only at the end
3932           do k=1,3
3933             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3934             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3935           enddo
3936             gelc_long(3,j)=gelc_long(3,j)+  &
3937           ssgradlipj*eesij/2.0d0*lipscale**2&
3938            *sss_ele_cut
3939
3940             gelc_long(3,i)=gelc_long(3,i)+  &
3941           ssgradlipi*eesij/2.0d0*lipscale**2&
3942            *sss_ele_cut
3943
3944
3945 !
3946 ! Loop over residues i+1 thru j-1.
3947 !
3948 !grad          do k=i+1,j-1
3949 !grad            do l=1,3
3950 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3951 !grad            enddo
3952 !grad          enddo
3953           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3954            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3955           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3956            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3957           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3958            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3959
3960 !          do k=1,3
3961 !            ghalf=0.5D0*ggg(k)
3962 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3963 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3964 !          enddo
3965 ! 9/28/08 AL Gradient compotents will be summed only at the end
3966           do k=1,3
3967             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3968             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3969           enddo
3970
3971 !C Lipidic part for scaling weight
3972            gvdwpp(3,j)=gvdwpp(3,j)+ &
3973           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3974            gvdwpp(3,i)=gvdwpp(3,i)+ &
3975           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3976 !! Loop over residues i+1 thru j-1.
3977 !
3978 !grad          do k=i+1,j-1
3979 !grad            do l=1,3
3980 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3981 !grad            enddo
3982 !grad          enddo
3983 #else
3984           facvdw=(ev1+evdwij)*sss_ele_cut &
3985            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3986
3987           facel=(el1+eesij)*sss_ele_cut
3988           fac1=fac
3989           fac=-3*rrmij*(facvdw+facvdw+facel)
3990           erij(1)=xj*rmij
3991           erij(2)=yj*rmij
3992           erij(3)=zj*rmij
3993 !
3994 ! Radial derivatives. First process both termini of the fragment (i,j)
3995 !
3996           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3997           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3998           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3999 !          do k=1,3
4000 !            ghalf=0.5D0*ggg(k)
4001 !            gelc(k,i)=gelc(k,i)+ghalf
4002 !            gelc(k,j)=gelc(k,j)+ghalf
4003 !          enddo
4004 ! 9/28/08 AL Gradient compotents will be summed only at the end
4005           do k=1,3
4006             gelc_long(k,j)=gelc(k,j)+ggg(k)
4007             gelc_long(k,i)=gelc(k,i)-ggg(k)
4008           enddo
4009 !
4010 ! Loop over residues i+1 thru j-1.
4011 !
4012 !grad          do k=i+1,j-1
4013 !grad            do l=1,3
4014 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4015 !grad            enddo
4016 !grad          enddo
4017 ! 9/28/08 AL Gradient compotents will be summed only at the end
4018           ggg(1)=facvdw*xj &
4019            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4020           ggg(2)=facvdw*yj &
4021            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4022           ggg(3)=facvdw*zj &
4023            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4024
4025           do k=1,3
4026             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4027             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4028           enddo
4029            gvdwpp(3,j)=gvdwpp(3,j)+ &
4030           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4031            gvdwpp(3,i)=gvdwpp(3,i)+ &
4032           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4033
4034 #endif
4035 !
4036 ! Angular part
4037 !
4038           ecosa=2.0D0*fac3*fac1+fac4
4039           fac4=-3.0D0*fac4
4040           fac3=-6.0D0*fac3
4041           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4042           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4043           do k=1,3
4044             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4045             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4046           enddo
4047 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4048 !d   &          (dcosg(k),k=1,3)
4049           do k=1,3
4050             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4051              *fac_shield(i)**2*fac_shield(j)**2 &
4052              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4053
4054           enddo
4055 !          do k=1,3
4056 !            ghalf=0.5D0*ggg(k)
4057 !            gelc(k,i)=gelc(k,i)+ghalf
4058 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4059 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4060 !            gelc(k,j)=gelc(k,j)+ghalf
4061 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4062 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4063 !          enddo
4064 !grad          do k=i+1,j-1
4065 !grad            do l=1,3
4066 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4067 !grad            enddo
4068 !grad          enddo
4069           do k=1,3
4070             gelc(k,i)=gelc(k,i) &
4071                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4072                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4073                      *sss_ele_cut &
4074                      *fac_shield(i)**2*fac_shield(j)**2 &
4075                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4076
4077             gelc(k,j)=gelc(k,j) &
4078                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4079                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4080                      *sss_ele_cut  &
4081                      *fac_shield(i)**2*fac_shield(j)**2  &
4082                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4083
4084             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4085             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4086           enddo
4087
4088           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4089               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4090               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4091 !
4092 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4093 !   energy of a peptide unit is assumed in the form of a second-order
4094 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4095 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4096 !   are computed for EVERY pair of non-contiguous peptide groups.
4097 !
4098           if (j.lt.nres-1) then
4099             j1=j+1
4100             j2=j-1
4101           else
4102             j1=j-1
4103             j2=j-2
4104           endif
4105           kkk=0
4106           do k=1,2
4107             do l=1,2
4108               kkk=kkk+1
4109               muij(kkk)=mu(k,i)*mu(l,j)
4110 #ifdef NEWCORR
4111              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4112 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4113              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4114              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4115 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4116              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4117 #endif
4118
4119             enddo
4120           enddo
4121 !d         write (iout,*) 'EELEC: i',i,' j',j
4122 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4123 !d          write(iout,*) 'muij',muij
4124           ury=scalar(uy(1,i),erij)
4125           urz=scalar(uz(1,i),erij)
4126           vry=scalar(uy(1,j),erij)
4127           vrz=scalar(uz(1,j),erij)
4128           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4129           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4130           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4131           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4132           fac=dsqrt(-ael6i)*r3ij
4133           a22=a22*fac
4134           a23=a23*fac
4135           a32=a32*fac
4136           a33=a33*fac
4137 !d          write (iout,'(4i5,4f10.5)')
4138 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4139 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4140 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4141 !d     &      uy(:,j),uz(:,j)
4142 !d          write (iout,'(4f10.5)')
4143 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4144 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4145 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4146 !d           write (iout,'(9f10.5/)')
4147 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4148 ! Derivatives of the elements of A in virtual-bond vectors
4149           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4150           do k=1,3
4151             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4152             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4153             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4154             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4155             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4156             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4157             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4158             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4159             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4160             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4161             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4162             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4163           enddo
4164 ! Compute radial contributions to the gradient
4165           facr=-3.0d0*rrmij
4166           a22der=a22*facr
4167           a23der=a23*facr
4168           a32der=a32*facr
4169           a33der=a33*facr
4170           agg(1,1)=a22der*xj
4171           agg(2,1)=a22der*yj
4172           agg(3,1)=a22der*zj
4173           agg(1,2)=a23der*xj
4174           agg(2,2)=a23der*yj
4175           agg(3,2)=a23der*zj
4176           agg(1,3)=a32der*xj
4177           agg(2,3)=a32der*yj
4178           agg(3,3)=a32der*zj
4179           agg(1,4)=a33der*xj
4180           agg(2,4)=a33der*yj
4181           agg(3,4)=a33der*zj
4182 ! Add the contributions coming from er
4183           fac3=-3.0d0*fac
4184           do k=1,3
4185             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4186             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4187             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4188             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4189           enddo
4190           do k=1,3
4191 ! Derivatives in DC(i)
4192 !grad            ghalf1=0.5d0*agg(k,1)
4193 !grad            ghalf2=0.5d0*agg(k,2)
4194 !grad            ghalf3=0.5d0*agg(k,3)
4195 !grad            ghalf4=0.5d0*agg(k,4)
4196             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4197             -3.0d0*uryg(k,2)*vry)!+ghalf1
4198             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4199             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4200             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4201             -3.0d0*urzg(k,2)*vry)!+ghalf3
4202             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4203             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4204 ! Derivatives in DC(i+1)
4205             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4206             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4207             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4208             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4209             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4210             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4211             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4212             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4213 ! Derivatives in DC(j)
4214             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4215             -3.0d0*vryg(k,2)*ury)!+ghalf1
4216             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4217             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4218             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4219             -3.0d0*vryg(k,2)*urz)!+ghalf3
4220             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4221             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4222 ! Derivatives in DC(j+1) or DC(nres-1)
4223             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4224             -3.0d0*vryg(k,3)*ury)
4225             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4226             -3.0d0*vrzg(k,3)*ury)
4227             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4228             -3.0d0*vryg(k,3)*urz)
4229             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4230             -3.0d0*vrzg(k,3)*urz)
4231 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4232 !grad              do l=1,4
4233 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4234 !grad              enddo
4235 !grad            endif
4236           enddo
4237           acipa(1,1)=a22
4238           acipa(1,2)=a23
4239           acipa(2,1)=a32
4240           acipa(2,2)=a33
4241           a22=-a22
4242           a23=-a23
4243           do l=1,2
4244             do k=1,3
4245               agg(k,l)=-agg(k,l)
4246               aggi(k,l)=-aggi(k,l)
4247               aggi1(k,l)=-aggi1(k,l)
4248               aggj(k,l)=-aggj(k,l)
4249               aggj1(k,l)=-aggj1(k,l)
4250             enddo
4251           enddo
4252           if (j.lt.nres-1) then
4253             a22=-a22
4254             a32=-a32
4255             do l=1,3,2
4256               do k=1,3
4257                 agg(k,l)=-agg(k,l)
4258                 aggi(k,l)=-aggi(k,l)
4259                 aggi1(k,l)=-aggi1(k,l)
4260                 aggj(k,l)=-aggj(k,l)
4261                 aggj1(k,l)=-aggj1(k,l)
4262               enddo
4263             enddo
4264           else
4265             a22=-a22
4266             a23=-a23
4267             a32=-a32
4268             a33=-a33
4269             do l=1,4
4270               do k=1,3
4271                 agg(k,l)=-agg(k,l)
4272                 aggi(k,l)=-aggi(k,l)
4273                 aggi1(k,l)=-aggi1(k,l)
4274                 aggj(k,l)=-aggj(k,l)
4275                 aggj1(k,l)=-aggj1(k,l)
4276               enddo
4277             enddo
4278           endif
4279           ENDIF ! WCORR
4280           IF (wel_loc.gt.0.0d0) THEN
4281 ! Contribution to the local-electrostatic energy coming from the i-j pair
4282           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4283            +a33*muij(4)
4284           if (shield_mode.eq.0) then
4285            fac_shield(i)=1.0
4286            fac_shield(j)=1.0
4287           endif
4288           eel_loc_ij=eel_loc_ij &
4289          *fac_shield(i)*fac_shield(j) &
4290          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4291 !C Now derivative over eel_loc
4292           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4293          (shield_mode.gt.0)) then
4294 !C          print *,i,j
4295
4296           do ilist=1,ishield_list(i)
4297            iresshield=shield_list(ilist,i)
4298            do k=1,3
4299            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4300                                                 /fac_shield(i)&
4301            *sss_ele_cut
4302            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4303                    rlocshield  &
4304           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4305           *sss_ele_cut
4306
4307             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4308            +rlocshield
4309            enddo
4310           enddo
4311           do ilist=1,ishield_list(j)
4312            iresshield=shield_list(ilist,j)
4313            do k=1,3
4314            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4315                                             /fac_shield(j)   &
4316             *sss_ele_cut
4317            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4318                    rlocshield  &
4319       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4320        *sss_ele_cut
4321
4322            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4323                   +rlocshield
4324
4325            enddo
4326           enddo
4327
4328           do k=1,3
4329             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4330                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4331                     *sss_ele_cut
4332             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4333                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4334                     *sss_ele_cut
4335             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4336                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4337                     *sss_ele_cut
4338             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4339                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4340                     *sss_ele_cut
4341
4342            enddo
4343            endif
4344
4345 #ifdef NEWCORR
4346          geel_loc_ij=(a22*gmuij1(1)&
4347           +a23*gmuij1(2)&
4348           +a32*gmuij1(3)&
4349           +a33*gmuij1(4))&
4350          *fac_shield(i)*fac_shield(j)&
4351                     *sss_ele_cut
4352
4353 !c         write(iout,*) "derivative over thatai"
4354 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4355 !c     &   a33*gmuij1(4)
4356          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4357            geel_loc_ij*wel_loc
4358 !c         write(iout,*) "derivative over thatai-1"
4359 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4360 !c     &   a33*gmuij2(4)
4361          geel_loc_ij=&
4362           a22*gmuij2(1)&
4363           +a23*gmuij2(2)&
4364           +a32*gmuij2(3)&
4365           +a33*gmuij2(4)
4366          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4367            geel_loc_ij*wel_loc&
4368          *fac_shield(i)*fac_shield(j)&
4369                     *sss_ele_cut
4370
4371
4372 !c  Derivative over j residue
4373          geel_loc_ji=a22*gmuji1(1)&
4374           +a23*gmuji1(2)&
4375           +a32*gmuji1(3)&
4376           +a33*gmuji1(4)
4377 !c         write(iout,*) "derivative over thataj"
4378 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4379 !c     &   a33*gmuji1(4)
4380
4381         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4382            geel_loc_ji*wel_loc&
4383          *fac_shield(i)*fac_shield(j)&
4384                     *sss_ele_cut
4385
4386
4387          geel_loc_ji=&
4388           +a22*gmuji2(1)&
4389           +a23*gmuji2(2)&
4390           +a32*gmuji2(3)&
4391           +a33*gmuji2(4)
4392 !c         write(iout,*) "derivative over thataj-1"
4393 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4394 !c     &   a33*gmuji2(4)
4395          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4396            geel_loc_ji*wel_loc&
4397          *fac_shield(i)*fac_shield(j)&
4398                     *sss_ele_cut
4399 #endif
4400
4401 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4402 !           eel_loc_ij=0.0
4403 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4404 !                  'eelloc',i,j,eel_loc_ij
4405           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4406                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4407 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4408
4409 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4410 !          if (energy_dec) write (iout,*) "muij",muij
4411 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4412
4413           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4414 ! Partial derivatives in virtual-bond dihedral angles gamma
4415           if (i.gt.1) &
4416           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4417                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4418                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4419                  *sss_ele_cut  &
4420           *fac_shield(i)*fac_shield(j) &
4421           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4422
4423           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4424                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4425                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4426                  *sss_ele_cut &
4427           *fac_shield(i)*fac_shield(j) &
4428           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4429 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4430 !          do l=1,3
4431 !            ggg(1)=(agg(1,1)*muij(1)+ &
4432 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4433 !            *sss_ele_cut &
4434 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4435 !            ggg(2)=(agg(2,1)*muij(1)+ &
4436 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4437 !            *sss_ele_cut &
4438 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4439 !            ggg(3)=(agg(3,1)*muij(1)+ &
4440 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4441 !            *sss_ele_cut &
4442 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4443            xtemp(1)=xj
4444            xtemp(2)=yj
4445            xtemp(3)=zj
4446
4447            do l=1,3
4448             ggg(l)=(agg(l,1)*muij(1)+ &
4449                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4450             *sss_ele_cut &
4451           *fac_shield(i)*fac_shield(j) &
4452           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4453              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4454
4455
4456             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4457             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4458 !grad            ghalf=0.5d0*ggg(l)
4459 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4460 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4461           enddo
4462             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4463           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4464           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4465
4466             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4467           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4468           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4469
4470 !grad          do k=i+1,j2
4471 !grad            do l=1,3
4472 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4473 !grad            enddo
4474 !grad          enddo
4475 ! Remaining derivatives of eello
4476           do l=1,3
4477             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4478                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4479             *sss_ele_cut &
4480           *fac_shield(i)*fac_shield(j) &
4481           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4482
4483 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4484             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4485                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4486             +aggi1(l,4)*muij(4))&
4487             *sss_ele_cut &
4488           *fac_shield(i)*fac_shield(j) &
4489           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4490
4491 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4492             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4493                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4494             *sss_ele_cut &
4495           *fac_shield(i)*fac_shield(j) &
4496           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4497
4498 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4499             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4500                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4501             +aggj1(l,4)*muij(4))&
4502             *sss_ele_cut &
4503           *fac_shield(i)*fac_shield(j) &
4504          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4505
4506 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4507           enddo
4508           ENDIF
4509 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4510 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4511           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4512              .and. num_conti.le.maxconts) then
4513 !            write (iout,*) i,j," entered corr"
4514 !
4515 ! Calculate the contact function. The ith column of the array JCONT will
4516 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4517 ! greater than I). The arrays FACONT and GACONT will contain the values of
4518 ! the contact function and its derivative.
4519 !           r0ij=1.02D0*rpp(iteli,itelj)
4520 !           r0ij=1.11D0*rpp(iteli,itelj)
4521             r0ij=2.20D0*rpp(iteli,itelj)
4522 !           r0ij=1.55D0*rpp(iteli,itelj)
4523             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4524 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4525             if (fcont.gt.0.0D0) then
4526               num_conti=num_conti+1
4527               if (num_conti.gt.maxconts) then
4528 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4529 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4530                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4531                                ' will skip next contacts for this conf.', num_conti
4532               else
4533                 jcont_hb(num_conti,i)=j
4534 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4535 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4536                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4537                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4538 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4539 !  terms.
4540                 d_cont(num_conti,i)=rij
4541 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4542 !     --- Electrostatic-interaction matrix ---
4543                 a_chuj(1,1,num_conti,i)=a22
4544                 a_chuj(1,2,num_conti,i)=a23
4545                 a_chuj(2,1,num_conti,i)=a32
4546                 a_chuj(2,2,num_conti,i)=a33
4547 !     --- Gradient of rij
4548                 do kkk=1,3
4549                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4550                 enddo
4551                 kkll=0
4552                 do k=1,2
4553                   do l=1,2
4554                     kkll=kkll+1
4555                     do m=1,3
4556                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4557                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4558                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4559                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4560                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4561                     enddo
4562                   enddo
4563                 enddo
4564                 ENDIF
4565                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4566 ! Calculate contact energies
4567                 cosa4=4.0D0*cosa
4568                 wij=cosa-3.0D0*cosb*cosg
4569                 cosbg1=cosb+cosg
4570                 cosbg2=cosb-cosg
4571 !               fac3=dsqrt(-ael6i)/r0ij**3
4572                 fac3=dsqrt(-ael6i)*r3ij
4573 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4574                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4575                 if (ees0tmp.gt.0) then
4576                   ees0pij=dsqrt(ees0tmp)
4577                 else
4578                   ees0pij=0
4579                 endif
4580                 if (shield_mode.eq.0) then
4581                 fac_shield(i)=1.0d0
4582                 fac_shield(j)=1.0d0
4583                 else
4584                 ees0plist(num_conti,i)=j
4585                 endif
4586 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4587                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4588                 if (ees0tmp.gt.0) then
4589                   ees0mij=dsqrt(ees0tmp)
4590                 else
4591                   ees0mij=0
4592                 endif
4593 !               ees0mij=0.0D0
4594                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4595                      *sss_ele_cut &
4596                      *fac_shield(i)*fac_shield(j)
4597
4598                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4599                      *sss_ele_cut &
4600                      *fac_shield(i)*fac_shield(j)
4601
4602 ! Diagnostics. Comment out or remove after debugging!
4603 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4604 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4605 !               ees0m(num_conti,i)=0.0D0
4606 ! End diagnostics.
4607 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4608 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4609 ! Angular derivatives of the contact function
4610                 ees0pij1=fac3/ees0pij
4611                 ees0mij1=fac3/ees0mij
4612                 fac3p=-3.0D0*fac3*rrmij
4613                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4614                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4615 !               ees0mij1=0.0D0
4616                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4617                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4618                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4619                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4620                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4621                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4622                 ecosap=ecosa1+ecosa2
4623                 ecosbp=ecosb1+ecosb2
4624                 ecosgp=ecosg1+ecosg2
4625                 ecosam=ecosa1-ecosa2
4626                 ecosbm=ecosb1-ecosb2
4627                 ecosgm=ecosg1-ecosg2
4628 ! Diagnostics
4629 !               ecosap=ecosa1
4630 !               ecosbp=ecosb1
4631 !               ecosgp=ecosg1
4632 !               ecosam=0.0D0
4633 !               ecosbm=0.0D0
4634 !               ecosgm=0.0D0
4635 ! End diagnostics
4636                 facont_hb(num_conti,i)=fcont
4637                 fprimcont=fprimcont/rij
4638 !d              facont_hb(num_conti,i)=1.0D0
4639 ! Following line is for diagnostics.
4640 !d              fprimcont=0.0D0
4641                 do k=1,3
4642                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4643                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4644                 enddo
4645                 do k=1,3
4646                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4647                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4648                 enddo
4649                 gggp(1)=gggp(1)+ees0pijp*xj &
4650                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4651                 gggp(2)=gggp(2)+ees0pijp*yj &
4652                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4653                 gggp(3)=gggp(3)+ees0pijp*zj &
4654                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4655
4656                 gggm(1)=gggm(1)+ees0mijp*xj &
4657                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4658
4659                 gggm(2)=gggm(2)+ees0mijp*yj &
4660                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4661
4662                 gggm(3)=gggm(3)+ees0mijp*zj &
4663                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4664
4665 ! Derivatives due to the contact function
4666                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4667                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4668                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4669                 do k=1,3
4670 !
4671 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4672 !          following the change of gradient-summation algorithm.
4673 !
4674 !grad                  ghalfp=0.5D0*gggp(k)
4675 !grad                  ghalfm=0.5D0*gggm(k)
4676                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4677                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4678                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4679                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4680
4681                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4682                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4683                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4684                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4685
4686                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4687                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4688
4689                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4690                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4691                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4692                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4693
4694                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4695                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4696                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4697                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4698
4699                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4700                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4701
4702                 enddo
4703 ! Diagnostics. Comment out or remove after debugging!
4704 !diag           do k=1,3
4705 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4706 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4707 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4708 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4709 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4710 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4711 !diag           enddo
4712               ENDIF ! wcorr
4713               endif  ! num_conti.le.maxconts
4714             endif  ! fcont.gt.0
4715           endif    ! j.gt.i+1
4716           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4717             do k=1,4
4718               do l=1,3
4719                 ghalf=0.5d0*agg(l,k)
4720                 aggi(l,k)=aggi(l,k)+ghalf
4721                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4722                 aggj(l,k)=aggj(l,k)+ghalf
4723               enddo
4724             enddo
4725             if (j.eq.nres-1 .and. i.lt.j-2) then
4726               do k=1,4
4727                 do l=1,3
4728                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4729                 enddo
4730               enddo
4731             endif
4732           endif
4733  128  continue
4734 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4735       return
4736       end subroutine eelecij
4737 !-----------------------------------------------------------------------------
4738       subroutine eturn3(i,eello_turn3)
4739 ! Third- and fourth-order contributions from turns
4740
4741       use comm_locel
4742 !      implicit real*8 (a-h,o-z)
4743 !      include 'DIMENSIONS'
4744 !      include 'COMMON.IOUNITS'
4745 !      include 'COMMON.GEO'
4746 !      include 'COMMON.VAR'
4747 !      include 'COMMON.LOCAL'
4748 !      include 'COMMON.CHAIN'
4749 !      include 'COMMON.DERIV'
4750 !      include 'COMMON.INTERACT'
4751 !      include 'COMMON.CONTACTS'
4752 !      include 'COMMON.TORSION'
4753 !      include 'COMMON.VECTORS'
4754 !      include 'COMMON.FFIELD'
4755 !      include 'COMMON.CONTROL'
4756       real(kind=8),dimension(3) :: ggg
4757       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4758         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4759        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4760
4761       real(kind=8),dimension(2) :: auxvec,auxvec1
4762 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4763       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4764 !el      integer :: num_conti,j1,j2
4765 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4766 !el        dz_normi,xmedi,ymedi,zmedi
4767
4768 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4769 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4770 !el         num_conti,j1,j2
4771 !el local variables
4772       integer :: i,j,l,k,ilist,iresshield
4773       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4774
4775       j=i+2
4776 !      write (iout,*) "eturn3",i,j,j1,j2
4777           zj=(c(3,j)+c(3,j+1))/2.0d0
4778           zj=mod(zj,boxzsize)
4779           if (zj.lt.0) zj=zj+boxzsize
4780           if ((zj.lt.0)) write (*,*) "CHUJ"
4781        if ((zj.gt.bordlipbot)  &
4782         .and.(zj.lt.bordliptop)) then
4783 !C the energy transfer exist
4784         if (zj.lt.buflipbot) then
4785 !C what fraction I am in
4786          fracinbuf=1.0d0-     &
4787              ((zj-bordlipbot)/lipbufthick)
4788 !C lipbufthick is thickenes of lipid buffore
4789          sslipj=sscalelip(fracinbuf)
4790          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4791         elseif (zj.gt.bufliptop) then
4792          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4793          sslipj=sscalelip(fracinbuf)
4794          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4795         else
4796          sslipj=1.0d0
4797          ssgradlipj=0.0
4798         endif
4799        else
4800          sslipj=0.0d0
4801          ssgradlipj=0.0
4802        endif
4803
4804       a_temp(1,1)=a22
4805       a_temp(1,2)=a23
4806       a_temp(2,1)=a32
4807       a_temp(2,2)=a33
4808 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4809 !
4810 !               Third-order contributions
4811 !
4812 !                 (i+2)o----(i+3)
4813 !                      | |
4814 !                      | |
4815 !                 (i+1)o----i
4816 !
4817 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4818 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4819         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4820         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4821         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4822         call transpose2(auxmat(1,1),auxmat1(1,1))
4823         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4824         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4825         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4826         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4827         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4828
4829         if (shield_mode.eq.0) then
4830         fac_shield(i)=1.0d0
4831         fac_shield(j)=1.0d0
4832         endif
4833
4834         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4835          *fac_shield(i)*fac_shield(j)  &
4836          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4837         eello_t3= &
4838         0.5d0*(pizda(1,1)+pizda(2,2)) &
4839         *fac_shield(i)*fac_shield(j)
4840
4841         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4842                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4843 !C#ifdef NEWCORR
4844 !C Derivatives in theta
4845         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4846        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4847         *fac_shield(i)*fac_shield(j)
4848         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4849        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4850         *fac_shield(i)*fac_shield(j)
4851 !C#endif
4852
4853
4854
4855           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4856        (shield_mode.gt.0)) then
4857 !C          print *,i,j
4858
4859           do ilist=1,ishield_list(i)
4860            iresshield=shield_list(ilist,i)
4861            do k=1,3
4862            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4863            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4864                    rlocshield &
4865            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4866             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4867              +rlocshield
4868            enddo
4869           enddo
4870           do ilist=1,ishield_list(j)
4871            iresshield=shield_list(ilist,j)
4872            do k=1,3
4873            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4874            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4875                    rlocshield &
4876            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4877            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4878                   +rlocshield
4879
4880            enddo
4881           enddo
4882
4883           do k=1,3
4884             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4885                    grad_shield(k,i)*eello_t3/fac_shield(i)
4886             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4887                    grad_shield(k,j)*eello_t3/fac_shield(j)
4888             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4889                    grad_shield(k,i)*eello_t3/fac_shield(i)
4890             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4891                    grad_shield(k,j)*eello_t3/fac_shield(j)
4892            enddo
4893            endif
4894
4895 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4896 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4897 !d     &    ' eello_turn3_num',4*eello_turn3_num
4898 ! Derivatives in gamma(i)
4899         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4900         call transpose2(auxmat2(1,1),auxmat3(1,1))
4901         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4902         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4903           *fac_shield(i)*fac_shield(j)        &
4904           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4905 ! Derivatives in gamma(i+1)
4906         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4907         call transpose2(auxmat2(1,1),auxmat3(1,1))
4908         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4909         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4910           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4911           *fac_shield(i)*fac_shield(j)        &
4912           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4913
4914 ! Cartesian derivatives
4915         do l=1,3
4916 !            ghalf1=0.5d0*agg(l,1)
4917 !            ghalf2=0.5d0*agg(l,2)
4918 !            ghalf3=0.5d0*agg(l,3)
4919 !            ghalf4=0.5d0*agg(l,4)
4920           a_temp(1,1)=aggi(l,1)!+ghalf1
4921           a_temp(1,2)=aggi(l,2)!+ghalf2
4922           a_temp(2,1)=aggi(l,3)!+ghalf3
4923           a_temp(2,2)=aggi(l,4)!+ghalf4
4924           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4925           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4926             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4927           *fac_shield(i)*fac_shield(j)      &
4928           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4929
4930           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4931           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4932           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4933           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4934           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4935           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4936             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4937           *fac_shield(i)*fac_shield(j)        &
4938           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4939
4940           a_temp(1,1)=aggj(l,1)!+ghalf1
4941           a_temp(1,2)=aggj(l,2)!+ghalf2
4942           a_temp(2,1)=aggj(l,3)!+ghalf3
4943           a_temp(2,2)=aggj(l,4)!+ghalf4
4944           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4945           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4946             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4947           *fac_shield(i)*fac_shield(j)      &
4948           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4949
4950           a_temp(1,1)=aggj1(l,1)
4951           a_temp(1,2)=aggj1(l,2)
4952           a_temp(2,1)=aggj1(l,3)
4953           a_temp(2,2)=aggj1(l,4)
4954           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4955           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4956             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4957           *fac_shield(i)*fac_shield(j)        &
4958           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4959         enddo
4960          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4961           ssgradlipi*eello_t3/4.0d0*lipscale
4962          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4963           ssgradlipj*eello_t3/4.0d0*lipscale
4964          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4965           ssgradlipi*eello_t3/4.0d0*lipscale
4966          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4967           ssgradlipj*eello_t3/4.0d0*lipscale
4968
4969       return
4970       end subroutine eturn3
4971 !-----------------------------------------------------------------------------
4972       subroutine eturn4(i,eello_turn4)
4973 ! Third- and fourth-order contributions from turns
4974
4975       use comm_locel
4976 !      implicit real*8 (a-h,o-z)
4977 !      include 'DIMENSIONS'
4978 !      include 'COMMON.IOUNITS'
4979 !      include 'COMMON.GEO'
4980 !      include 'COMMON.VAR'
4981 !      include 'COMMON.LOCAL'
4982 !      include 'COMMON.CHAIN'
4983 !      include 'COMMON.DERIV'
4984 !      include 'COMMON.INTERACT'
4985 !      include 'COMMON.CONTACTS'
4986 !      include 'COMMON.TORSION'
4987 !      include 'COMMON.VECTORS'
4988 !      include 'COMMON.FFIELD'
4989 !      include 'COMMON.CONTROL'
4990       real(kind=8),dimension(3) :: ggg
4991       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4992         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4993         gte1t,gte2t,gte3t,&
4994         gte1a,gtae3,gtae3e2, ae3gte2,&
4995         gtEpizda1,gtEpizda2,gtEpizda3
4996
4997       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4998        auxgEvec3,auxgvec
4999
5000 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5001       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5002 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5003 !el        dz_normi,xmedi,ymedi,zmedi
5004 !el      integer :: num_conti,j1,j2
5005 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5006 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5007 !el          num_conti,j1,j2
5008 !el local variables
5009       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5010       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5011          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5012
5013       j=i+3
5014 !      if (j.ne.20) return
5015 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5016 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5017 !
5018 !               Fourth-order contributions
5019 !
5020 !                 (i+3)o----(i+4)
5021 !                     /  |
5022 !               (i+2)o   |
5023 !                     \  |
5024 !                 (i+1)o----i
5025 !
5026 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5027 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5028 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5029           zj=(c(3,j)+c(3,j+1))/2.0d0
5030           zj=mod(zj,boxzsize)
5031           if (zj.lt.0) zj=zj+boxzsize
5032        if ((zj.gt.bordlipbot)  &
5033         .and.(zj.lt.bordliptop)) then
5034 !C the energy transfer exist
5035         if (zj.lt.buflipbot) then
5036 !C what fraction I am in
5037          fracinbuf=1.0d0-     &
5038              ((zj-bordlipbot)/lipbufthick)
5039 !C lipbufthick is thickenes of lipid buffore
5040          sslipj=sscalelip(fracinbuf)
5041          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5042         elseif (zj.gt.bufliptop) then
5043          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5044          sslipj=sscalelip(fracinbuf)
5045          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5046         else
5047          sslipj=1.0d0
5048          ssgradlipj=0.0
5049         endif
5050        else
5051          sslipj=0.0d0
5052          ssgradlipj=0.0
5053        endif
5054
5055         a_temp(1,1)=a22
5056         a_temp(1,2)=a23
5057         a_temp(2,1)=a32
5058         a_temp(2,2)=a33
5059         iti1=i+1
5060         iti2=i+2
5061         iti3=i+3
5062 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5063         call transpose2(EUg(1,1,i+1),e1t(1,1))
5064         call transpose2(Eug(1,1,i+2),e2t(1,1))
5065         call transpose2(Eug(1,1,i+3),e3t(1,1))
5066 !C Ematrix derivative in theta
5067         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5068         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5069         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5070
5071         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5072         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5073         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5074         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5075 !c       auxalary matrix of E i+1
5076         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5077         s1=scalar2(b1(1,iti2),auxvec(1))
5078 !c derivative of theta i+2 with constant i+3
5079         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5080 !c derivative of theta i+2 with constant i+2
5081         gs32=scalar2(b1(1,i+2),auxgvec(1))
5082 !c derivative of E matix in theta of i+1
5083         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5084
5085         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5086         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5087         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5088 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5089         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5090 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5091         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5092         s2=scalar2(b1(1,i+1),auxvec(1))
5093 !c derivative of theta i+1 with constant i+3
5094         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5095 !c derivative of theta i+2 with constant i+1
5096         gs21=scalar2(b1(1,i+1),auxgvec(1))
5097 !c derivative of theta i+3 with constant i+1
5098         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5099
5100         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5101         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5102 !c ae3gte2 is derivative over i+2
5103         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5104
5105         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5106         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5107 !c i+2
5108         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5109 !c i+3
5110         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5111
5112         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5113         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5114         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5115         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5116         if (shield_mode.eq.0) then
5117         fac_shield(i)=1.0
5118         fac_shield(j)=1.0
5119         endif
5120
5121         eello_turn4=eello_turn4-(s1+s2+s3) &
5122         *fac_shield(i)*fac_shield(j)       &
5123         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5124         eello_t4=-(s1+s2+s3)  &
5125           *fac_shield(i)*fac_shield(j)
5126 !C Now derivative over shield:
5127           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5128          (shield_mode.gt.0)) then
5129 !C          print *,i,j
5130
5131           do ilist=1,ishield_list(i)
5132            iresshield=shield_list(ilist,i)
5133            do k=1,3
5134            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5135 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5136            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5137                    rlocshield &
5138             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5139             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5140            +rlocshield
5141            enddo
5142           enddo
5143           do ilist=1,ishield_list(j)
5144            iresshield=shield_list(ilist,j)
5145            do k=1,3
5146 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5147            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5148            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5149                    rlocshield  &
5150            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5151            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5152                   +rlocshield
5153 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5154
5155            enddo
5156           enddo
5157           do k=1,3
5158             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5159                    grad_shield(k,i)*eello_t4/fac_shield(i)
5160             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5161                    grad_shield(k,j)*eello_t4/fac_shield(j)
5162             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5163                    grad_shield(k,i)*eello_t4/fac_shield(i)
5164             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5165                    grad_shield(k,j)*eello_t4/fac_shield(j)
5166 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5167            enddo
5168            endif
5169 #ifdef NEWCORR
5170         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5171                        -(gs13+gsE13+gsEE1)*wturn4&
5172        *fac_shield(i)*fac_shield(j)
5173         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5174                          -(gs23+gs21+gsEE2)*wturn4&
5175        *fac_shield(i)*fac_shield(j)
5176
5177         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5178                          -(gs32+gsE31+gsEE3)*wturn4&
5179        *fac_shield(i)*fac_shield(j)
5180
5181 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5182 !c     &   gs2
5183 #endif
5184         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5185            'eturn4',i,j,-(s1+s2+s3)
5186 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5187 !d     &    ' eello_turn4_num',8*eello_turn4_num
5188 ! Derivatives in gamma(i)
5189         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5190         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5191         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5192         s1=scalar2(b1(1,i+1),auxvec(1))
5193         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5194         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5195         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5196        *fac_shield(i)*fac_shield(j)  &
5197        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5198
5199 ! Derivatives in gamma(i+1)
5200         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5201         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5202         s2=scalar2(b1(1,iti1),auxvec(1))
5203         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5204         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5205         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5206         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5207        *fac_shield(i)*fac_shield(j)  &
5208        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5209
5210 ! Derivatives in gamma(i+2)
5211         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5212         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5213         s1=scalar2(b1(1,iti2),auxvec(1))
5214         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5215         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5216         s2=scalar2(b1(1,iti1),auxvec(1))
5217         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5218         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5219         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5220         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5221        *fac_shield(i)*fac_shield(j)  &
5222        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5223
5224 ! Cartesian derivatives
5225 ! Derivatives of this turn contributions in DC(i+2)
5226         if (j.lt.nres-1) then
5227           do l=1,3
5228             a_temp(1,1)=agg(l,1)
5229             a_temp(1,2)=agg(l,2)
5230             a_temp(2,1)=agg(l,3)
5231             a_temp(2,2)=agg(l,4)
5232             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5233             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234             s1=scalar2(b1(1,iti2),auxvec(1))
5235             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5236             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237             s2=scalar2(b1(1,iti1),auxvec(1))
5238             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5239             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5240             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5241             ggg(l)=-(s1+s2+s3)
5242             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5243        *fac_shield(i)*fac_shield(j)  &
5244        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5245
5246           enddo
5247         endif
5248 ! Remaining derivatives of this turn contribution
5249         do l=1,3
5250           a_temp(1,1)=aggi(l,1)
5251           a_temp(1,2)=aggi(l,2)
5252           a_temp(2,1)=aggi(l,3)
5253           a_temp(2,2)=aggi(l,4)
5254           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5255           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5256           s1=scalar2(b1(1,iti2),auxvec(1))
5257           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5258           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5259           s2=scalar2(b1(1,iti1),auxvec(1))
5260           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5261           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5262           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5263           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5264          *fac_shield(i)*fac_shield(j)  &
5265          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5266
5267
5268           a_temp(1,1)=aggi1(l,1)
5269           a_temp(1,2)=aggi1(l,2)
5270           a_temp(2,1)=aggi1(l,3)
5271           a_temp(2,2)=aggi1(l,4)
5272           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5273           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5274           s1=scalar2(b1(1,iti2),auxvec(1))
5275           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5276           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5277           s2=scalar2(b1(1,iti1),auxvec(1))
5278           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5279           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5280           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5281           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5282          *fac_shield(i)*fac_shield(j)  &
5283          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5284
5285
5286           a_temp(1,1)=aggj(l,1)
5287           a_temp(1,2)=aggj(l,2)
5288           a_temp(2,1)=aggj(l,3)
5289           a_temp(2,2)=aggj(l,4)
5290           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5291           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5292           s1=scalar2(b1(1,iti2),auxvec(1))
5293           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5294           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5295           s2=scalar2(b1(1,iti1),auxvec(1))
5296           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5297           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5298           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5299 !        if (j.lt.nres-1) then
5300           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5301          *fac_shield(i)*fac_shield(j)  &
5302          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5303 !        endif
5304
5305           a_temp(1,1)=aggj1(l,1)
5306           a_temp(1,2)=aggj1(l,2)
5307           a_temp(2,1)=aggj1(l,3)
5308           a_temp(2,2)=aggj1(l,4)
5309           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5310           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5311           s1=scalar2(b1(1,iti2),auxvec(1))
5312           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5313           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5314           s2=scalar2(b1(1,iti1),auxvec(1))
5315           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5316           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5317           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5318 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5319 !        if (j.lt.nres-1) then
5320 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5321           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5322          *fac_shield(i)*fac_shield(j)  &
5323          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5324 !            if (shield_mode.gt.0) then
5325 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5326 !            else
5327 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5328 !            endif
5329 !         endif
5330         enddo
5331          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5332           ssgradlipi*eello_t4/4.0d0*lipscale
5333          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5334           ssgradlipj*eello_t4/4.0d0*lipscale
5335          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5336           ssgradlipi*eello_t4/4.0d0*lipscale
5337          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5338           ssgradlipj*eello_t4/4.0d0*lipscale
5339
5340       return
5341       end subroutine eturn4
5342 !-----------------------------------------------------------------------------
5343       subroutine unormderiv(u,ugrad,unorm,ungrad)
5344 ! This subroutine computes the derivatives of a normalized vector u, given
5345 ! the derivatives computed without normalization conditions, ugrad. Returns
5346 ! ungrad.
5347 !      implicit none
5348       real(kind=8),dimension(3) :: u,vec
5349       real(kind=8),dimension(3,3) ::ugrad,ungrad
5350       real(kind=8) :: unorm      !,scalar
5351       integer :: i,j
5352 !      write (2,*) 'ugrad',ugrad
5353 !      write (2,*) 'u',u
5354       do i=1,3
5355         vec(i)=scalar(ugrad(1,i),u(1))
5356       enddo
5357 !      write (2,*) 'vec',vec
5358       do i=1,3
5359         do j=1,3
5360           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5361         enddo
5362       enddo
5363 !      write (2,*) 'ungrad',ungrad
5364       return
5365       end subroutine unormderiv
5366 !-----------------------------------------------------------------------------
5367       subroutine escp_soft_sphere(evdw2,evdw2_14)
5368 !
5369 ! This subroutine calculates the excluded-volume interaction energy between
5370 ! peptide-group centers and side chains and its gradient in virtual-bond and
5371 ! side-chain vectors.
5372 !
5373 !      implicit real*8 (a-h,o-z)
5374 !      include 'DIMENSIONS'
5375 !      include 'COMMON.GEO'
5376 !      include 'COMMON.VAR'
5377 !      include 'COMMON.LOCAL'
5378 !      include 'COMMON.CHAIN'
5379 !      include 'COMMON.DERIV'
5380 !      include 'COMMON.INTERACT'
5381 !      include 'COMMON.FFIELD'
5382 !      include 'COMMON.IOUNITS'
5383 !      include 'COMMON.CONTROL'
5384       real(kind=8),dimension(3) :: ggg
5385 !el local variables
5386       integer :: i,iint,j,k,iteli,itypj
5387       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5388                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5389
5390       evdw2=0.0D0
5391       evdw2_14=0.0d0
5392       r0_scp=4.5d0
5393 !d    print '(a)','Enter ESCP'
5394 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5395       do i=iatscp_s,iatscp_e
5396         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5397         iteli=itel(i)
5398         xi=0.5D0*(c(1,i)+c(1,i+1))
5399         yi=0.5D0*(c(2,i)+c(2,i+1))
5400         zi=0.5D0*(c(3,i)+c(3,i+1))
5401
5402         do iint=1,nscp_gr(i)
5403
5404         do j=iscpstart(i,iint),iscpend(i,iint)
5405           if (itype(j,1).eq.ntyp1) cycle
5406           itypj=iabs(itype(j,1))
5407 ! Uncomment following three lines for SC-p interactions
5408 !         xj=c(1,nres+j)-xi
5409 !         yj=c(2,nres+j)-yi
5410 !         zj=c(3,nres+j)-zi
5411 ! Uncomment following three lines for Ca-p interactions
5412           xj=c(1,j)-xi
5413           yj=c(2,j)-yi
5414           zj=c(3,j)-zi
5415           rij=xj*xj+yj*yj+zj*zj
5416           r0ij=r0_scp
5417           r0ijsq=r0ij*r0ij
5418           if (rij.lt.r0ijsq) then
5419             evdwij=0.25d0*(rij-r0ijsq)**2
5420             fac=rij-r0ijsq
5421           else
5422             evdwij=0.0d0
5423             fac=0.0d0
5424           endif
5425           evdw2=evdw2+evdwij
5426 !
5427 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5428 !
5429           ggg(1)=xj*fac
5430           ggg(2)=yj*fac
5431           ggg(3)=zj*fac
5432 !grad          if (j.lt.i) then
5433 !d          write (iout,*) 'j<i'
5434 ! Uncomment following three lines for SC-p interactions
5435 !           do k=1,3
5436 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5437 !           enddo
5438 !grad          else
5439 !d          write (iout,*) 'j>i'
5440 !grad            do k=1,3
5441 !grad              ggg(k)=-ggg(k)
5442 ! Uncomment following line for SC-p interactions
5443 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5444 !grad            enddo
5445 !grad          endif
5446 !grad          do k=1,3
5447 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5448 !grad          enddo
5449 !grad          kstart=min0(i+1,j)
5450 !grad          kend=max0(i-1,j-1)
5451 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5452 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5453 !grad          do k=kstart,kend
5454 !grad            do l=1,3
5455 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5456 !grad            enddo
5457 !grad          enddo
5458           do k=1,3
5459             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5460             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5461           enddo
5462         enddo
5463
5464         enddo ! iint
5465       enddo ! i
5466       return
5467       end subroutine escp_soft_sphere
5468 !-----------------------------------------------------------------------------
5469       subroutine escp(evdw2,evdw2_14)
5470 !
5471 ! This subroutine calculates the excluded-volume interaction energy between
5472 ! peptide-group centers and side chains and its gradient in virtual-bond and
5473 ! side-chain vectors.
5474 !
5475 !      implicit real*8 (a-h,o-z)
5476 !      include 'DIMENSIONS'
5477 !      include 'COMMON.GEO'
5478 !      include 'COMMON.VAR'
5479 !      include 'COMMON.LOCAL'
5480 !      include 'COMMON.CHAIN'
5481 !      include 'COMMON.DERIV'
5482 !      include 'COMMON.INTERACT'
5483 !      include 'COMMON.FFIELD'
5484 !      include 'COMMON.IOUNITS'
5485 !      include 'COMMON.CONTROL'
5486       real(kind=8),dimension(3) :: ggg
5487 !el local variables
5488       integer :: i,iint,j,k,iteli,itypj,subchap
5489       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5490                    e1,e2,evdwij,rij
5491       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5492                     dist_temp, dist_init
5493       integer xshift,yshift,zshift
5494
5495       evdw2=0.0D0
5496       evdw2_14=0.0d0
5497 !d    print '(a)','Enter ESCP'
5498 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5499       do i=iatscp_s,iatscp_e
5500         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5501         iteli=itel(i)
5502         xi=0.5D0*(c(1,i)+c(1,i+1))
5503         yi=0.5D0*(c(2,i)+c(2,i+1))
5504         zi=0.5D0*(c(3,i)+c(3,i+1))
5505           xi=mod(xi,boxxsize)
5506           if (xi.lt.0) xi=xi+boxxsize
5507           yi=mod(yi,boxysize)
5508           if (yi.lt.0) yi=yi+boxysize
5509           zi=mod(zi,boxzsize)
5510           if (zi.lt.0) zi=zi+boxzsize
5511
5512         do iint=1,nscp_gr(i)
5513
5514         do j=iscpstart(i,iint),iscpend(i,iint)
5515           itypj=iabs(itype(j,1))
5516           if (itypj.eq.ntyp1) cycle
5517 ! Uncomment following three lines for SC-p interactions
5518 !         xj=c(1,nres+j)-xi
5519 !         yj=c(2,nres+j)-yi
5520 !         zj=c(3,nres+j)-zi
5521 ! Uncomment following three lines for Ca-p interactions
5522 !          xj=c(1,j)-xi
5523 !          yj=c(2,j)-yi
5524 !          zj=c(3,j)-zi
5525           xj=c(1,j)
5526           yj=c(2,j)
5527           zj=c(3,j)
5528           xj=mod(xj,boxxsize)
5529           if (xj.lt.0) xj=xj+boxxsize
5530           yj=mod(yj,boxysize)
5531           if (yj.lt.0) yj=yj+boxysize
5532           zj=mod(zj,boxzsize)
5533           if (zj.lt.0) zj=zj+boxzsize
5534       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5535       xj_safe=xj
5536       yj_safe=yj
5537       zj_safe=zj
5538       subchap=0
5539       do xshift=-1,1
5540       do yshift=-1,1
5541       do zshift=-1,1
5542           xj=xj_safe+xshift*boxxsize
5543           yj=yj_safe+yshift*boxysize
5544           zj=zj_safe+zshift*boxzsize
5545           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5546           if(dist_temp.lt.dist_init) then
5547             dist_init=dist_temp
5548             xj_temp=xj
5549             yj_temp=yj
5550             zj_temp=zj
5551             subchap=1
5552           endif
5553        enddo
5554        enddo
5555        enddo
5556        if (subchap.eq.1) then
5557           xj=xj_temp-xi
5558           yj=yj_temp-yi
5559           zj=zj_temp-zi
5560        else
5561           xj=xj_safe-xi
5562           yj=yj_safe-yi
5563           zj=zj_safe-zi
5564        endif
5565
5566           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5567           rij=dsqrt(1.0d0/rrij)
5568             sss_ele_cut=sscale_ele(rij)
5569             sss_ele_grad=sscagrad_ele(rij)
5570 !            print *,sss_ele_cut,sss_ele_grad,&
5571 !            (rij),r_cut_ele,rlamb_ele
5572             if (sss_ele_cut.le.0.0) cycle
5573           fac=rrij**expon2
5574           e1=fac*fac*aad(itypj,iteli)
5575           e2=fac*bad(itypj,iteli)
5576           if (iabs(j-i) .le. 2) then
5577             e1=scal14*e1
5578             e2=scal14*e2
5579             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5580           endif
5581           evdwij=e1+e2
5582           evdw2=evdw2+evdwij*sss_ele_cut
5583 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5584 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5585           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5586              'evdw2',i,j,evdwij
5587 !
5588 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5589 !
5590           fac=-(evdwij+e1)*rrij*sss_ele_cut
5591           fac=fac+evdwij*sss_ele_grad/rij/expon
5592           ggg(1)=xj*fac
5593           ggg(2)=yj*fac
5594           ggg(3)=zj*fac
5595 !grad          if (j.lt.i) then
5596 !d          write (iout,*) 'j<i'
5597 ! Uncomment following three lines for SC-p interactions
5598 !           do k=1,3
5599 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5600 !           enddo
5601 !grad          else
5602 !d          write (iout,*) 'j>i'
5603 !grad            do k=1,3
5604 !grad              ggg(k)=-ggg(k)
5605 ! Uncomment following line for SC-p interactions
5606 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5607 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5608 !grad            enddo
5609 !grad          endif
5610 !grad          do k=1,3
5611 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5612 !grad          enddo
5613 !grad          kstart=min0(i+1,j)
5614 !grad          kend=max0(i-1,j-1)
5615 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5616 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5617 !grad          do k=kstart,kend
5618 !grad            do l=1,3
5619 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5620 !grad            enddo
5621 !grad          enddo
5622           do k=1,3
5623             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5624             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5625           enddo
5626         enddo
5627
5628         enddo ! iint
5629       enddo ! i
5630       do i=1,nct
5631         do j=1,3
5632           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5633           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5634           gradx_scp(j,i)=expon*gradx_scp(j,i)
5635         enddo
5636       enddo
5637 !******************************************************************************
5638 !
5639 !                              N O T E !!!
5640 !
5641 ! To save time the factor EXPON has been extracted from ALL components
5642 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5643 ! use!
5644 !
5645 !******************************************************************************
5646       return
5647       end subroutine escp
5648 !-----------------------------------------------------------------------------
5649       subroutine edis(ehpb)
5650 !
5651 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5652 !
5653 !      implicit real*8 (a-h,o-z)
5654 !      include 'DIMENSIONS'
5655 !      include 'COMMON.SBRIDGE'
5656 !      include 'COMMON.CHAIN'
5657 !      include 'COMMON.DERIV'
5658 !      include 'COMMON.VAR'
5659 !      include 'COMMON.INTERACT'
5660 !      include 'COMMON.IOUNITS'
5661       real(kind=8),dimension(3) :: ggg
5662 !el local variables
5663       integer :: i,j,ii,jj,iii,jjj,k
5664       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5665
5666       ehpb=0.0D0
5667 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5668 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5669       if (link_end.eq.0) return
5670       do i=link_start,link_end
5671 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5672 ! CA-CA distance used in regularization of structure.
5673         ii=ihpb(i)
5674         jj=jhpb(i)
5675 ! iii and jjj point to the residues for which the distance is assigned.
5676         if (ii.gt.nres) then
5677           iii=ii-nres
5678           jjj=jj-nres
5679         else
5680           iii=ii
5681           jjj=jj
5682         endif
5683 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5684 !     &    dhpb(i),dhpb1(i),forcon(i)
5685 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5686 !    distance and angle dependent SS bond potential.
5687 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5688 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5689         if (.not.dyn_ss .and. i.le.nss) then
5690 ! 15/02/13 CC dynamic SSbond - additional check
5691          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5692         iabs(itype(jjj,1)).eq.1) then
5693           call ssbond_ene(iii,jjj,eij)
5694           ehpb=ehpb+2*eij
5695 !d          write (iout,*) "eij",eij
5696          endif
5697         else if (ii.gt.nres .and. jj.gt.nres) then
5698 !c Restraints from contact prediction
5699           dd=dist(ii,jj)
5700           if (constr_dist.eq.11) then
5701             ehpb=ehpb+fordepth(i)**4.0d0 &
5702                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5703             fac=fordepth(i)**4.0d0 &
5704                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5705           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5706             ehpb,fordepth(i),dd
5707            else
5708           if (dhpb1(i).gt.0.0d0) then
5709             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5710             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5711 !c            write (iout,*) "beta nmr",
5712 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5713           else
5714             dd=dist(ii,jj)
5715             rdis=dd-dhpb(i)
5716 !C Get the force constant corresponding to this distance.
5717             waga=forcon(i)
5718 !C Calculate the contribution to energy.
5719             ehpb=ehpb+waga*rdis*rdis
5720 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5721 !C
5722 !C Evaluate gradient.
5723 !C
5724             fac=waga*rdis/dd
5725           endif
5726           endif
5727           do j=1,3
5728             ggg(j)=fac*(c(j,jj)-c(j,ii))
5729           enddo
5730           do j=1,3
5731             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5732             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5733           enddo
5734           do k=1,3
5735             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5736             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5737           enddo
5738         else
5739           dd=dist(ii,jj)
5740           if (constr_dist.eq.11) then
5741             ehpb=ehpb+fordepth(i)**4.0d0 &
5742                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5743             fac=fordepth(i)**4.0d0 &
5744                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5745           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5746          ehpb,fordepth(i),dd
5747            else
5748           if (dhpb1(i).gt.0.0d0) then
5749             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5750             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5751 !c            write (iout,*) "alph nmr",
5752 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5753           else
5754             rdis=dd-dhpb(i)
5755 !C Get the force constant corresponding to this distance.
5756             waga=forcon(i)
5757 !C Calculate the contribution to energy.
5758             ehpb=ehpb+waga*rdis*rdis
5759 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5760 !C
5761 !C Evaluate gradient.
5762 !C
5763             fac=waga*rdis/dd
5764           endif
5765           endif
5766
5767             do j=1,3
5768               ggg(j)=fac*(c(j,jj)-c(j,ii))
5769             enddo
5770 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5771 !C If this is a SC-SC distance, we need to calculate the contributions to the
5772 !C Cartesian gradient in the SC vectors (ghpbx).
5773           if (iii.lt.ii) then
5774           do j=1,3
5775             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5776             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5777           enddo
5778           endif
5779 !cgrad        do j=iii,jjj-1
5780 !cgrad          do k=1,3
5781 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5782 !cgrad          enddo
5783 !cgrad        enddo
5784           do k=1,3
5785             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5786             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5787           enddo
5788         endif
5789       enddo
5790       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5791
5792       return
5793       end subroutine edis
5794 !-----------------------------------------------------------------------------
5795       subroutine ssbond_ene(i,j,eij)
5796 !
5797 ! Calculate the distance and angle dependent SS-bond potential energy
5798 ! using a free-energy function derived based on RHF/6-31G** ab initio
5799 ! calculations of diethyl disulfide.
5800 !
5801 ! A. Liwo and U. Kozlowska, 11/24/03
5802 !
5803 !      implicit real*8 (a-h,o-z)
5804 !      include 'DIMENSIONS'
5805 !      include 'COMMON.SBRIDGE'
5806 !      include 'COMMON.CHAIN'
5807 !      include 'COMMON.DERIV'
5808 !      include 'COMMON.LOCAL'
5809 !      include 'COMMON.INTERACT'
5810 !      include 'COMMON.VAR'
5811 !      include 'COMMON.IOUNITS'
5812       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5813 !el local variables
5814       integer :: i,j,itypi,itypj,k
5815       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5816                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5817                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5818                    cosphi,ggk
5819
5820       itypi=iabs(itype(i,1))
5821       xi=c(1,nres+i)
5822       yi=c(2,nres+i)
5823       zi=c(3,nres+i)
5824       dxi=dc_norm(1,nres+i)
5825       dyi=dc_norm(2,nres+i)
5826       dzi=dc_norm(3,nres+i)
5827 !      dsci_inv=dsc_inv(itypi)
5828       dsci_inv=vbld_inv(nres+i)
5829       itypj=iabs(itype(j,1))
5830 !      dscj_inv=dsc_inv(itypj)
5831       dscj_inv=vbld_inv(nres+j)
5832       xj=c(1,nres+j)-xi
5833       yj=c(2,nres+j)-yi
5834       zj=c(3,nres+j)-zi
5835       dxj=dc_norm(1,nres+j)
5836       dyj=dc_norm(2,nres+j)
5837       dzj=dc_norm(3,nres+j)
5838       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5839       rij=dsqrt(rrij)
5840       erij(1)=xj*rij
5841       erij(2)=yj*rij
5842       erij(3)=zj*rij
5843       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5844       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5845       om12=dxi*dxj+dyi*dyj+dzi*dzj
5846       do k=1,3
5847         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5848         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5849       enddo
5850       rij=1.0d0/rij
5851       deltad=rij-d0cm
5852       deltat1=1.0d0-om1
5853       deltat2=1.0d0+om2
5854       deltat12=om2-om1+2.0d0
5855       cosphi=om12-om1*om2
5856       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5857         +akct*deltad*deltat12 &
5858         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5859 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5860 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5861 !     &  " deltat12",deltat12," eij",eij
5862       ed=2*akcm*deltad+akct*deltat12
5863       pom1=akct*deltad
5864       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5865       eom1=-2*akth*deltat1-pom1-om2*pom2
5866       eom2= 2*akth*deltat2+pom1-om1*pom2
5867       eom12=pom2
5868       do k=1,3
5869         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5870         ghpbx(k,i)=ghpbx(k,i)-ggk &
5871                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5872                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5873         ghpbx(k,j)=ghpbx(k,j)+ggk &
5874                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5875                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5876         ghpbc(k,i)=ghpbc(k,i)-ggk
5877         ghpbc(k,j)=ghpbc(k,j)+ggk
5878       enddo
5879 !
5880 ! Calculate the components of the gradient in DC and X
5881 !
5882 !grad      do k=i,j-1
5883 !grad        do l=1,3
5884 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5885 !grad        enddo
5886 !grad      enddo
5887       return
5888       end subroutine ssbond_ene
5889 !-----------------------------------------------------------------------------
5890       subroutine ebond(estr)
5891 !
5892 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5893 !
5894 !      implicit real*8 (a-h,o-z)
5895 !      include 'DIMENSIONS'
5896 !      include 'COMMON.LOCAL'
5897 !      include 'COMMON.GEO'
5898 !      include 'COMMON.INTERACT'
5899 !      include 'COMMON.DERIV'
5900 !      include 'COMMON.VAR'
5901 !      include 'COMMON.CHAIN'
5902 !      include 'COMMON.IOUNITS'
5903 !      include 'COMMON.NAMES'
5904 !      include 'COMMON.FFIELD'
5905 !      include 'COMMON.CONTROL'
5906 !      include 'COMMON.SETUP'
5907       real(kind=8),dimension(3) :: u,ud
5908 !el local variables
5909       integer :: i,j,iti,nbi,k
5910       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5911                    uprod1,uprod2
5912
5913       estr=0.0d0
5914       estr1=0.0d0
5915 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5916 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5917
5918       do i=ibondp_start,ibondp_end
5919         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5920         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5921 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5922 !C          do j=1,3
5923 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5924 !C            *dc(j,i-1)/vbld(i)
5925 !C          enddo
5926 !C          if (energy_dec) write(iout,*) &
5927 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5928         diff = vbld(i)-vbldpDUM
5929         else
5930         diff = vbld(i)-vbldp0
5931         endif
5932         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5933            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5934         estr=estr+diff*diff
5935         do j=1,3
5936           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5937         enddo
5938 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5939 !        endif
5940       enddo
5941       estr=0.5d0*AKP*estr+estr1
5942 !      print *,"estr_bb",estr,AKP
5943 !
5944 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5945 !
5946       do i=ibond_start,ibond_end
5947         iti=iabs(itype(i,1))
5948         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5949         if (iti.ne.10 .and. iti.ne.ntyp1) then
5950           nbi=nbondterm(iti)
5951           if (nbi.eq.1) then
5952             diff=vbld(i+nres)-vbldsc0(1,iti)
5953             if (energy_dec) write (iout,*) &
5954             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5955             AKSC(1,iti),AKSC(1,iti)*diff*diff
5956             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5957 !            print *,"estr_sc",estr
5958             do j=1,3
5959               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5960             enddo
5961           else
5962             do j=1,nbi
5963               diff=vbld(i+nres)-vbldsc0(j,iti)
5964               ud(j)=aksc(j,iti)*diff
5965               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5966             enddo
5967             uprod=u(1)
5968             do j=2,nbi
5969               uprod=uprod*u(j)
5970             enddo
5971             usum=0.0d0
5972             usumsqder=0.0d0
5973             do j=1,nbi
5974               uprod1=1.0d0
5975               uprod2=1.0d0
5976               do k=1,nbi
5977                 if (k.ne.j) then
5978                   uprod1=uprod1*u(k)
5979                   uprod2=uprod2*u(k)*u(k)
5980                 endif
5981               enddo
5982               usum=usum+uprod1
5983               usumsqder=usumsqder+ud(j)*uprod2
5984             enddo
5985             estr=estr+uprod/usum
5986 !            print *,"estr_sc",estr,i
5987
5988              if (energy_dec) write (iout,*) &
5989             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5990             AKSC(1,iti),uprod/usum
5991             do j=1,3
5992              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5993             enddo
5994           endif
5995         endif
5996       enddo
5997       return
5998       end subroutine ebond
5999 #ifdef CRYST_THETA
6000 !-----------------------------------------------------------------------------
6001       subroutine ebend(etheta)
6002 !
6003 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6004 ! angles gamma and its derivatives in consecutive thetas and gammas.
6005 !
6006       use comm_calcthet
6007 !      implicit real*8 (a-h,o-z)
6008 !      include 'DIMENSIONS'
6009 !      include 'COMMON.LOCAL'
6010 !      include 'COMMON.GEO'
6011 !      include 'COMMON.INTERACT'
6012 !      include 'COMMON.DERIV'
6013 !      include 'COMMON.VAR'
6014 !      include 'COMMON.CHAIN'
6015 !      include 'COMMON.IOUNITS'
6016 !      include 'COMMON.NAMES'
6017 !      include 'COMMON.FFIELD'
6018 !      include 'COMMON.CONTROL'
6019 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6020 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6021 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6022 !el      integer :: it
6023 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6024 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6025 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6026 !el local variables
6027       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6028        ichir21,ichir22
6029       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6030        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6031        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6032       real(kind=8),dimension(2) :: y,z
6033
6034       delta=0.02d0*pi
6035 !      time11=dexp(-2*time)
6036 !      time12=1.0d0
6037       etheta=0.0D0
6038 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6039       do i=ithet_start,ithet_end
6040         if (itype(i-1,1).eq.ntyp1) cycle
6041 ! Zero the energy function and its derivative at 0 or pi.
6042         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6043         it=itype(i-1,1)
6044         ichir1=isign(1,itype(i-2,1))
6045         ichir2=isign(1,itype(i,1))
6046          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6047          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6048          if (itype(i-1,1).eq.10) then
6049           itype1=isign(10,itype(i-2,1))
6050           ichir11=isign(1,itype(i-2,1))
6051           ichir12=isign(1,itype(i-2,1))
6052           itype2=isign(10,itype(i,1))
6053           ichir21=isign(1,itype(i,1))
6054           ichir22=isign(1,itype(i,1))
6055          endif
6056
6057         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6058 #ifdef OSF
6059           phii=phi(i)
6060           if (phii.ne.phii) phii=150.0
6061 #else
6062           phii=phi(i)
6063 #endif
6064           y(1)=dcos(phii)
6065           y(2)=dsin(phii)
6066         else
6067           y(1)=0.0D0
6068           y(2)=0.0D0
6069         endif
6070         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6071 #ifdef OSF
6072           phii1=phi(i+1)
6073           if (phii1.ne.phii1) phii1=150.0
6074           phii1=pinorm(phii1)
6075           z(1)=cos(phii1)
6076 #else
6077           phii1=phi(i+1)
6078           z(1)=dcos(phii1)
6079 #endif
6080           z(2)=dsin(phii1)
6081         else
6082           z(1)=0.0D0
6083           z(2)=0.0D0
6084         endif
6085 ! Calculate the "mean" value of theta from the part of the distribution
6086 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6087 ! In following comments this theta will be referred to as t_c.
6088         thet_pred_mean=0.0d0
6089         do k=1,2
6090             athetk=athet(k,it,ichir1,ichir2)
6091             bthetk=bthet(k,it,ichir1,ichir2)
6092           if (it.eq.10) then
6093              athetk=athet(k,itype1,ichir11,ichir12)
6094              bthetk=bthet(k,itype2,ichir21,ichir22)
6095           endif
6096          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6097         enddo
6098         dthett=thet_pred_mean*ssd
6099         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6100 ! Derivatives of the "mean" values in gamma1 and gamma2.
6101         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6102                +athet(2,it,ichir1,ichir2)*y(1))*ss
6103         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6104                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6105          if (it.eq.10) then
6106         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6107              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6108         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6109                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6110          endif
6111         if (theta(i).gt.pi-delta) then
6112           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6113                E_tc0)
6114           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6115           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6116           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6117               E_theta)
6118           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6119               E_tc)
6120         else if (theta(i).lt.delta) then
6121           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6122           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6123           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6124               E_theta)
6125           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6126           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6127               E_tc)
6128         else
6129           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6130               E_theta,E_tc)
6131         endif
6132         etheta=etheta+ethetai
6133         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6134             'ebend',i,ethetai
6135         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6136         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6137         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6138       enddo
6139 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6140
6141 ! Ufff.... We've done all this!!!
6142       return
6143       end subroutine ebend
6144 !-----------------------------------------------------------------------------
6145       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6146
6147       use comm_calcthet
6148 !      implicit real*8 (a-h,o-z)
6149 !      include 'DIMENSIONS'
6150 !      include 'COMMON.LOCAL'
6151 !      include 'COMMON.IOUNITS'
6152 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6153 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6154 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6155       integer :: i,j,k
6156       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6157 !el      integer :: it
6158 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6159 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6160 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6161 !el local variables
6162       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6163        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6164
6165 ! Calculate the contributions to both Gaussian lobes.
6166 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6167 ! The "polynomial part" of the "standard deviation" of this part of
6168 ! the distribution.
6169         sig=polthet(3,it)
6170         do j=2,0,-1
6171           sig=sig*thet_pred_mean+polthet(j,it)
6172         enddo
6173 ! Derivative of the "interior part" of the "standard deviation of the"
6174 ! gamma-dependent Gaussian lobe in t_c.
6175         sigtc=3*polthet(3,it)
6176         do j=2,1,-1
6177           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6178         enddo
6179         sigtc=sig*sigtc
6180 ! Set the parameters of both Gaussian lobes of the distribution.
6181 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6182         fac=sig*sig+sigc0(it)
6183         sigcsq=fac+fac
6184         sigc=1.0D0/sigcsq
6185 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6186         sigsqtc=-4.0D0*sigcsq*sigtc
6187 !       print *,i,sig,sigtc,sigsqtc
6188 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6189         sigtc=-sigtc/(fac*fac)
6190 ! Following variable is sigma(t_c)**(-2)
6191         sigcsq=sigcsq*sigcsq
6192         sig0i=sig0(it)
6193         sig0inv=1.0D0/sig0i**2
6194         delthec=thetai-thet_pred_mean
6195         delthe0=thetai-theta0i
6196         term1=-0.5D0*sigcsq*delthec*delthec
6197         term2=-0.5D0*sig0inv*delthe0*delthe0
6198 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6199 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6200 ! to the energy (this being the log of the distribution) at the end of energy
6201 ! term evaluation for this virtual-bond angle.
6202         if (term1.gt.term2) then
6203           termm=term1
6204           term2=dexp(term2-termm)
6205           term1=1.0d0
6206         else
6207           termm=term2
6208           term1=dexp(term1-termm)
6209           term2=1.0d0
6210         endif
6211 ! The ratio between the gamma-independent and gamma-dependent lobes of
6212 ! the distribution is a Gaussian function of thet_pred_mean too.
6213         diffak=gthet(2,it)-thet_pred_mean
6214         ratak=diffak/gthet(3,it)**2
6215         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6216 ! Let's differentiate it in thet_pred_mean NOW.
6217         aktc=ak*ratak
6218 ! Now put together the distribution terms to make complete distribution.
6219         termexp=term1+ak*term2
6220         termpre=sigc+ak*sig0i
6221 ! Contribution of the bending energy from this theta is just the -log of
6222 ! the sum of the contributions from the two lobes and the pre-exponential
6223 ! factor. Simple enough, isn't it?
6224         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6225 ! NOW the derivatives!!!
6226 ! 6/6/97 Take into account the deformation.
6227         E_theta=(delthec*sigcsq*term1 &
6228              +ak*delthe0*sig0inv*term2)/termexp
6229         E_tc=((sigtc+aktc*sig0i)/termpre &
6230             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6231              aktc*term2)/termexp)
6232       return
6233       end subroutine theteng
6234 #else
6235 !-----------------------------------------------------------------------------
6236       subroutine ebend(etheta)
6237 !
6238 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6239 ! angles gamma and its derivatives in consecutive thetas and gammas.
6240 ! ab initio-derived potentials from
6241 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6242 !
6243 !      implicit real*8 (a-h,o-z)
6244 !      include 'DIMENSIONS'
6245 !      include 'COMMON.LOCAL'
6246 !      include 'COMMON.GEO'
6247 !      include 'COMMON.INTERACT'
6248 !      include 'COMMON.DERIV'
6249 !      include 'COMMON.VAR'
6250 !      include 'COMMON.CHAIN'
6251 !      include 'COMMON.IOUNITS'
6252 !      include 'COMMON.NAMES'
6253 !      include 'COMMON.FFIELD'
6254 !      include 'COMMON.CONTROL'
6255       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6256       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6257       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6258       logical :: lprn=.false., lprn1=.false.
6259 !el local variables
6260       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6261       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6262       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6263 ! local variables for constrains
6264       real(kind=8) :: difi,thetiii
6265        integer itheta
6266 !      write(iout,*) "in ebend",ithet_start,ithet_end
6267       call flush(iout)
6268       etheta=0.0D0
6269       do i=ithet_start,ithet_end
6270         if (itype(i-1,1).eq.ntyp1) cycle
6271         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6272         if (iabs(itype(i+1,1)).eq.20) iblock=2
6273         if (iabs(itype(i+1,1)).ne.20) iblock=1
6274         dethetai=0.0d0
6275         dephii=0.0d0
6276         dephii1=0.0d0
6277         theti2=0.5d0*theta(i)
6278         ityp2=ithetyp((itype(i-1,1)))
6279         do k=1,nntheterm
6280           coskt(k)=dcos(k*theti2)
6281           sinkt(k)=dsin(k*theti2)
6282         enddo
6283         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6284 #ifdef OSF
6285           phii=phi(i)
6286           if (phii.ne.phii) phii=150.0
6287 #else
6288           phii=phi(i)
6289 #endif
6290           ityp1=ithetyp((itype(i-2,1)))
6291 ! propagation of chirality for glycine type
6292           do k=1,nsingle
6293             cosph1(k)=dcos(k*phii)
6294             sinph1(k)=dsin(k*phii)
6295           enddo
6296         else
6297           phii=0.0d0
6298           ityp1=ithetyp(itype(i-2,1))
6299           do k=1,nsingle
6300             cosph1(k)=0.0d0
6301             sinph1(k)=0.0d0
6302           enddo
6303         endif
6304         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6305 #ifdef OSF
6306           phii1=phi(i+1)
6307           if (phii1.ne.phii1) phii1=150.0
6308           phii1=pinorm(phii1)
6309 #else
6310           phii1=phi(i+1)
6311 #endif
6312           ityp3=ithetyp((itype(i,1)))
6313           do k=1,nsingle
6314             cosph2(k)=dcos(k*phii1)
6315             sinph2(k)=dsin(k*phii1)
6316           enddo
6317         else
6318           phii1=0.0d0
6319           ityp3=ithetyp(itype(i,1))
6320           do k=1,nsingle
6321             cosph2(k)=0.0d0
6322             sinph2(k)=0.0d0
6323           enddo
6324         endif
6325         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6326         do k=1,ndouble
6327           do l=1,k-1
6328             ccl=cosph1(l)*cosph2(k-l)
6329             ssl=sinph1(l)*sinph2(k-l)
6330             scl=sinph1(l)*cosph2(k-l)
6331             csl=cosph1(l)*sinph2(k-l)
6332             cosph1ph2(l,k)=ccl-ssl
6333             cosph1ph2(k,l)=ccl+ssl
6334             sinph1ph2(l,k)=scl+csl
6335             sinph1ph2(k,l)=scl-csl
6336           enddo
6337         enddo
6338         if (lprn) then
6339         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6340           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6341         write (iout,*) "coskt and sinkt"
6342         do k=1,nntheterm
6343           write (iout,*) k,coskt(k),sinkt(k)
6344         enddo
6345         endif
6346         do k=1,ntheterm
6347           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6348           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6349             *coskt(k)
6350           if (lprn) &
6351           write (iout,*) "k",k,&
6352            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6353            " ethetai",ethetai
6354         enddo
6355         if (lprn) then
6356         write (iout,*) "cosph and sinph"
6357         do k=1,nsingle
6358           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6359         enddo
6360         write (iout,*) "cosph1ph2 and sinph2ph2"
6361         do k=2,ndouble
6362           do l=1,k-1
6363             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6364                sinph1ph2(l,k),sinph1ph2(k,l)
6365           enddo
6366         enddo
6367         write(iout,*) "ethetai",ethetai
6368         endif
6369         do m=1,ntheterm2
6370           do k=1,nsingle
6371             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6372                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6373                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6374                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6375             ethetai=ethetai+sinkt(m)*aux
6376             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6377             dephii=dephii+k*sinkt(m)* &
6378                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6379                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6380             dephii1=dephii1+k*sinkt(m)* &
6381                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6382                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6383             if (lprn) &
6384             write (iout,*) "m",m," k",k," bbthet", &
6385                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6386                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6387                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6388                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6389           enddo
6390         enddo
6391         if (lprn) &
6392         write(iout,*) "ethetai",ethetai
6393         do m=1,ntheterm3
6394           do k=2,ndouble
6395             do l=1,k-1
6396               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6397                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6398                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6399                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6400               ethetai=ethetai+sinkt(m)*aux
6401               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6402               dephii=dephii+l*sinkt(m)* &
6403                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6404                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6405                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6406                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6407               dephii1=dephii1+(k-l)*sinkt(m)* &
6408                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6409                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6410                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6411                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6412               if (lprn) then
6413               write (iout,*) "m",m," k",k," l",l," ffthet",&
6414                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6415                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6416                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6417                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6418                   " ethetai",ethetai
6419               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6420                   cosph1ph2(k,l)*sinkt(m),&
6421                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6422               endif
6423             enddo
6424           enddo
6425         enddo
6426 10      continue
6427 !        lprn1=.true.
6428         if (lprn1) &
6429           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6430          i,theta(i)*rad2deg,phii*rad2deg,&
6431          phii1*rad2deg,ethetai
6432 !        lprn1=.false.
6433         etheta=etheta+ethetai
6434         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6435                                     'ebend',i,ethetai
6436         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6437         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6438         gloc(nphi+i-2,icg)=wang*dethetai
6439       enddo
6440 !-----------thete constrains
6441 !      if (tor_mode.ne.2) then
6442
6443       return
6444       end subroutine ebend
6445 #endif
6446 #ifdef CRYST_SC
6447 !-----------------------------------------------------------------------------
6448       subroutine esc(escloc)
6449 ! Calculate the local energy of a side chain and its derivatives in the
6450 ! corresponding virtual-bond valence angles THETA and the spherical angles
6451 ! ALPHA and OMEGA.
6452 !
6453       use comm_sccalc
6454 !      implicit real*8 (a-h,o-z)
6455 !      include 'DIMENSIONS'
6456 !      include 'COMMON.GEO'
6457 !      include 'COMMON.LOCAL'
6458 !      include 'COMMON.VAR'
6459 !      include 'COMMON.INTERACT'
6460 !      include 'COMMON.DERIV'
6461 !      include 'COMMON.CHAIN'
6462 !      include 'COMMON.IOUNITS'
6463 !      include 'COMMON.NAMES'
6464 !      include 'COMMON.FFIELD'
6465 !      include 'COMMON.CONTROL'
6466       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6467          ddersc0,ddummy,xtemp,temp
6468 !el      real(kind=8) :: time11,time12,time112,theti
6469       real(kind=8) :: escloc,delta
6470 !el      integer :: it,nlobit
6471 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6472 !el local variables
6473       integer :: i,k
6474       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6475        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6476       delta=0.02d0*pi
6477       escloc=0.0D0
6478 !     write (iout,'(a)') 'ESC'
6479       do i=loc_start,loc_end
6480         it=itype(i,1)
6481         if (it.eq.ntyp1) cycle
6482         if (it.eq.10) goto 1
6483         nlobit=nlob(iabs(it))
6484 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6485 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6486         theti=theta(i+1)-pipol
6487         x(1)=dtan(theti)
6488         x(2)=alph(i)
6489         x(3)=omeg(i)
6490
6491         if (x(2).gt.pi-delta) then
6492           xtemp(1)=x(1)
6493           xtemp(2)=pi-delta
6494           xtemp(3)=x(3)
6495           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6496           xtemp(2)=pi
6497           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6498           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6499               escloci,dersc(2))
6500           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6501               ddersc0(1),dersc(1))
6502           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6503               ddersc0(3),dersc(3))
6504           xtemp(2)=pi-delta
6505           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6506           xtemp(2)=pi
6507           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6508           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6509                   dersc0(2),esclocbi,dersc02)
6510           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6511                   dersc12,dersc01)
6512           call splinthet(x(2),0.5d0*delta,ss,ssd)
6513           dersc0(1)=dersc01
6514           dersc0(2)=dersc02
6515           dersc0(3)=0.0d0
6516           do k=1,3
6517             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6518           enddo
6519           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6520 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6521 !    &             esclocbi,ss,ssd
6522           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6523 !         escloci=esclocbi
6524 !         write (iout,*) escloci
6525         else if (x(2).lt.delta) then
6526           xtemp(1)=x(1)
6527           xtemp(2)=delta
6528           xtemp(3)=x(3)
6529           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6530           xtemp(2)=0.0d0
6531           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6532           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6533               escloci,dersc(2))
6534           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6535               ddersc0(1),dersc(1))
6536           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6537               ddersc0(3),dersc(3))
6538           xtemp(2)=delta
6539           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6540           xtemp(2)=0.0d0
6541           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6542           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6543                   dersc0(2),esclocbi,dersc02)
6544           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6545                   dersc12,dersc01)
6546           dersc0(1)=dersc01
6547           dersc0(2)=dersc02
6548           dersc0(3)=0.0d0
6549           call splinthet(x(2),0.5d0*delta,ss,ssd)
6550           do k=1,3
6551             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6552           enddo
6553           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6554 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6555 !    &             esclocbi,ss,ssd
6556           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6557 !         write (iout,*) escloci
6558         else
6559           call enesc(x,escloci,dersc,ddummy,.false.)
6560         endif
6561
6562         escloc=escloc+escloci
6563         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6564            'escloc',i,escloci
6565 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6566
6567         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6568          wscloc*dersc(1)
6569         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6570         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6571     1   continue
6572       enddo
6573       return
6574       end subroutine esc
6575 !-----------------------------------------------------------------------------
6576       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6577
6578       use comm_sccalc
6579 !      implicit real*8 (a-h,o-z)
6580 !      include 'DIMENSIONS'
6581 !      include 'COMMON.GEO'
6582 !      include 'COMMON.LOCAL'
6583 !      include 'COMMON.IOUNITS'
6584 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6585       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6586       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6587       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6588       real(kind=8) :: escloci
6589       logical :: mixed
6590 !el local variables
6591       integer :: j,iii,l,k !el,it,nlobit
6592       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6593 !el       time11,time12,time112
6594 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6595         escloc_i=0.0D0
6596         do j=1,3
6597           dersc(j)=0.0D0
6598           if (mixed) ddersc(j)=0.0d0
6599         enddo
6600         x3=x(3)
6601
6602 ! Because of periodicity of the dependence of the SC energy in omega we have
6603 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6604 ! To avoid underflows, first compute & store the exponents.
6605
6606         do iii=-1,1
6607
6608           x(3)=x3+iii*dwapi
6609
6610           do j=1,nlobit
6611             do k=1,3
6612               z(k)=x(k)-censc(k,j,it)
6613             enddo
6614             do k=1,3
6615               Axk=0.0D0
6616               do l=1,3
6617                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6618               enddo
6619               Ax(k,j,iii)=Axk
6620             enddo
6621             expfac=0.0D0
6622             do k=1,3
6623               expfac=expfac+Ax(k,j,iii)*z(k)
6624             enddo
6625             contr(j,iii)=expfac
6626           enddo ! j
6627
6628         enddo ! iii
6629
6630         x(3)=x3
6631 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6632 ! subsequent NaNs and INFs in energy calculation.
6633 ! Find the largest exponent
6634         emin=contr(1,-1)
6635         do iii=-1,1
6636           do j=1,nlobit
6637             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6638           enddo
6639         enddo
6640         emin=0.5D0*emin
6641 !d      print *,'it=',it,' emin=',emin
6642
6643 ! Compute the contribution to SC energy and derivatives
6644         do iii=-1,1
6645
6646           do j=1,nlobit
6647 #ifdef OSF
6648             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6649             if(adexp.ne.adexp) adexp=1.0
6650             expfac=dexp(adexp)
6651 #else
6652             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6653 #endif
6654 !d          print *,'j=',j,' expfac=',expfac
6655             escloc_i=escloc_i+expfac
6656             do k=1,3
6657               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6658             enddo
6659             if (mixed) then
6660               do k=1,3,2
6661                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6662                   +gaussc(k,2,j,it))*expfac
6663               enddo
6664             endif
6665           enddo
6666
6667         enddo ! iii
6668
6669         dersc(1)=dersc(1)/cos(theti)**2
6670         ddersc(1)=ddersc(1)/cos(theti)**2
6671         ddersc(3)=ddersc(3)
6672
6673         escloci=-(dlog(escloc_i)-emin)
6674         do j=1,3
6675           dersc(j)=dersc(j)/escloc_i
6676         enddo
6677         if (mixed) then
6678           do j=1,3,2
6679             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6680           enddo
6681         endif
6682       return
6683       end subroutine enesc
6684 !-----------------------------------------------------------------------------
6685       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6686
6687       use comm_sccalc
6688 !      implicit real*8 (a-h,o-z)
6689 !      include 'DIMENSIONS'
6690 !      include 'COMMON.GEO'
6691 !      include 'COMMON.LOCAL'
6692 !      include 'COMMON.IOUNITS'
6693 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6694       real(kind=8),dimension(3) :: x,z,dersc
6695       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6696       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6697       real(kind=8) :: escloci,dersc12,emin
6698       logical :: mixed
6699 !el local varables
6700       integer :: j,k,l !el,it,nlobit
6701       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6702
6703       escloc_i=0.0D0
6704
6705       do j=1,3
6706         dersc(j)=0.0D0
6707       enddo
6708
6709       do j=1,nlobit
6710         do k=1,2
6711           z(k)=x(k)-censc(k,j,it)
6712         enddo
6713         z(3)=dwapi
6714         do k=1,3
6715           Axk=0.0D0
6716           do l=1,3
6717             Axk=Axk+gaussc(l,k,j,it)*z(l)
6718           enddo
6719           Ax(k,j)=Axk
6720         enddo
6721         expfac=0.0D0
6722         do k=1,3
6723           expfac=expfac+Ax(k,j)*z(k)
6724         enddo
6725         contr(j)=expfac
6726       enddo ! j
6727
6728 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6729 ! subsequent NaNs and INFs in energy calculation.
6730 ! Find the largest exponent
6731       emin=contr(1)
6732       do j=1,nlobit
6733         if (emin.gt.contr(j)) emin=contr(j)
6734       enddo
6735       emin=0.5D0*emin
6736
6737 ! Compute the contribution to SC energy and derivatives
6738
6739       dersc12=0.0d0
6740       do j=1,nlobit
6741         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6742         escloc_i=escloc_i+expfac
6743         do k=1,2
6744           dersc(k)=dersc(k)+Ax(k,j)*expfac
6745         enddo
6746         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6747                   +gaussc(1,2,j,it))*expfac
6748         dersc(3)=0.0d0
6749       enddo
6750
6751       dersc(1)=dersc(1)/cos(theti)**2
6752       dersc12=dersc12/cos(theti)**2
6753       escloci=-(dlog(escloc_i)-emin)
6754       do j=1,2
6755         dersc(j)=dersc(j)/escloc_i
6756       enddo
6757       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6758       return
6759       end subroutine enesc_bound
6760 #else
6761 !-----------------------------------------------------------------------------
6762       subroutine esc(escloc)
6763 ! Calculate the local energy of a side chain and its derivatives in the
6764 ! corresponding virtual-bond valence angles THETA and the spherical angles
6765 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6766 ! added by Urszula Kozlowska. 07/11/2007
6767 !
6768       use comm_sccalc
6769 !      implicit real*8 (a-h,o-z)
6770 !      include 'DIMENSIONS'
6771 !      include 'COMMON.GEO'
6772 !      include 'COMMON.LOCAL'
6773 !      include 'COMMON.VAR'
6774 !      include 'COMMON.SCROT'
6775 !      include 'COMMON.INTERACT'
6776 !      include 'COMMON.DERIV'
6777 !      include 'COMMON.CHAIN'
6778 !      include 'COMMON.IOUNITS'
6779 !      include 'COMMON.NAMES'
6780 !      include 'COMMON.FFIELD'
6781 !      include 'COMMON.CONTROL'
6782 !      include 'COMMON.VECTORS'
6783       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6784       real(kind=8),dimension(65) :: x
6785       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6786          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6787       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6788       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6789          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6790 !el local variables
6791       integer :: i,j,k !el,it,nlobit
6792       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6793 !el      real(kind=8) :: time11,time12,time112,theti
6794 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6795       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6796                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6797                    sumene1x,sumene2x,sumene3x,sumene4x,&
6798                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6799                    cosfac2xx,sinfac2yy
6800 #ifdef DEBUG
6801       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6802                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6803                    de_dt_num
6804 #endif
6805 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6806
6807       delta=0.02d0*pi
6808       escloc=0.0D0
6809       do i=loc_start,loc_end
6810         if (itype(i,1).eq.ntyp1) cycle
6811         costtab(i+1) =dcos(theta(i+1))
6812         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6813         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6814         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6815         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6816         cosfac=dsqrt(cosfac2)
6817         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6818         sinfac=dsqrt(sinfac2)
6819         it=iabs(itype(i,1))
6820         if (it.eq.10) goto 1
6821 !
6822 !  Compute the axes of tghe local cartesian coordinates system; store in
6823 !   x_prime, y_prime and z_prime
6824 !
6825         do j=1,3
6826           x_prime(j) = 0.00
6827           y_prime(j) = 0.00
6828           z_prime(j) = 0.00
6829         enddo
6830 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6831 !     &   dc_norm(3,i+nres)
6832         do j = 1,3
6833           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6834           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6835         enddo
6836         do j = 1,3
6837           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6838         enddo
6839 !       write (2,*) "i",i
6840 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6841 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6842 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6843 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6844 !      & " xy",scalar(x_prime(1),y_prime(1)),
6845 !      & " xz",scalar(x_prime(1),z_prime(1)),
6846 !      & " yy",scalar(y_prime(1),y_prime(1)),
6847 !      & " yz",scalar(y_prime(1),z_prime(1)),
6848 !      & " zz",scalar(z_prime(1),z_prime(1))
6849 !
6850 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6851 ! to local coordinate system. Store in xx, yy, zz.
6852 !
6853         xx=0.0d0
6854         yy=0.0d0
6855         zz=0.0d0
6856         do j = 1,3
6857           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6858           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6859           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6860         enddo
6861
6862         xxtab(i)=xx
6863         yytab(i)=yy
6864         zztab(i)=zz
6865 !
6866 ! Compute the energy of the ith side cbain
6867 !
6868 !        write (2,*) "xx",xx," yy",yy," zz",zz
6869         it=iabs(itype(i,1))
6870         do j = 1,65
6871           x(j) = sc_parmin(j,it)
6872         enddo
6873 #ifdef CHECK_COORD
6874 !c diagnostics - remove later
6875         xx1 = dcos(alph(2))
6876         yy1 = dsin(alph(2))*dcos(omeg(2))
6877         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6878         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6879           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6880           xx1,yy1,zz1
6881 !,"  --- ", xx_w,yy_w,zz_w
6882 ! end diagnostics
6883 #endif
6884         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6885          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6886          + x(10)*yy*zz
6887         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6888          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6889          + x(20)*yy*zz
6890         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6891          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6892          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6893          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6894          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6895          +x(40)*xx*yy*zz
6896         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6897          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6898          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6899          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6900          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6901          +x(60)*xx*yy*zz
6902         dsc_i   = 0.743d0+x(61)
6903         dp2_i   = 1.9d0+x(62)
6904         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6905                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6906         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6907                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6908         s1=(1+x(63))/(0.1d0 + dscp1)
6909         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6910         s2=(1+x(65))/(0.1d0 + dscp2)
6911         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6912         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6913       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6914 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6915 !     &   sumene4,
6916 !     &   dscp1,dscp2,sumene
6917 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6918         escloc = escloc + sumene
6919 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6920 !     & ,zz,xx,yy
6921 !#define DEBUG
6922 #ifdef DEBUG
6923 !
6924 ! This section to check the numerical derivatives of the energy of ith side
6925 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6926 ! #define DEBUG in the code to turn it on.
6927 !
6928         write (2,*) "sumene               =",sumene
6929         aincr=1.0d-7
6930         xxsave=xx
6931         xx=xx+aincr
6932         write (2,*) xx,yy,zz
6933         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6934         de_dxx_num=(sumenep-sumene)/aincr
6935         xx=xxsave
6936         write (2,*) "xx+ sumene from enesc=",sumenep
6937         yysave=yy
6938         yy=yy+aincr
6939         write (2,*) xx,yy,zz
6940         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6941         de_dyy_num=(sumenep-sumene)/aincr
6942         yy=yysave
6943         write (2,*) "yy+ sumene from enesc=",sumenep
6944         zzsave=zz
6945         zz=zz+aincr
6946         write (2,*) xx,yy,zz
6947         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6948         de_dzz_num=(sumenep-sumene)/aincr
6949         zz=zzsave
6950         write (2,*) "zz+ sumene from enesc=",sumenep
6951         costsave=cost2tab(i+1)
6952         sintsave=sint2tab(i+1)
6953         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6954         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6955         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6956         de_dt_num=(sumenep-sumene)/aincr
6957         write (2,*) " t+ sumene from enesc=",sumenep
6958         cost2tab(i+1)=costsave
6959         sint2tab(i+1)=sintsave
6960 ! End of diagnostics section.
6961 #endif
6962 !
6963 ! Compute the gradient of esc
6964 !
6965 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6966         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6967         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6968         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6969         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6970         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6971         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6972         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6973         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6974         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6975            *(pom_s1/dscp1+pom_s16*dscp1**4)
6976         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6977            *(pom_s2/dscp2+pom_s26*dscp2**4)
6978         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6979         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6980         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6981         +x(40)*yy*zz
6982         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6983         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6984         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6985         +x(60)*yy*zz
6986         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6987               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6988               +(pom1+pom2)*pom_dx
6989 #ifdef DEBUG
6990         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6991 #endif
6992 !
6993         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6994         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6995         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6996         +x(40)*xx*zz
6997         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6998         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6999         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7000         +x(59)*zz**2 +x(60)*xx*zz
7001         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7002               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7003               +(pom1-pom2)*pom_dy
7004 #ifdef DEBUG
7005         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7006 #endif
7007 !
7008         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7009         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7010         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7011         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7012         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7013         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7014         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7015         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7016 #ifdef DEBUG
7017         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7018 #endif
7019 !
7020         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7021         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7022         +pom1*pom_dt1+pom2*pom_dt2
7023 #ifdef DEBUG
7024         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7025 #endif
7026 !
7027 !
7028        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7029        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7030        cosfac2xx=cosfac2*xx
7031        sinfac2yy=sinfac2*yy
7032        do k = 1,3
7033          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7034             vbld_inv(i+1)
7035          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7036             vbld_inv(i)
7037          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7038          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7039 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7040 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7041 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7042 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7043          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7044          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7045          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7046          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7047          dZZ_Ci1(k)=0.0d0
7048          dZZ_Ci(k)=0.0d0
7049          do j=1,3
7050            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7051            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7052            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7053            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7054          enddo
7055
7056          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7057          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7058          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7059          (z_prime(k)-zz*dC_norm(k,i+nres))
7060 !
7061          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7062          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7063        enddo
7064
7065        do k=1,3
7066          dXX_Ctab(k,i)=dXX_Ci(k)
7067          dXX_C1tab(k,i)=dXX_Ci1(k)
7068          dYY_Ctab(k,i)=dYY_Ci(k)
7069          dYY_C1tab(k,i)=dYY_Ci1(k)
7070          dZZ_Ctab(k,i)=dZZ_Ci(k)
7071          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7072          dXX_XYZtab(k,i)=dXX_XYZ(k)
7073          dYY_XYZtab(k,i)=dYY_XYZ(k)
7074          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7075        enddo
7076
7077        do k = 1,3
7078 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7079 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7080 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7081 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7082 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7083 !     &    dt_dci(k)
7084 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7085 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7086          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7087           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7088          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7089           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7090          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7091           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7092        enddo
7093 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7094 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7095
7096 ! to check gradient call subroutine check_grad
7097
7098     1 continue
7099       enddo
7100       return
7101       end subroutine esc
7102 !-----------------------------------------------------------------------------
7103       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7104 !      implicit none
7105       real(kind=8),dimension(65) :: x
7106       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7107         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7108
7109       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7110         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7111         + x(10)*yy*zz
7112       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7113         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7114         + x(20)*yy*zz
7115       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7116         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7117         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7118         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7119         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7120         +x(40)*xx*yy*zz
7121       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7122         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7123         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7124         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7125         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7126         +x(60)*xx*yy*zz
7127       dsc_i   = 0.743d0+x(61)
7128       dp2_i   = 1.9d0+x(62)
7129       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7130                 *(xx*cost2+yy*sint2))
7131       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7132                 *(xx*cost2-yy*sint2))
7133       s1=(1+x(63))/(0.1d0 + dscp1)
7134       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7135       s2=(1+x(65))/(0.1d0 + dscp2)
7136       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7137       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7138        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7139       enesc=sumene
7140       return
7141       end function enesc
7142 #endif
7143 !-----------------------------------------------------------------------------
7144       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7145 !
7146 ! This procedure calculates two-body contact function g(rij) and its derivative:
7147 !
7148 !           eps0ij                                     !       x < -1
7149 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7150 !            0                                         !       x > 1
7151 !
7152 ! where x=(rij-r0ij)/delta
7153 !
7154 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7155 !
7156 !      implicit none
7157       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7158       real(kind=8) :: x,x2,x4,delta
7159 !     delta=0.02D0*r0ij
7160 !      delta=0.2D0*r0ij
7161       x=(rij-r0ij)/delta
7162       if (x.lt.-1.0D0) then
7163         fcont=eps0ij
7164         fprimcont=0.0D0
7165       else if (x.le.1.0D0) then
7166         x2=x*x
7167         x4=x2*x2
7168         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7169         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7170       else
7171         fcont=0.0D0
7172         fprimcont=0.0D0
7173       endif
7174       return
7175       end subroutine gcont
7176 !-----------------------------------------------------------------------------
7177       subroutine splinthet(theti,delta,ss,ssder)
7178 !      implicit real*8 (a-h,o-z)
7179 !      include 'DIMENSIONS'
7180 !      include 'COMMON.VAR'
7181 !      include 'COMMON.GEO'
7182       real(kind=8) :: theti,delta,ss,ssder
7183       real(kind=8) :: thetup,thetlow
7184       thetup=pi-delta
7185       thetlow=delta
7186       if (theti.gt.pipol) then
7187         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7188       else
7189         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7190         ssder=-ssder
7191       endif
7192       return
7193       end subroutine splinthet
7194 !-----------------------------------------------------------------------------
7195       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7196 !      implicit none
7197       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7198       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7199       a1=fprim0*delta/(f1-f0)
7200       a2=3.0d0-2.0d0*a1
7201       a3=a1-2.0d0
7202       ksi=(x-x0)/delta
7203       ksi2=ksi*ksi
7204       ksi3=ksi2*ksi
7205       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7206       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7207       return
7208       end subroutine spline1
7209 !-----------------------------------------------------------------------------
7210       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7211 !      implicit none
7212       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7213       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7214       ksi=(x-x0)/delta
7215       ksi2=ksi*ksi
7216       ksi3=ksi2*ksi
7217       a1=fprim0x*delta
7218       a2=3*(f1x-f0x)-2*fprim0x*delta
7219       a3=fprim0x*delta-2*(f1x-f0x)
7220       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7221       return
7222       end subroutine spline2
7223 !-----------------------------------------------------------------------------
7224 #ifdef CRYST_TOR
7225 !-----------------------------------------------------------------------------
7226       subroutine etor(etors,edihcnstr)
7227 !      implicit real*8 (a-h,o-z)
7228 !      include 'DIMENSIONS'
7229 !      include 'COMMON.VAR'
7230 !      include 'COMMON.GEO'
7231 !      include 'COMMON.LOCAL'
7232 !      include 'COMMON.TORSION'
7233 !      include 'COMMON.INTERACT'
7234 !      include 'COMMON.DERIV'
7235 !      include 'COMMON.CHAIN'
7236 !      include 'COMMON.NAMES'
7237 !      include 'COMMON.IOUNITS'
7238 !      include 'COMMON.FFIELD'
7239 !      include 'COMMON.TORCNSTR'
7240 !      include 'COMMON.CONTROL'
7241       real(kind=8) :: etors,edihcnstr
7242       logical :: lprn
7243 !el local variables
7244       integer :: i,j,
7245       real(kind=8) :: phii,fac,etors_ii
7246
7247 ! Set lprn=.true. for debugging
7248       lprn=.false.
7249 !      lprn=.true.
7250       etors=0.0D0
7251       do i=iphi_start,iphi_end
7252       etors_ii=0.0D0
7253         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7254             .or. itype(i,1).eq.ntyp1) cycle
7255         itori=itortyp(itype(i-2,1))
7256         itori1=itortyp(itype(i-1,1))
7257         phii=phi(i)
7258         gloci=0.0D0
7259 ! Proline-Proline pair is a special case...
7260         if (itori.eq.3 .and. itori1.eq.3) then
7261           if (phii.gt.-dwapi3) then
7262             cosphi=dcos(3*phii)
7263             fac=1.0D0/(1.0D0-cosphi)
7264             etorsi=v1(1,3,3)*fac
7265             etorsi=etorsi+etorsi
7266             etors=etors+etorsi-v1(1,3,3)
7267             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7268             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7269           endif
7270           do j=1,3
7271             v1ij=v1(j+1,itori,itori1)
7272             v2ij=v2(j+1,itori,itori1)
7273             cosphi=dcos(j*phii)
7274             sinphi=dsin(j*phii)
7275             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7276             if (energy_dec) etors_ii=etors_ii+ &
7277                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7278             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7279           enddo
7280         else
7281           do j=1,nterm_old
7282             v1ij=v1(j,itori,itori1)
7283             v2ij=v2(j,itori,itori1)
7284             cosphi=dcos(j*phii)
7285             sinphi=dsin(j*phii)
7286             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7287             if (energy_dec) etors_ii=etors_ii+ &
7288                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7289             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7290           enddo
7291         endif
7292         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7293              'etor',i,etors_ii
7294         if (lprn) &
7295         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7296         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7297         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7298         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7299 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7300       enddo
7301 ! 6/20/98 - dihedral angle constraints
7302       edihcnstr=0.0d0
7303       do i=1,ndih_constr
7304         itori=idih_constr(i)
7305         phii=phi(itori)
7306         difi=phii-phi0(i)
7307         if (difi.gt.drange(i)) then
7308           difi=difi-drange(i)
7309           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7310           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7311         else if (difi.lt.-drange(i)) then
7312           difi=difi+drange(i)
7313           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7314           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7315         endif
7316 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7317 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7318       enddo
7319 !      write (iout,*) 'edihcnstr',edihcnstr
7320       return
7321       end subroutine etor
7322 !-----------------------------------------------------------------------------
7323       subroutine etor_d(etors_d)
7324       real(kind=8) :: etors_d
7325       etors_d=0.0d0
7326       return
7327       end subroutine etor_d
7328 #else
7329 !-----------------------------------------------------------------------------
7330       subroutine etor(etors)
7331 !      implicit real*8 (a-h,o-z)
7332 !      include 'DIMENSIONS'
7333 !      include 'COMMON.VAR'
7334 !      include 'COMMON.GEO'
7335 !      include 'COMMON.LOCAL'
7336 !      include 'COMMON.TORSION'
7337 !      include 'COMMON.INTERACT'
7338 !      include 'COMMON.DERIV'
7339 !      include 'COMMON.CHAIN'
7340 !      include 'COMMON.NAMES'
7341 !      include 'COMMON.IOUNITS'
7342 !      include 'COMMON.FFIELD'
7343 !      include 'COMMON.TORCNSTR'
7344 !      include 'COMMON.CONTROL'
7345       real(kind=8) :: etors,edihcnstr
7346       logical :: lprn
7347 !el local variables
7348       integer :: i,j,iblock,itori,itori1
7349       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7350                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7351 ! Set lprn=.true. for debugging
7352       lprn=.false.
7353 !     lprn=.true.
7354       etors=0.0D0
7355       do i=iphi_start,iphi_end
7356         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7357              .or. itype(i-3,1).eq.ntyp1 &
7358              .or. itype(i,1).eq.ntyp1) cycle
7359         etors_ii=0.0D0
7360          if (iabs(itype(i,1)).eq.20) then
7361          iblock=2
7362          else
7363          iblock=1
7364          endif
7365         itori=itortyp(itype(i-2,1))
7366         itori1=itortyp(itype(i-1,1))
7367         phii=phi(i)
7368         gloci=0.0D0
7369 ! Regular cosine and sine terms
7370         do j=1,nterm(itori,itori1,iblock)
7371           v1ij=v1(j,itori,itori1,iblock)
7372           v2ij=v2(j,itori,itori1,iblock)
7373           cosphi=dcos(j*phii)
7374           sinphi=dsin(j*phii)
7375           etors=etors+v1ij*cosphi+v2ij*sinphi
7376           if (energy_dec) etors_ii=etors_ii+ &
7377                      v1ij*cosphi+v2ij*sinphi
7378           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7379         enddo
7380 ! Lorentz terms
7381 !                         v1
7382 !  E = SUM ----------------------------------- - v1
7383 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7384 !
7385         cosphi=dcos(0.5d0*phii)
7386         sinphi=dsin(0.5d0*phii)
7387         do j=1,nlor(itori,itori1,iblock)
7388           vl1ij=vlor1(j,itori,itori1)
7389           vl2ij=vlor2(j,itori,itori1)
7390           vl3ij=vlor3(j,itori,itori1)
7391           pom=vl2ij*cosphi+vl3ij*sinphi
7392           pom1=1.0d0/(pom*pom+1.0d0)
7393           etors=etors+vl1ij*pom1
7394           if (energy_dec) etors_ii=etors_ii+ &
7395                      vl1ij*pom1
7396           pom=-pom*pom1*pom1
7397           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7398         enddo
7399 ! Subtract the constant term
7400         etors=etors-v0(itori,itori1,iblock)
7401           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7402                'etor',i,etors_ii-v0(itori,itori1,iblock)
7403         if (lprn) &
7404         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7405         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7406         (v1(j,itori,itori1,iblock),j=1,6),&
7407         (v2(j,itori,itori1,iblock),j=1,6)
7408         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7409 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7410       enddo
7411 ! 6/20/98 - dihedral angle constraints
7412       return
7413       end subroutine etor
7414 !C The rigorous attempt to derive energy function
7415 !-------------------------------------------------------------------------------------------
7416       subroutine etor_kcc(etors)
7417       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7418       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7419        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7420        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7421        gradvalst2,etori
7422       logical lprn
7423       integer :: i,j,itori,itori1,nval,k,l
7424
7425       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7426       etors=0.0D0
7427       do i=iphi_start,iphi_end
7428 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7429 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7430 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7431 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7432         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7433            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7434         itori=itortyp(itype(i-2,1))
7435         itori1=itortyp(itype(i-1,1))
7436         phii=phi(i)
7437         glocig=0.0D0
7438         glocit1=0.0d0
7439         glocit2=0.0d0
7440 !C to avoid multiple devision by 2
7441 !c        theti22=0.5d0*theta(i)
7442 !C theta 12 is the theta_1 /2
7443 !C theta 22 is theta_2 /2
7444 !c        theti12=0.5d0*theta(i-1)
7445 !C and appropriate sinus function
7446         sinthet1=dsin(theta(i-1))
7447         sinthet2=dsin(theta(i))
7448         costhet1=dcos(theta(i-1))
7449         costhet2=dcos(theta(i))
7450 !C to speed up lets store its mutliplication
7451         sint1t2=sinthet2*sinthet1
7452         sint1t2n=1.0d0
7453 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7454 !C +d_n*sin(n*gamma)) *
7455 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7456 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7457         nval=nterm_kcc_Tb(itori,itori1)
7458         c1(0)=0.0d0
7459         c2(0)=0.0d0
7460         c1(1)=1.0d0
7461         c2(1)=1.0d0
7462         do j=2,nval
7463           c1(j)=c1(j-1)*costhet1
7464           c2(j)=c2(j-1)*costhet2
7465         enddo
7466         etori=0.0d0
7467
7468        do j=1,nterm_kcc(itori,itori1)
7469           cosphi=dcos(j*phii)
7470           sinphi=dsin(j*phii)
7471           sint1t2n1=sint1t2n
7472           sint1t2n=sint1t2n*sint1t2
7473           sumvalc=0.0d0
7474           gradvalct1=0.0d0
7475           gradvalct2=0.0d0
7476           do k=1,nval
7477             do l=1,nval
7478               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7479               gradvalct1=gradvalct1+ &
7480                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7481               gradvalct2=gradvalct2+ &
7482                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7483             enddo
7484           enddo
7485           gradvalct1=-gradvalct1*sinthet1
7486           gradvalct2=-gradvalct2*sinthet2
7487           sumvals=0.0d0
7488           gradvalst1=0.0d0
7489           gradvalst2=0.0d0
7490           do k=1,nval
7491             do l=1,nval
7492               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7493               gradvalst1=gradvalst1+ &
7494                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7495               gradvalst2=gradvalst2+ &
7496                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7497             enddo
7498           enddo
7499           gradvalst1=-gradvalst1*sinthet1
7500           gradvalst2=-gradvalst2*sinthet2
7501           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7502           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7503 !C glocig is the gradient local i site in gamma
7504           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7505 !C now gradient over theta_1
7506          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7507         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7508          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7509         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7510         enddo ! j
7511         etors=etors+etori
7512         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7513 !C derivative over theta1
7514         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7515 !C now derivative over theta2
7516         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7517         if (lprn) then
7518          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7519             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7520           write (iout,*) "c1",(c1(k),k=0,nval), &
7521          " c2",(c2(k),k=0,nval)
7522         endif
7523       enddo
7524       return
7525        end  subroutine etor_kcc
7526 !------------------------------------------------------------------------------
7527
7528         subroutine etor_constr(edihcnstr)
7529       real(kind=8) :: etors,edihcnstr
7530       logical :: lprn
7531 !el local variables
7532       integer :: i,j,iblock,itori,itori1
7533       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7534                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7535                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7536
7537       if (raw_psipred) then
7538         do i=idihconstr_start,idihconstr_end
7539           itori=idih_constr(i)
7540           phii=phi(itori)
7541           gaudih_i=vpsipred(1,i)
7542           gauder_i=0.0d0
7543           do j=1,2
7544             s = sdihed(j,i)
7545             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7546             dexpcos_i=dexp(-cos_i*cos_i)
7547             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7548           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7549                  *cos_i*dexpcos_i/s**2
7550           enddo
7551           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7552           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7553           if (energy_dec) &
7554           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7555           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7556           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7557           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7558           -wdihc*dlog(gaudih_i)
7559         enddo
7560       else
7561
7562       do i=idihconstr_start,idihconstr_end
7563         itori=idih_constr(i)
7564         phii=phi(itori)
7565         difi=pinorm(phii-phi0(i))
7566         if (difi.gt.drange(i)) then
7567           difi=difi-drange(i)
7568           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7569           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7570         else if (difi.lt.-drange(i)) then
7571           difi=difi+drange(i)
7572           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7573           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7574         else
7575           difi=0.0
7576         endif
7577       enddo
7578
7579       endif
7580
7581       return
7582
7583       end subroutine etor_constr
7584 !-----------------------------------------------------------------------------
7585       subroutine etor_d(etors_d)
7586 ! 6/23/01 Compute double torsional energy
7587 !      implicit real*8 (a-h,o-z)
7588 !      include 'DIMENSIONS'
7589 !      include 'COMMON.VAR'
7590 !      include 'COMMON.GEO'
7591 !      include 'COMMON.LOCAL'
7592 !      include 'COMMON.TORSION'
7593 !      include 'COMMON.INTERACT'
7594 !      include 'COMMON.DERIV'
7595 !      include 'COMMON.CHAIN'
7596 !      include 'COMMON.NAMES'
7597 !      include 'COMMON.IOUNITS'
7598 !      include 'COMMON.FFIELD'
7599 !      include 'COMMON.TORCNSTR'
7600       real(kind=8) :: etors_d,etors_d_ii
7601       logical :: lprn
7602 !el local variables
7603       integer :: i,j,k,l,itori,itori1,itori2,iblock
7604       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7605                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7606                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7607                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7608 ! Set lprn=.true. for debugging
7609       lprn=.false.
7610 !     lprn=.true.
7611       etors_d=0.0D0
7612 !      write(iout,*) "a tu??"
7613       do i=iphid_start,iphid_end
7614         etors_d_ii=0.0D0
7615         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7616             .or. itype(i-3,1).eq.ntyp1 &
7617             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7618         itori=itortyp(itype(i-2,1))
7619         itori1=itortyp(itype(i-1,1))
7620         itori2=itortyp(itype(i,1))
7621         phii=phi(i)
7622         phii1=phi(i+1)
7623         gloci1=0.0D0
7624         gloci2=0.0D0
7625         iblock=1
7626         if (iabs(itype(i+1,1)).eq.20) iblock=2
7627
7628 ! Regular cosine and sine terms
7629         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7630           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7631           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7632           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7633           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7634           cosphi1=dcos(j*phii)
7635           sinphi1=dsin(j*phii)
7636           cosphi2=dcos(j*phii1)
7637           sinphi2=dsin(j*phii1)
7638           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7639            v2cij*cosphi2+v2sij*sinphi2
7640           if (energy_dec) etors_d_ii=etors_d_ii+ &
7641            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7642           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7643           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7644         enddo
7645         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7646           do l=1,k-1
7647             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7648             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7649             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7650             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7651             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7652             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7653             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7654             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7655             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7656               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7657             if (energy_dec) etors_d_ii=etors_d_ii+ &
7658               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7659               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7660             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7661               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7662             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7663               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7664           enddo
7665         enddo
7666         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7667                             'etor_d',i,etors_d_ii
7668         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7669         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7670       enddo
7671       return
7672       end subroutine etor_d
7673 #endif
7674
7675       subroutine ebend_kcc(etheta)
7676       logical lprn
7677       double precision thybt1(maxang_kcc),etheta
7678       integer :: i,iti,j,ihelp
7679       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7680 !C Set lprn=.true. for debugging
7681       lprn=energy_dec
7682 !c     lprn=.true.
7683 !C      print *,"wchodze kcc"
7684       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7685       etheta=0.0D0
7686       do i=ithet_start,ithet_end
7687 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7688         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7689        .or.itype(i,1).eq.ntyp1) cycle
7690         iti=iabs(itortyp(itype(i-1,1)))
7691         sinthet=dsin(theta(i))
7692         costhet=dcos(theta(i))
7693         do j=1,nbend_kcc_Tb(iti)
7694           thybt1(j)=v1bend_chyb(j,iti)
7695         enddo
7696         sumth1thyb=v1bend_chyb(0,iti)+ &
7697          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7698         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7699          sumth1thyb
7700         ihelp=nbend_kcc_Tb(iti)-1
7701         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7702         etheta=etheta+sumth1thyb
7703 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7704         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7705       enddo
7706       return
7707       end subroutine ebend_kcc
7708 !c------------
7709 !c-------------------------------------------------------------------------------------
7710       subroutine etheta_constr(ethetacnstr)
7711       real (kind=8) :: ethetacnstr,thetiii,difi
7712       integer :: i,itheta
7713       ethetacnstr=0.0d0
7714 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7715       do i=ithetaconstr_start,ithetaconstr_end
7716         itheta=itheta_constr(i)
7717         thetiii=theta(itheta)
7718         difi=pinorm(thetiii-theta_constr0(i))
7719         if (difi.gt.theta_drange(i)) then
7720           difi=difi-theta_drange(i)
7721           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7722           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7723          +for_thet_constr(i)*difi**3
7724         else if (difi.lt.-drange(i)) then
7725           difi=difi+drange(i)
7726           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7727           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7728           +for_thet_constr(i)*difi**3
7729         else
7730           difi=0.0
7731         endif
7732        if (energy_dec) then
7733         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7734          i,itheta,rad2deg*thetiii,&
7735          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7736          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7737          gloc(itheta+nphi-2,icg)
7738         endif
7739       enddo
7740       return
7741       end subroutine etheta_constr
7742
7743 !-----------------------------------------------------------------------------
7744       subroutine eback_sc_corr(esccor)
7745 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7746 !        conformational states; temporarily implemented as differences
7747 !        between UNRES torsional potentials (dependent on three types of
7748 !        residues) and the torsional potentials dependent on all 20 types
7749 !        of residues computed from AM1  energy surfaces of terminally-blocked
7750 !        amino-acid residues.
7751 !      implicit real*8 (a-h,o-z)
7752 !      include 'DIMENSIONS'
7753 !      include 'COMMON.VAR'
7754 !      include 'COMMON.GEO'
7755 !      include 'COMMON.LOCAL'
7756 !      include 'COMMON.TORSION'
7757 !      include 'COMMON.SCCOR'
7758 !      include 'COMMON.INTERACT'
7759 !      include 'COMMON.DERIV'
7760 !      include 'COMMON.CHAIN'
7761 !      include 'COMMON.NAMES'
7762 !      include 'COMMON.IOUNITS'
7763 !      include 'COMMON.FFIELD'
7764 !      include 'COMMON.CONTROL'
7765       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7766                    cosphi,sinphi
7767       logical :: lprn
7768       integer :: i,interty,j,isccori,isccori1,intertyp
7769 ! Set lprn=.true. for debugging
7770       lprn=.false.
7771 !      lprn=.true.
7772 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7773       esccor=0.0D0
7774       do i=itau_start,itau_end
7775         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7776         esccor_ii=0.0D0
7777         isccori=isccortyp(itype(i-2,1))
7778         isccori1=isccortyp(itype(i-1,1))
7779
7780 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7781         phii=phi(i)
7782         do intertyp=1,3 !intertyp
7783          esccor_ii=0.0D0
7784 !c Added 09 May 2012 (Adasko)
7785 !c  Intertyp means interaction type of backbone mainchain correlation:
7786 !   1 = SC...Ca...Ca...Ca
7787 !   2 = Ca...Ca...Ca...SC
7788 !   3 = SC...Ca...Ca...SCi
7789         gloci=0.0D0
7790         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7791             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7792             (itype(i-1,1).eq.ntyp1))) &
7793           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7794            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7795            .or.(itype(i,1).eq.ntyp1))) &
7796           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7797             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7798             (itype(i-3,1).eq.ntyp1)))) cycle
7799         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7800         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7801        cycle
7802        do j=1,nterm_sccor(isccori,isccori1)
7803           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7804           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7805           cosphi=dcos(j*tauangle(intertyp,i))
7806           sinphi=dsin(j*tauangle(intertyp,i))
7807           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7808           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7809           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7810         enddo
7811         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7812                                 'esccor',i,intertyp,esccor_ii
7813 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7814         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7815         if (lprn) &
7816         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7817         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7818         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7819         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7820         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7821        enddo !intertyp
7822       enddo
7823
7824       return
7825       end subroutine eback_sc_corr
7826 !-----------------------------------------------------------------------------
7827       subroutine multibody(ecorr)
7828 ! This subroutine calculates multi-body contributions to energy following
7829 ! the idea of Skolnick et al. If side chains I and J make a contact and
7830 ! at the same time side chains I+1 and J+1 make a contact, an extra
7831 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7832 !      implicit real*8 (a-h,o-z)
7833 !      include 'DIMENSIONS'
7834 !      include 'COMMON.IOUNITS'
7835 !      include 'COMMON.DERIV'
7836 !      include 'COMMON.INTERACT'
7837 !      include 'COMMON.CONTACTS'
7838       real(kind=8),dimension(3) :: gx,gx1
7839       logical :: lprn
7840       real(kind=8) :: ecorr
7841       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7842 ! Set lprn=.true. for debugging
7843       lprn=.false.
7844
7845       if (lprn) then
7846         write (iout,'(a)') 'Contact function values:'
7847         do i=nnt,nct-2
7848           write (iout,'(i2,20(1x,i2,f10.5))') &
7849               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7850         enddo
7851       endif
7852       ecorr=0.0D0
7853
7854 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7855 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7856       do i=nnt,nct
7857         do j=1,3
7858           gradcorr(j,i)=0.0D0
7859           gradxorr(j,i)=0.0D0
7860         enddo
7861       enddo
7862       do i=nnt,nct-2
7863
7864         DO ISHIFT = 3,4
7865
7866         i1=i+ishift
7867         num_conti=num_cont(i)
7868         num_conti1=num_cont(i1)
7869         do jj=1,num_conti
7870           j=jcont(jj,i)
7871           do kk=1,num_conti1
7872             j1=jcont(kk,i1)
7873             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7874 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7875 !d   &                   ' ishift=',ishift
7876 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7877 ! The system gains extra energy.
7878               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7879             endif   ! j1==j+-ishift
7880           enddo     ! kk
7881         enddo       ! jj
7882
7883         ENDDO ! ISHIFT
7884
7885       enddo         ! i
7886       return
7887       end subroutine multibody
7888 !-----------------------------------------------------------------------------
7889       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7890 !      implicit real*8 (a-h,o-z)
7891 !      include 'DIMENSIONS'
7892 !      include 'COMMON.IOUNITS'
7893 !      include 'COMMON.DERIV'
7894 !      include 'COMMON.INTERACT'
7895 !      include 'COMMON.CONTACTS'
7896       real(kind=8),dimension(3) :: gx,gx1
7897       logical :: lprn
7898       integer :: i,j,k,l,jj,kk,m,ll
7899       real(kind=8) :: eij,ekl
7900       lprn=.false.
7901       eij=facont(jj,i)
7902       ekl=facont(kk,k)
7903 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7904 ! Calculate the multi-body contribution to energy.
7905 ! Calculate multi-body contributions to the gradient.
7906 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7907 !d   & k,l,(gacont(m,kk,k),m=1,3)
7908       do m=1,3
7909         gx(m) =ekl*gacont(m,jj,i)
7910         gx1(m)=eij*gacont(m,kk,k)
7911         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7912         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7913         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7914         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7915       enddo
7916       do m=i,j-1
7917         do ll=1,3
7918           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7919         enddo
7920       enddo
7921       do m=k,l-1
7922         do ll=1,3
7923           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7924         enddo
7925       enddo
7926       esccorr=-eij*ekl
7927       return
7928       end function esccorr
7929 !-----------------------------------------------------------------------------
7930       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7931 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7932 !      implicit real*8 (a-h,o-z)
7933 !      include 'DIMENSIONS'
7934 !      include 'COMMON.IOUNITS'
7935 #ifdef MPI
7936       include "mpif.h"
7937 !      integer :: maxconts !max_cont=maxconts  =nres/4
7938       integer,parameter :: max_dim=26
7939       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7940       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7941 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7942 !el      common /przechowalnia/ zapas
7943       integer :: status(MPI_STATUS_SIZE)
7944       integer,dimension((nres/4)*2) :: req !maxconts*2
7945       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7946 #endif
7947 !      include 'COMMON.SETUP'
7948 !      include 'COMMON.FFIELD'
7949 !      include 'COMMON.DERIV'
7950 !      include 'COMMON.INTERACT'
7951 !      include 'COMMON.CONTACTS'
7952 !      include 'COMMON.CONTROL'
7953 !      include 'COMMON.LOCAL'
7954       real(kind=8),dimension(3) :: gx,gx1
7955       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7956       logical :: lprn,ldone
7957 !el local variables
7958       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7959               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7960
7961 ! Set lprn=.true. for debugging
7962       lprn=.false.
7963 #ifdef MPI
7964 !      maxconts=nres/4
7965       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7966       n_corr=0
7967       n_corr1=0
7968       if (nfgtasks.le.1) goto 30
7969       if (lprn) then
7970         write (iout,'(a)') 'Contact function values before RECEIVE:'
7971         do i=nnt,nct-2
7972           write (iout,'(2i3,50(1x,i2,f5.2))') &
7973           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7974           j=1,num_cont_hb(i))
7975         enddo
7976       endif
7977       call flush(iout)
7978       do i=1,ntask_cont_from
7979         ncont_recv(i)=0
7980       enddo
7981       do i=1,ntask_cont_to
7982         ncont_sent(i)=0
7983       enddo
7984 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7985 !     & ntask_cont_to
7986 ! Make the list of contacts to send to send to other procesors
7987 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7988 !      call flush(iout)
7989       do i=iturn3_start,iturn3_end
7990 !        write (iout,*) "make contact list turn3",i," num_cont",
7991 !     &    num_cont_hb(i)
7992         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7993       enddo
7994       do i=iturn4_start,iturn4_end
7995 !        write (iout,*) "make contact list turn4",i," num_cont",
7996 !     &   num_cont_hb(i)
7997         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7998       enddo
7999       do ii=1,nat_sent
8000         i=iat_sent(ii)
8001 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8002 !     &    num_cont_hb(i)
8003         do j=1,num_cont_hb(i)
8004         do k=1,4
8005           jjc=jcont_hb(j,i)
8006           iproc=iint_sent_local(k,jjc,ii)
8007 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8008           if (iproc.gt.0) then
8009             ncont_sent(iproc)=ncont_sent(iproc)+1
8010             nn=ncont_sent(iproc)
8011             zapas(1,nn,iproc)=i
8012             zapas(2,nn,iproc)=jjc
8013             zapas(3,nn,iproc)=facont_hb(j,i)
8014             zapas(4,nn,iproc)=ees0p(j,i)
8015             zapas(5,nn,iproc)=ees0m(j,i)
8016             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8017             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8018             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8019             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8020             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8021             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8022             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8023             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8024             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8025             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8026             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8027             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8028             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8029             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8030             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8031             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8032             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8033             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8034             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8035             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8036             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8037           endif
8038         enddo
8039         enddo
8040       enddo
8041       if (lprn) then
8042       write (iout,*) &
8043         "Numbers of contacts to be sent to other processors",&
8044         (ncont_sent(i),i=1,ntask_cont_to)
8045       write (iout,*) "Contacts sent"
8046       do ii=1,ntask_cont_to
8047         nn=ncont_sent(ii)
8048         iproc=itask_cont_to(ii)
8049         write (iout,*) nn," contacts to processor",iproc,&
8050          " of CONT_TO_COMM group"
8051         do i=1,nn
8052           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8053         enddo
8054       enddo
8055       call flush(iout)
8056       endif
8057       CorrelType=477
8058       CorrelID=fg_rank+1
8059       CorrelType1=478
8060       CorrelID1=nfgtasks+fg_rank+1
8061       ireq=0
8062 ! Receive the numbers of needed contacts from other processors
8063       do ii=1,ntask_cont_from
8064         iproc=itask_cont_from(ii)
8065         ireq=ireq+1
8066         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8067           FG_COMM,req(ireq),IERR)
8068       enddo
8069 !      write (iout,*) "IRECV ended"
8070 !      call flush(iout)
8071 ! Send the number of contacts needed by other processors
8072       do ii=1,ntask_cont_to
8073         iproc=itask_cont_to(ii)
8074         ireq=ireq+1
8075         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8076           FG_COMM,req(ireq),IERR)
8077       enddo
8078 !      write (iout,*) "ISEND ended"
8079 !      write (iout,*) "number of requests (nn)",ireq
8080       call flush(iout)
8081       if (ireq.gt.0) &
8082         call MPI_Waitall(ireq,req,status_array,ierr)
8083 !      write (iout,*)
8084 !     &  "Numbers of contacts to be received from other processors",
8085 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8086 !      call flush(iout)
8087 ! Receive contacts
8088       ireq=0
8089       do ii=1,ntask_cont_from
8090         iproc=itask_cont_from(ii)
8091         nn=ncont_recv(ii)
8092 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8093 !     &   " of CONT_TO_COMM group"
8094         call flush(iout)
8095         if (nn.gt.0) then
8096           ireq=ireq+1
8097           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8098           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8099 !          write (iout,*) "ireq,req",ireq,req(ireq)
8100         endif
8101       enddo
8102 ! Send the contacts to processors that need them
8103       do ii=1,ntask_cont_to
8104         iproc=itask_cont_to(ii)
8105         nn=ncont_sent(ii)
8106 !        write (iout,*) nn," contacts to processor",iproc,
8107 !     &   " of CONT_TO_COMM group"
8108         if (nn.gt.0) then
8109           ireq=ireq+1
8110           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8111             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8112 !          write (iout,*) "ireq,req",ireq,req(ireq)
8113 !          do i=1,nn
8114 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8115 !          enddo
8116         endif
8117       enddo
8118 !      write (iout,*) "number of requests (contacts)",ireq
8119 !      write (iout,*) "req",(req(i),i=1,4)
8120 !      call flush(iout)
8121       if (ireq.gt.0) &
8122        call MPI_Waitall(ireq,req,status_array,ierr)
8123       do iii=1,ntask_cont_from
8124         iproc=itask_cont_from(iii)
8125         nn=ncont_recv(iii)
8126         if (lprn) then
8127         write (iout,*) "Received",nn," contacts from processor",iproc,&
8128          " of CONT_FROM_COMM group"
8129         call flush(iout)
8130         do i=1,nn
8131           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8132         enddo
8133         call flush(iout)
8134         endif
8135         do i=1,nn
8136           ii=zapas_recv(1,i,iii)
8137 ! Flag the received contacts to prevent double-counting
8138           jj=-zapas_recv(2,i,iii)
8139 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8140 !          call flush(iout)
8141           nnn=num_cont_hb(ii)+1
8142           num_cont_hb(ii)=nnn
8143           jcont_hb(nnn,ii)=jj
8144           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8145           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8146           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8147           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8148           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8149           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8150           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8151           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8152           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8153           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8154           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8155           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8156           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8157           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8158           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8159           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8160           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8161           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8162           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8163           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8164           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8165           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8166           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8167           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8168         enddo
8169       enddo
8170       call flush(iout)
8171       if (lprn) then
8172         write (iout,'(a)') 'Contact function values after receive:'
8173         do i=nnt,nct-2
8174           write (iout,'(2i3,50(1x,i3,f5.2))') &
8175           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8176           j=1,num_cont_hb(i))
8177         enddo
8178         call flush(iout)
8179       endif
8180    30 continue
8181 #endif
8182       if (lprn) then
8183         write (iout,'(a)') 'Contact function values:'
8184         do i=nnt,nct-2
8185           write (iout,'(2i3,50(1x,i3,f5.2))') &
8186           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8187           j=1,num_cont_hb(i))
8188         enddo
8189       endif
8190       ecorr=0.0D0
8191
8192 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8193 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8194 ! Remove the loop below after debugging !!!
8195       do i=nnt,nct
8196         do j=1,3
8197           gradcorr(j,i)=0.0D0
8198           gradxorr(j,i)=0.0D0
8199         enddo
8200       enddo
8201 ! Calculate the local-electrostatic correlation terms
8202       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8203         i1=i+1
8204         num_conti=num_cont_hb(i)
8205         num_conti1=num_cont_hb(i+1)
8206         do jj=1,num_conti
8207           j=jcont_hb(jj,i)
8208           jp=iabs(j)
8209           do kk=1,num_conti1
8210             j1=jcont_hb(kk,i1)
8211             jp1=iabs(j1)
8212 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8213 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8214             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8215                 .or. j.lt.0 .and. j1.gt.0) .and. &
8216                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8217 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8218 ! The system gains extra energy.
8219               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8220               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8221                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8222               n_corr=n_corr+1
8223             else if (j1.eq.j) then
8224 ! Contacts I-J and I-(J+1) occur simultaneously.
8225 ! The system loses extra energy.
8226 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8227             endif
8228           enddo ! kk
8229           do kk=1,num_conti
8230             j1=jcont_hb(kk,i)
8231 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8232 !    &         ' jj=',jj,' kk=',kk
8233             if (j1.eq.j+1) then
8234 ! Contacts I-J and (I+1)-J occur simultaneously.
8235 ! The system loses extra energy.
8236 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8237             endif ! j1==j+1
8238           enddo ! kk
8239         enddo ! jj
8240       enddo ! i
8241       return
8242       end subroutine multibody_hb
8243 !-----------------------------------------------------------------------------
8244       subroutine add_hb_contact(ii,jj,itask)
8245 !      implicit real*8 (a-h,o-z)
8246 !      include "DIMENSIONS"
8247 !      include "COMMON.IOUNITS"
8248 !      include "COMMON.CONTACTS"
8249 !      integer,parameter :: maxconts=nres/4
8250       integer,parameter :: max_dim=26
8251       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8252 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8253 !      common /przechowalnia/ zapas
8254       integer :: i,j,ii,jj,iproc,nn,jjc
8255       integer,dimension(4) :: itask
8256 !      write (iout,*) "itask",itask
8257       do i=1,2
8258         iproc=itask(i)
8259         if (iproc.gt.0) then
8260           do j=1,num_cont_hb(ii)
8261             jjc=jcont_hb(j,ii)
8262 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8263             if (jjc.eq.jj) then
8264               ncont_sent(iproc)=ncont_sent(iproc)+1
8265               nn=ncont_sent(iproc)
8266               zapas(1,nn,iproc)=ii
8267               zapas(2,nn,iproc)=jjc
8268               zapas(3,nn,iproc)=facont_hb(j,ii)
8269               zapas(4,nn,iproc)=ees0p(j,ii)
8270               zapas(5,nn,iproc)=ees0m(j,ii)
8271               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8272               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8273               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8274               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8275               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8276               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8277               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8278               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8279               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8280               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8281               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8282               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8283               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8284               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8285               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8286               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8287               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8288               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8289               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8290               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8291               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8292               exit
8293             endif
8294           enddo
8295         endif
8296       enddo
8297       return
8298       end subroutine add_hb_contact
8299 !-----------------------------------------------------------------------------
8300       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8301 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8302 !      implicit real*8 (a-h,o-z)
8303 !      include 'DIMENSIONS'
8304 !      include 'COMMON.IOUNITS'
8305       integer,parameter :: max_dim=70
8306 #ifdef MPI
8307       include "mpif.h"
8308 !      integer :: maxconts !max_cont=maxconts=nres/4
8309       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8310       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8311 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8312 !      common /przechowalnia/ zapas
8313       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8314         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8315         ierr,iii,nnn
8316 #endif
8317 !      include 'COMMON.SETUP'
8318 !      include 'COMMON.FFIELD'
8319 !      include 'COMMON.DERIV'
8320 !      include 'COMMON.LOCAL'
8321 !      include 'COMMON.INTERACT'
8322 !      include 'COMMON.CONTACTS'
8323 !      include 'COMMON.CHAIN'
8324 !      include 'COMMON.CONTROL'
8325       real(kind=8),dimension(3) :: gx,gx1
8326       integer,dimension(nres) :: num_cont_hb_old
8327       logical :: lprn,ldone
8328 !EL      double precision eello4,eello5,eelo6,eello_turn6
8329 !EL      external eello4,eello5,eello6,eello_turn6
8330 !el local variables
8331       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8332               j1,jp1,i1,num_conti1
8333       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8334       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8335
8336 ! Set lprn=.true. for debugging
8337       lprn=.false.
8338       eturn6=0.0d0
8339 #ifdef MPI
8340 !      maxconts=nres/4
8341       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8342       do i=1,nres
8343         num_cont_hb_old(i)=num_cont_hb(i)
8344       enddo
8345       n_corr=0
8346       n_corr1=0
8347       if (nfgtasks.le.1) goto 30
8348       if (lprn) then
8349         write (iout,'(a)') 'Contact function values before RECEIVE:'
8350         do i=nnt,nct-2
8351           write (iout,'(2i3,50(1x,i2,f5.2))') &
8352           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8353           j=1,num_cont_hb(i))
8354         enddo
8355       endif
8356       call flush(iout)
8357       do i=1,ntask_cont_from
8358         ncont_recv(i)=0
8359       enddo
8360       do i=1,ntask_cont_to
8361         ncont_sent(i)=0
8362       enddo
8363 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8364 !     & ntask_cont_to
8365 ! Make the list of contacts to send to send to other procesors
8366       do i=iturn3_start,iturn3_end
8367 !        write (iout,*) "make contact list turn3",i," num_cont",
8368 !     &    num_cont_hb(i)
8369         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8370       enddo
8371       do i=iturn4_start,iturn4_end
8372 !        write (iout,*) "make contact list turn4",i," num_cont",
8373 !     &   num_cont_hb(i)
8374         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8375       enddo
8376       do ii=1,nat_sent
8377         i=iat_sent(ii)
8378 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8379 !     &    num_cont_hb(i)
8380         do j=1,num_cont_hb(i)
8381         do k=1,4
8382           jjc=jcont_hb(j,i)
8383           iproc=iint_sent_local(k,jjc,ii)
8384 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8385           if (iproc.ne.0) then
8386             ncont_sent(iproc)=ncont_sent(iproc)+1
8387             nn=ncont_sent(iproc)
8388             zapas(1,nn,iproc)=i
8389             zapas(2,nn,iproc)=jjc
8390             zapas(3,nn,iproc)=d_cont(j,i)
8391             ind=3
8392             do kk=1,3
8393               ind=ind+1
8394               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8395             enddo
8396             do kk=1,2
8397               do ll=1,2
8398                 ind=ind+1
8399                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8400               enddo
8401             enddo
8402             do jj=1,5
8403               do kk=1,3
8404                 do ll=1,2
8405                   do mm=1,2
8406                     ind=ind+1
8407                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8408                   enddo
8409                 enddo
8410               enddo
8411             enddo
8412           endif
8413         enddo
8414         enddo
8415       enddo
8416       if (lprn) then
8417       write (iout,*) &
8418         "Numbers of contacts to be sent to other processors",&
8419         (ncont_sent(i),i=1,ntask_cont_to)
8420       write (iout,*) "Contacts sent"
8421       do ii=1,ntask_cont_to
8422         nn=ncont_sent(ii)
8423         iproc=itask_cont_to(ii)
8424         write (iout,*) nn," contacts to processor",iproc,&
8425          " of CONT_TO_COMM group"
8426         do i=1,nn
8427           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8428         enddo
8429       enddo
8430       call flush(iout)
8431       endif
8432       CorrelType=477
8433       CorrelID=fg_rank+1
8434       CorrelType1=478
8435       CorrelID1=nfgtasks+fg_rank+1
8436       ireq=0
8437 ! Receive the numbers of needed contacts from other processors
8438       do ii=1,ntask_cont_from
8439         iproc=itask_cont_from(ii)
8440         ireq=ireq+1
8441         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8442           FG_COMM,req(ireq),IERR)
8443       enddo
8444 !      write (iout,*) "IRECV ended"
8445 !      call flush(iout)
8446 ! Send the number of contacts needed by other processors
8447       do ii=1,ntask_cont_to
8448         iproc=itask_cont_to(ii)
8449         ireq=ireq+1
8450         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8451           FG_COMM,req(ireq),IERR)
8452       enddo
8453 !      write (iout,*) "ISEND ended"
8454 !      write (iout,*) "number of requests (nn)",ireq
8455       call flush(iout)
8456       if (ireq.gt.0) &
8457         call MPI_Waitall(ireq,req,status_array,ierr)
8458 !      write (iout,*)
8459 !     &  "Numbers of contacts to be received from other processors",
8460 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8461 !      call flush(iout)
8462 ! Receive contacts
8463       ireq=0
8464       do ii=1,ntask_cont_from
8465         iproc=itask_cont_from(ii)
8466         nn=ncont_recv(ii)
8467 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8468 !     &   " of CONT_TO_COMM group"
8469         call flush(iout)
8470         if (nn.gt.0) then
8471           ireq=ireq+1
8472           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8473           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8474 !          write (iout,*) "ireq,req",ireq,req(ireq)
8475         endif
8476       enddo
8477 ! Send the contacts to processors that need them
8478       do ii=1,ntask_cont_to
8479         iproc=itask_cont_to(ii)
8480         nn=ncont_sent(ii)
8481 !        write (iout,*) nn," contacts to processor",iproc,
8482 !     &   " of CONT_TO_COMM group"
8483         if (nn.gt.0) then
8484           ireq=ireq+1
8485           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8486             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8487 !          write (iout,*) "ireq,req",ireq,req(ireq)
8488 !          do i=1,nn
8489 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8490 !          enddo
8491         endif
8492       enddo
8493 !      write (iout,*) "number of requests (contacts)",ireq
8494 !      write (iout,*) "req",(req(i),i=1,4)
8495 !      call flush(iout)
8496       if (ireq.gt.0) &
8497        call MPI_Waitall(ireq,req,status_array,ierr)
8498       do iii=1,ntask_cont_from
8499         iproc=itask_cont_from(iii)
8500         nn=ncont_recv(iii)
8501         if (lprn) then
8502         write (iout,*) "Received",nn," contacts from processor",iproc,&
8503          " of CONT_FROM_COMM group"
8504         call flush(iout)
8505         do i=1,nn
8506           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8507         enddo
8508         call flush(iout)
8509         endif
8510         do i=1,nn
8511           ii=zapas_recv(1,i,iii)
8512 ! Flag the received contacts to prevent double-counting
8513           jj=-zapas_recv(2,i,iii)
8514 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8515 !          call flush(iout)
8516           nnn=num_cont_hb(ii)+1
8517           num_cont_hb(ii)=nnn
8518           jcont_hb(nnn,ii)=jj
8519           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8520           ind=3
8521           do kk=1,3
8522             ind=ind+1
8523             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8524           enddo
8525           do kk=1,2
8526             do ll=1,2
8527               ind=ind+1
8528               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8529             enddo
8530           enddo
8531           do jj=1,5
8532             do kk=1,3
8533               do ll=1,2
8534                 do mm=1,2
8535                   ind=ind+1
8536                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8537                 enddo
8538               enddo
8539             enddo
8540           enddo
8541         enddo
8542       enddo
8543       call flush(iout)
8544       if (lprn) then
8545         write (iout,'(a)') 'Contact function values after receive:'
8546         do i=nnt,nct-2
8547           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8548           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8549           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8550         enddo
8551         call flush(iout)
8552       endif
8553    30 continue
8554 #endif
8555       if (lprn) then
8556         write (iout,'(a)') 'Contact function values:'
8557         do i=nnt,nct-2
8558           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8559           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8560           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8561         enddo
8562       endif
8563       ecorr=0.0D0
8564       ecorr5=0.0d0
8565       ecorr6=0.0d0
8566
8567 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8568 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8569 ! Remove the loop below after debugging !!!
8570       do i=nnt,nct
8571         do j=1,3
8572           gradcorr(j,i)=0.0D0
8573           gradxorr(j,i)=0.0D0
8574         enddo
8575       enddo
8576 ! Calculate the dipole-dipole interaction energies
8577       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8578       do i=iatel_s,iatel_e+1
8579         num_conti=num_cont_hb(i)
8580         do jj=1,num_conti
8581           j=jcont_hb(jj,i)
8582 #ifdef MOMENT
8583           call dipole(i,j,jj)
8584 #endif
8585         enddo
8586       enddo
8587       endif
8588 ! Calculate the local-electrostatic correlation terms
8589 !                write (iout,*) "gradcorr5 in eello5 before loop"
8590 !                do iii=1,nres
8591 !                  write (iout,'(i5,3f10.5)')
8592 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8593 !                enddo
8594       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8595 !        write (iout,*) "corr loop i",i
8596         i1=i+1
8597         num_conti=num_cont_hb(i)
8598         num_conti1=num_cont_hb(i+1)
8599         do jj=1,num_conti
8600           j=jcont_hb(jj,i)
8601           jp=iabs(j)
8602           do kk=1,num_conti1
8603             j1=jcont_hb(kk,i1)
8604             jp1=iabs(j1)
8605 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8606 !     &         ' jj=',jj,' kk=',kk
8607 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8608             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8609                 .or. j.lt.0 .and. j1.gt.0) .and. &
8610                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8611 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8612 ! The system gains extra energy.
8613               n_corr=n_corr+1
8614               sqd1=dsqrt(d_cont(jj,i))
8615               sqd2=dsqrt(d_cont(kk,i1))
8616               sred_geom = sqd1*sqd2
8617               IF (sred_geom.lt.cutoff_corr) THEN
8618                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8619                   ekont,fprimcont)
8620 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8621 !d     &         ' jj=',jj,' kk=',kk
8622                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8623                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8624                 do l=1,3
8625                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8626                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8627                 enddo
8628                 n_corr1=n_corr1+1
8629 !d               write (iout,*) 'sred_geom=',sred_geom,
8630 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8631 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8632 !d               write (iout,*) "g_contij",g_contij
8633 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8634 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8635                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8636                 if (wcorr4.gt.0.0d0) &
8637                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8638                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8639                        write (iout,'(a6,4i5,0pf7.3)') &
8640                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8641 !                write (iout,*) "gradcorr5 before eello5"
8642 !                do iii=1,nres
8643 !                  write (iout,'(i5,3f10.5)')
8644 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8645 !                enddo
8646                 if (wcorr5.gt.0.0d0) &
8647                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8648 !                write (iout,*) "gradcorr5 after eello5"
8649 !                do iii=1,nres
8650 !                  write (iout,'(i5,3f10.5)')
8651 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8652 !                enddo
8653                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8654                        write (iout,'(a6,4i5,0pf7.3)') &
8655                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8656 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8657 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8658                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8659                      .or. wturn6.eq.0.0d0))then
8660 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8661                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8662                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8663                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8664 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8665 !d     &            'ecorr6=',ecorr6
8666 !d                write (iout,'(4e15.5)') sred_geom,
8667 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8668 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8669 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8670                 else if (wturn6.gt.0.0d0 &
8671                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8672 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8673                   eturn6=eturn6+eello_turn6(i,jj,kk)
8674                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8675                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8676 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8677                 endif
8678               ENDIF
8679 1111          continue
8680             endif
8681           enddo ! kk
8682         enddo ! jj
8683       enddo ! i
8684       do i=1,nres
8685         num_cont_hb(i)=num_cont_hb_old(i)
8686       enddo
8687 !                write (iout,*) "gradcorr5 in eello5"
8688 !                do iii=1,nres
8689 !                  write (iout,'(i5,3f10.5)')
8690 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8691 !                enddo
8692       return
8693       end subroutine multibody_eello
8694 !-----------------------------------------------------------------------------
8695       subroutine add_hb_contact_eello(ii,jj,itask)
8696 !      implicit real*8 (a-h,o-z)
8697 !      include "DIMENSIONS"
8698 !      include "COMMON.IOUNITS"
8699 !      include "COMMON.CONTACTS"
8700 !      integer,parameter :: maxconts=nres/4
8701       integer,parameter :: max_dim=70
8702       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8703 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8704 !      common /przechowalnia/ zapas
8705
8706       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8707       integer,dimension(4) ::itask
8708 !      write (iout,*) "itask",itask
8709       do i=1,2
8710         iproc=itask(i)
8711         if (iproc.gt.0) then
8712           do j=1,num_cont_hb(ii)
8713             jjc=jcont_hb(j,ii)
8714 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8715             if (jjc.eq.jj) then
8716               ncont_sent(iproc)=ncont_sent(iproc)+1
8717               nn=ncont_sent(iproc)
8718               zapas(1,nn,iproc)=ii
8719               zapas(2,nn,iproc)=jjc
8720               zapas(3,nn,iproc)=d_cont(j,ii)
8721               ind=3
8722               do kk=1,3
8723                 ind=ind+1
8724                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8725               enddo
8726               do kk=1,2
8727                 do ll=1,2
8728                   ind=ind+1
8729                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8730                 enddo
8731               enddo
8732               do jj=1,5
8733                 do kk=1,3
8734                   do ll=1,2
8735                     do mm=1,2
8736                       ind=ind+1
8737                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8738                     enddo
8739                   enddo
8740                 enddo
8741               enddo
8742               exit
8743             endif
8744           enddo
8745         endif
8746       enddo
8747       return
8748       end subroutine add_hb_contact_eello
8749 !-----------------------------------------------------------------------------
8750       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8751 !      implicit real*8 (a-h,o-z)
8752 !      include 'DIMENSIONS'
8753 !      include 'COMMON.IOUNITS'
8754 !      include 'COMMON.DERIV'
8755 !      include 'COMMON.INTERACT'
8756 !      include 'COMMON.CONTACTS'
8757       real(kind=8),dimension(3) :: gx,gx1
8758       logical :: lprn
8759 !el local variables
8760       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8761       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8762                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8763                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8764                    rlocshield
8765
8766       lprn=.false.
8767       eij=facont_hb(jj,i)
8768       ekl=facont_hb(kk,k)
8769       ees0pij=ees0p(jj,i)
8770       ees0pkl=ees0p(kk,k)
8771       ees0mij=ees0m(jj,i)
8772       ees0mkl=ees0m(kk,k)
8773       ekont=eij*ekl
8774       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8775 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8776 ! Following 4 lines for diagnostics.
8777 !d    ees0pkl=0.0D0
8778 !d    ees0pij=1.0D0
8779 !d    ees0mkl=0.0D0
8780 !d    ees0mij=1.0D0
8781 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8782 !     & 'Contacts ',i,j,
8783 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8784 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8785 !     & 'gradcorr_long'
8786 ! Calculate the multi-body contribution to energy.
8787 !      ecorr=ecorr+ekont*ees
8788 ! Calculate multi-body contributions to the gradient.
8789       coeffpees0pij=coeffp*ees0pij
8790       coeffmees0mij=coeffm*ees0mij
8791       coeffpees0pkl=coeffp*ees0pkl
8792       coeffmees0mkl=coeffm*ees0mkl
8793       do ll=1,3
8794 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8795         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8796         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8797         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8798         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8799         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8800         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8801 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8802         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8803         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8804         coeffmees0mij*gacontm_hb1(ll,kk,k))
8805         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8806         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8807         coeffmees0mij*gacontm_hb2(ll,kk,k))
8808         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8809            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8810            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8811         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8812         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8813         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8814            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8815            coeffmees0mij*gacontm_hb3(ll,kk,k))
8816         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8817         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8818 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8819       enddo
8820 !      write (iout,*)
8821 !grad      do m=i+1,j-1
8822 !grad        do ll=1,3
8823 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8824 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8825 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8826 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8827 !grad        enddo
8828 !grad      enddo
8829 !grad      do m=k+1,l-1
8830 !grad        do ll=1,3
8831 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8832 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8833 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8834 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8835 !grad        enddo
8836 !grad      enddo
8837 !      write (iout,*) "ehbcorr",ekont*ees
8838       ehbcorr=ekont*ees
8839       if (shield_mode.gt.0) then
8840        j=ees0plist(jj,i)
8841        l=ees0plist(kk,k)
8842 !C        print *,i,j,fac_shield(i),fac_shield(j),
8843 !C     &fac_shield(k),fac_shield(l)
8844         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8845            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8846           do ilist=1,ishield_list(i)
8847            iresshield=shield_list(ilist,i)
8848            do m=1,3
8849            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8850            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8851                    rlocshield  &
8852             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8853             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8854             +rlocshield
8855            enddo
8856           enddo
8857           do ilist=1,ishield_list(j)
8858            iresshield=shield_list(ilist,j)
8859            do m=1,3
8860            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8861            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8862                    rlocshield &
8863             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8864            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8865             +rlocshield
8866            enddo
8867           enddo
8868
8869           do ilist=1,ishield_list(k)
8870            iresshield=shield_list(ilist,k)
8871            do m=1,3
8872            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8873            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8874                    rlocshield &
8875             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8876            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8877             +rlocshield
8878            enddo
8879           enddo
8880           do ilist=1,ishield_list(l)
8881            iresshield=shield_list(ilist,l)
8882            do m=1,3
8883            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8884            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8885                    rlocshield &
8886             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8887            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8888             +rlocshield
8889            enddo
8890           enddo
8891           do m=1,3
8892             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8893                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8894             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8895                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8896             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8897                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8898             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8899                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8900
8901             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8902                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8903             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8904                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8905             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8906                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8907             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8908                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8909
8910            enddo
8911       endif
8912       endif
8913       return
8914       end function ehbcorr
8915 #ifdef MOMENT
8916 !-----------------------------------------------------------------------------
8917       subroutine dipole(i,j,jj)
8918 !      implicit real*8 (a-h,o-z)
8919 !      include 'DIMENSIONS'
8920 !      include 'COMMON.IOUNITS'
8921 !      include 'COMMON.CHAIN'
8922 !      include 'COMMON.FFIELD'
8923 !      include 'COMMON.DERIV'
8924 !      include 'COMMON.INTERACT'
8925 !      include 'COMMON.CONTACTS'
8926 !      include 'COMMON.TORSION'
8927 !      include 'COMMON.VAR'
8928 !      include 'COMMON.GEO'
8929       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8930       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8931       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8932
8933       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8934       allocate(dipderx(3,5,4,maxconts,nres))
8935 !
8936
8937       iti1 = itortyp(itype(i+1,1))
8938       if (j.lt.nres-1) then
8939         itj1 = itype2loc(itype(j+1,1))
8940       else
8941         itj1=nloctyp
8942       endif
8943       do iii=1,2
8944         dipi(iii,1)=Ub2(iii,i)
8945         dipderi(iii)=Ub2der(iii,i)
8946         dipi(iii,2)=b1(iii,iti1)
8947         dipj(iii,1)=Ub2(iii,j)
8948         dipderj(iii)=Ub2der(iii,j)
8949         dipj(iii,2)=b1(iii,itj1)
8950       enddo
8951       kkk=0
8952       do iii=1,2
8953         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8954         do jjj=1,2
8955           kkk=kkk+1
8956           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8957         enddo
8958       enddo
8959       do kkk=1,5
8960         do lll=1,3
8961           mmm=0
8962           do iii=1,2
8963             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8964               auxvec(1))
8965             do jjj=1,2
8966               mmm=mmm+1
8967               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8968             enddo
8969           enddo
8970         enddo
8971       enddo
8972       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8973       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8974       do iii=1,2
8975         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8976       enddo
8977       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8978       do iii=1,2
8979         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8980       enddo
8981       return
8982       end subroutine dipole
8983 #endif
8984 !-----------------------------------------------------------------------------
8985       subroutine calc_eello(i,j,k,l,jj,kk)
8986 !
8987 ! This subroutine computes matrices and vectors needed to calculate
8988 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8989 !
8990       use comm_kut
8991 !      implicit real*8 (a-h,o-z)
8992 !      include 'DIMENSIONS'
8993 !      include 'COMMON.IOUNITS'
8994 !      include 'COMMON.CHAIN'
8995 !      include 'COMMON.DERIV'
8996 !      include 'COMMON.INTERACT'
8997 !      include 'COMMON.CONTACTS'
8998 !      include 'COMMON.TORSION'
8999 !      include 'COMMON.VAR'
9000 !      include 'COMMON.GEO'
9001 !      include 'COMMON.FFIELD'
9002       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9003       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9004       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9005               itj1
9006 !el      logical :: lprn
9007 !el      common /kutas/ lprn
9008 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9009 !d     & ' jj=',jj,' kk=',kk
9010 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9011 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9012 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9013       do iii=1,2
9014         do jjj=1,2
9015           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9016           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9017         enddo
9018       enddo
9019       call transpose2(aa1(1,1),aa1t(1,1))
9020       call transpose2(aa2(1,1),aa2t(1,1))
9021       do kkk=1,5
9022         do lll=1,3
9023           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9024             aa1tder(1,1,lll,kkk))
9025           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9026             aa2tder(1,1,lll,kkk))
9027         enddo
9028       enddo
9029       if (l.eq.j+1) then
9030 ! parallel orientation of the two CA-CA-CA frames.
9031         if (i.gt.1) then
9032           iti=itortyp(itype(i,1))
9033         else
9034           iti=ntortyp+1
9035         endif
9036         itk1=itortyp(itype(k+1,1))
9037         itj=itortyp(itype(j,1))
9038         if (l.lt.nres-1) then
9039           itl1=itortyp(itype(l+1,1))
9040         else
9041           itl1=ntortyp+1
9042         endif
9043 ! A1 kernel(j+1) A2T
9044 !d        do iii=1,2
9045 !d          write (iout,'(3f10.5,5x,3f10.5)')
9046 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9047 !d        enddo
9048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9049          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9050          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9051 ! Following matrices are needed only for 6-th order cumulants
9052         IF (wcorr6.gt.0.0d0) THEN
9053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9054          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9055          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9056         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9057          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9058          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9059          ADtEAderx(1,1,1,1,1,1))
9060         lprn=.false.
9061         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9062          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9063          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9064          ADtEA1derx(1,1,1,1,1,1))
9065         ENDIF
9066 ! End 6-th order cumulants
9067 !d        lprn=.false.
9068 !d        if (lprn) then
9069 !d        write (2,*) 'In calc_eello6'
9070 !d        do iii=1,2
9071 !d          write (2,*) 'iii=',iii
9072 !d          do kkk=1,5
9073 !d            write (2,*) 'kkk=',kkk
9074 !d            do jjj=1,2
9075 !d              write (2,'(3(2f10.5),5x)')
9076 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9077 !d            enddo
9078 !d          enddo
9079 !d        enddo
9080 !d        endif
9081         call transpose2(EUgder(1,1,k),auxmat(1,1))
9082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9083         call transpose2(EUg(1,1,k),auxmat(1,1))
9084         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9085         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9086         do iii=1,2
9087           do kkk=1,5
9088             do lll=1,3
9089               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9090                 EAEAderx(1,1,lll,kkk,iii,1))
9091             enddo
9092           enddo
9093         enddo
9094 ! A1T kernel(i+1) A2
9095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9096          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9097          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9098 ! Following matrices are needed only for 6-th order cumulants
9099         IF (wcorr6.gt.0.0d0) THEN
9100         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9101          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9102          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9103         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9104          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9105          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9106          ADtEAderx(1,1,1,1,1,2))
9107         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9108          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9109          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9110          ADtEA1derx(1,1,1,1,1,2))
9111         ENDIF
9112 ! End 6-th order cumulants
9113         call transpose2(EUgder(1,1,l),auxmat(1,1))
9114         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9115         call transpose2(EUg(1,1,l),auxmat(1,1))
9116         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9117         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9118         do iii=1,2
9119           do kkk=1,5
9120             do lll=1,3
9121               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9122                 EAEAderx(1,1,lll,kkk,iii,2))
9123             enddo
9124           enddo
9125         enddo
9126 ! AEAb1 and AEAb2
9127 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9128 ! They are needed only when the fifth- or the sixth-order cumulants are
9129 ! indluded.
9130         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9131         call transpose2(AEA(1,1,1),auxmat(1,1))
9132         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9134         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9135         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9136         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9137         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9138         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9139         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9140         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9141         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9142         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9143         call transpose2(AEA(1,1,2),auxmat(1,1))
9144         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9145         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9146         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9147         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9148         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9149         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9150         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9151         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9152         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9153         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9154         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9155 ! Calculate the Cartesian derivatives of the vectors.
9156         do iii=1,2
9157           do kkk=1,5
9158             do lll=1,3
9159               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9160               call matvec2(auxmat(1,1),b1(1,iti),&
9161                 AEAb1derx(1,lll,kkk,iii,1,1))
9162               call matvec2(auxmat(1,1),Ub2(1,i),&
9163                 AEAb2derx(1,lll,kkk,iii,1,1))
9164               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9165                 AEAb1derx(1,lll,kkk,iii,2,1))
9166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9167                 AEAb2derx(1,lll,kkk,iii,2,1))
9168               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9169               call matvec2(auxmat(1,1),b1(1,itj),&
9170                 AEAb1derx(1,lll,kkk,iii,1,2))
9171               call matvec2(auxmat(1,1),Ub2(1,j),&
9172                 AEAb2derx(1,lll,kkk,iii,1,2))
9173               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9174                 AEAb1derx(1,lll,kkk,iii,2,2))
9175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9176                 AEAb2derx(1,lll,kkk,iii,2,2))
9177             enddo
9178           enddo
9179         enddo
9180         ENDIF
9181 ! End vectors
9182       else
9183 ! Antiparallel orientation of the two CA-CA-CA frames.
9184         if (i.gt.1) then
9185           iti=itortyp(itype(i,1))
9186         else
9187           iti=ntortyp+1
9188         endif
9189         itk1=itortyp(itype(k+1,1))
9190         itl=itortyp(itype(l,1))
9191         itj=itortyp(itype(j,1))
9192         if (j.lt.nres-1) then
9193           itj1=itortyp(itype(j+1,1))
9194         else
9195           itj1=ntortyp+1
9196         endif
9197 ! A2 kernel(j-1)T A1T
9198         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9199          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9200          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9201 ! Following matrices are needed only for 6-th order cumulants
9202         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9203            j.eq.i+4 .and. l.eq.i+3)) THEN
9204         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9205          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9206          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9207         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9208          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9209          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9210          ADtEAderx(1,1,1,1,1,1))
9211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9212          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9213          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9214          ADtEA1derx(1,1,1,1,1,1))
9215         ENDIF
9216 ! End 6-th order cumulants
9217         call transpose2(EUgder(1,1,k),auxmat(1,1))
9218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9219         call transpose2(EUg(1,1,k),auxmat(1,1))
9220         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9221         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9222         do iii=1,2
9223           do kkk=1,5
9224             do lll=1,3
9225               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9226                 EAEAderx(1,1,lll,kkk,iii,1))
9227             enddo
9228           enddo
9229         enddo
9230 ! A2T kernel(i+1)T A1
9231         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9232          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9233          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9234 ! Following matrices are needed only for 6-th order cumulants
9235         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9236            j.eq.i+4 .and. l.eq.i+3)) THEN
9237         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9238          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9239          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9240         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9241          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9242          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9243          ADtEAderx(1,1,1,1,1,2))
9244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9245          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9246          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9247          ADtEA1derx(1,1,1,1,1,2))
9248         ENDIF
9249 ! End 6-th order cumulants
9250         call transpose2(EUgder(1,1,j),auxmat(1,1))
9251         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9252         call transpose2(EUg(1,1,j),auxmat(1,1))
9253         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9254         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9255         do iii=1,2
9256           do kkk=1,5
9257             do lll=1,3
9258               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9259                 EAEAderx(1,1,lll,kkk,iii,2))
9260             enddo
9261           enddo
9262         enddo
9263 ! AEAb1 and AEAb2
9264 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9265 ! They are needed only when the fifth- or the sixth-order cumulants are
9266 ! indluded.
9267         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9268           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9269         call transpose2(AEA(1,1,1),auxmat(1,1))
9270         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9271         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9272         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9273         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9274         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9275         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9276         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9277         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9278         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9279         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9280         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9281         call transpose2(AEA(1,1,2),auxmat(1,1))
9282         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9283         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9284         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9285         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9286         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9287         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9288         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9289         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9290         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9291         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9292         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9293 ! Calculate the Cartesian derivatives of the vectors.
9294         do iii=1,2
9295           do kkk=1,5
9296             do lll=1,3
9297               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9298               call matvec2(auxmat(1,1),b1(1,iti),&
9299                 AEAb1derx(1,lll,kkk,iii,1,1))
9300               call matvec2(auxmat(1,1),Ub2(1,i),&
9301                 AEAb2derx(1,lll,kkk,iii,1,1))
9302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9303                 AEAb1derx(1,lll,kkk,iii,2,1))
9304               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9305                 AEAb2derx(1,lll,kkk,iii,2,1))
9306               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9307               call matvec2(auxmat(1,1),b1(1,itl),&
9308                 AEAb1derx(1,lll,kkk,iii,1,2))
9309               call matvec2(auxmat(1,1),Ub2(1,l),&
9310                 AEAb2derx(1,lll,kkk,iii,1,2))
9311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9312                 AEAb1derx(1,lll,kkk,iii,2,2))
9313               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9314                 AEAb2derx(1,lll,kkk,iii,2,2))
9315             enddo
9316           enddo
9317         enddo
9318         ENDIF
9319 ! End vectors
9320       endif
9321       return
9322       end subroutine calc_eello
9323 !-----------------------------------------------------------------------------
9324       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9325       use comm_kut
9326       implicit none
9327       integer :: nderg
9328       logical :: transp
9329       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9330       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9331       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9332       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9333       integer :: iii,kkk,lll
9334       integer :: jjj,mmm
9335 !el      logical :: lprn
9336 !el      common /kutas/ lprn
9337       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9338       do iii=1,nderg
9339         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9340           AKAderg(1,1,iii))
9341       enddo
9342 !d      if (lprn) write (2,*) 'In kernel'
9343       do kkk=1,5
9344 !d        if (lprn) write (2,*) 'kkk=',kkk
9345         do lll=1,3
9346           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9347             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9348 !d          if (lprn) then
9349 !d            write (2,*) 'lll=',lll
9350 !d            write (2,*) 'iii=1'
9351 !d            do jjj=1,2
9352 !d              write (2,'(3(2f10.5),5x)')
9353 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9354 !d            enddo
9355 !d          endif
9356           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9357             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9358 !d          if (lprn) then
9359 !d            write (2,*) 'lll=',lll
9360 !d            write (2,*) 'iii=2'
9361 !d            do jjj=1,2
9362 !d              write (2,'(3(2f10.5),5x)')
9363 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9364 !d            enddo
9365 !d          endif
9366         enddo
9367       enddo
9368       return
9369       end subroutine kernel
9370 !-----------------------------------------------------------------------------
9371       real(kind=8) function eello4(i,j,k,l,jj,kk)
9372 !      implicit real*8 (a-h,o-z)
9373 !      include 'DIMENSIONS'
9374 !      include 'COMMON.IOUNITS'
9375 !      include 'COMMON.CHAIN'
9376 !      include 'COMMON.DERIV'
9377 !      include 'COMMON.INTERACT'
9378 !      include 'COMMON.CONTACTS'
9379 !      include 'COMMON.TORSION'
9380 !      include 'COMMON.VAR'
9381 !      include 'COMMON.GEO'
9382       real(kind=8),dimension(2,2) :: pizda
9383       real(kind=8),dimension(3) :: ggg1,ggg2
9384       real(kind=8) ::  eel4,glongij,glongkl
9385       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9386 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9387 !d        eello4=0.0d0
9388 !d        return
9389 !d      endif
9390 !d      print *,'eello4:',i,j,k,l,jj,kk
9391 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9392 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9393 !old      eij=facont_hb(jj,i)
9394 !old      ekl=facont_hb(kk,k)
9395 !old      ekont=eij*ekl
9396       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9397 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9398       gcorr_loc(k-1)=gcorr_loc(k-1) &
9399          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9400       if (l.eq.j+1) then
9401         gcorr_loc(l-1)=gcorr_loc(l-1) &
9402            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9403       else
9404         gcorr_loc(j-1)=gcorr_loc(j-1) &
9405            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9406       endif
9407       do iii=1,2
9408         do kkk=1,5
9409           do lll=1,3
9410             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9411                               -EAEAderx(2,2,lll,kkk,iii,1)
9412 !d            derx(lll,kkk,iii)=0.0d0
9413           enddo
9414         enddo
9415       enddo
9416 !d      gcorr_loc(l-1)=0.0d0
9417 !d      gcorr_loc(j-1)=0.0d0
9418 !d      gcorr_loc(k-1)=0.0d0
9419 !d      eel4=1.0d0
9420 !d      write (iout,*)'Contacts have occurred for peptide groups',
9421 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9422 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9423       if (j.lt.nres-1) then
9424         j1=j+1
9425         j2=j-1
9426       else
9427         j1=j-1
9428         j2=j-2
9429       endif
9430       if (l.lt.nres-1) then
9431         l1=l+1
9432         l2=l-1
9433       else
9434         l1=l-1
9435         l2=l-2
9436       endif
9437       do ll=1,3
9438 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9439 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9440         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9441         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9442 !grad        ghalf=0.5d0*ggg1(ll)
9443         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9444         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9445         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9446         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9447         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9448         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9449 !grad        ghalf=0.5d0*ggg2(ll)
9450         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9451         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9452         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9453         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9454         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9455         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9456       enddo
9457 !grad      do m=i+1,j-1
9458 !grad        do ll=1,3
9459 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9460 !grad        enddo
9461 !grad      enddo
9462 !grad      do m=k+1,l-1
9463 !grad        do ll=1,3
9464 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9465 !grad        enddo
9466 !grad      enddo
9467 !grad      do m=i+2,j2
9468 !grad        do ll=1,3
9469 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9470 !grad        enddo
9471 !grad      enddo
9472 !grad      do m=k+2,l2
9473 !grad        do ll=1,3
9474 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9475 !grad        enddo
9476 !grad      enddo
9477 !d      do iii=1,nres-3
9478 !d        write (2,*) iii,gcorr_loc(iii)
9479 !d      enddo
9480       eello4=ekont*eel4
9481 !d      write (2,*) 'ekont',ekont
9482 !d      write (iout,*) 'eello4',ekont*eel4
9483       return
9484       end function eello4
9485 !-----------------------------------------------------------------------------
9486       real(kind=8) function eello5(i,j,k,l,jj,kk)
9487 !      implicit real*8 (a-h,o-z)
9488 !      include 'DIMENSIONS'
9489 !      include 'COMMON.IOUNITS'
9490 !      include 'COMMON.CHAIN'
9491 !      include 'COMMON.DERIV'
9492 !      include 'COMMON.INTERACT'
9493 !      include 'COMMON.CONTACTS'
9494 !      include 'COMMON.TORSION'
9495 !      include 'COMMON.VAR'
9496 !      include 'COMMON.GEO'
9497       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9498       real(kind=8),dimension(2) :: vv
9499       real(kind=8),dimension(3) :: ggg1,ggg2
9500       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9501       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9502       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9503 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9504 !                                                                              C
9505 !                            Parallel chains                                   C
9506 !                                                                              C
9507 !          o             o                   o             o                   C
9508 !         /l\           / \             \   / \           / \   /              C
9509 !        /   \         /   \             \ /   \         /   \ /               C
9510 !       j| o |l1       | o |                o| o |         | o |o                C
9511 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9512 !      \i/   \         /   \ /             /   \         /   \                 C
9513 !       o    k1             o                                                  C
9514 !         (I)          (II)                (III)          (IV)                 C
9515 !                                                                              C
9516 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9517 !                                                                              C
9518 !                            Antiparallel chains                               C
9519 !                                                                              C
9520 !          o             o                   o             o                   C
9521 !         /j\           / \             \   / \           / \   /              C
9522 !        /   \         /   \             \ /   \         /   \ /               C
9523 !      j1| o |l        | o |                o| o |         | o |o                C
9524 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9525 !      \i/   \         /   \ /             /   \         /   \                 C
9526 !       o     k1            o                                                  C
9527 !         (I)          (II)                (III)          (IV)                 C
9528 !                                                                              C
9529 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9530 !                                                                              C
9531 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9532 !                                                                              C
9533 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9534 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9535 !d        eello5=0.0d0
9536 !d        return
9537 !d      endif
9538 !d      write (iout,*)
9539 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9540 !d     &   ' and',k,l
9541       itk=itortyp(itype(k,1))
9542       itl=itortyp(itype(l,1))
9543       itj=itortyp(itype(j,1))
9544       eello5_1=0.0d0
9545       eello5_2=0.0d0
9546       eello5_3=0.0d0
9547       eello5_4=0.0d0
9548 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9549 !d     &   eel5_3_num,eel5_4_num)
9550       do iii=1,2
9551         do kkk=1,5
9552           do lll=1,3
9553             derx(lll,kkk,iii)=0.0d0
9554           enddo
9555         enddo
9556       enddo
9557 !d      eij=facont_hb(jj,i)
9558 !d      ekl=facont_hb(kk,k)
9559 !d      ekont=eij*ekl
9560 !d      write (iout,*)'Contacts have occurred for peptide groups',
9561 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9562 !d      goto 1111
9563 ! Contribution from the graph I.
9564 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9565 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9566       call transpose2(EUg(1,1,k),auxmat(1,1))
9567       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9568       vv(1)=pizda(1,1)-pizda(2,2)
9569       vv(2)=pizda(1,2)+pizda(2,1)
9570       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9571        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9572 ! Explicit gradient in virtual-dihedral angles.
9573       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9574        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9575        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9576       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9577       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9578       vv(1)=pizda(1,1)-pizda(2,2)
9579       vv(2)=pizda(1,2)+pizda(2,1)
9580       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9581        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9582        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9583       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9584       vv(1)=pizda(1,1)-pizda(2,2)
9585       vv(2)=pizda(1,2)+pizda(2,1)
9586       if (l.eq.j+1) then
9587         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9588          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9589          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9590       else
9591         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9592          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9593          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9594       endif
9595 ! Cartesian gradient
9596       do iii=1,2
9597         do kkk=1,5
9598           do lll=1,3
9599             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9600               pizda(1,1))
9601             vv(1)=pizda(1,1)-pizda(2,2)
9602             vv(2)=pizda(1,2)+pizda(2,1)
9603             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9604              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9605              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9606           enddo
9607         enddo
9608       enddo
9609 !      goto 1112
9610 !1111  continue
9611 ! Contribution from graph II
9612       call transpose2(EE(1,1,itk),auxmat(1,1))
9613       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9614       vv(1)=pizda(1,1)+pizda(2,2)
9615       vv(2)=pizda(2,1)-pizda(1,2)
9616       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9617        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9618 ! Explicit gradient in virtual-dihedral angles.
9619       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9620        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9621       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9622       vv(1)=pizda(1,1)+pizda(2,2)
9623       vv(2)=pizda(2,1)-pizda(1,2)
9624       if (l.eq.j+1) then
9625         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9626          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9627          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9628       else
9629         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9630          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9631          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9632       endif
9633 ! Cartesian gradient
9634       do iii=1,2
9635         do kkk=1,5
9636           do lll=1,3
9637             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9638               pizda(1,1))
9639             vv(1)=pizda(1,1)+pizda(2,2)
9640             vv(2)=pizda(2,1)-pizda(1,2)
9641             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9642              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9643              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9644           enddo
9645         enddo
9646       enddo
9647 !d      goto 1112
9648 !d1111  continue
9649       if (l.eq.j+1) then
9650 !d        goto 1110
9651 ! Parallel orientation
9652 ! Contribution from graph III
9653         call transpose2(EUg(1,1,l),auxmat(1,1))
9654         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9655         vv(1)=pizda(1,1)-pizda(2,2)
9656         vv(2)=pizda(1,2)+pizda(2,1)
9657         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9658          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9659 ! Explicit gradient in virtual-dihedral angles.
9660         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9661          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9662          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9663         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9664         vv(1)=pizda(1,1)-pizda(2,2)
9665         vv(2)=pizda(1,2)+pizda(2,1)
9666         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9667          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9668          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9669         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9670         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9671         vv(1)=pizda(1,1)-pizda(2,2)
9672         vv(2)=pizda(1,2)+pizda(2,1)
9673         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9674          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9675          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9676 ! Cartesian gradient
9677         do iii=1,2
9678           do kkk=1,5
9679             do lll=1,3
9680               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9681                 pizda(1,1))
9682               vv(1)=pizda(1,1)-pizda(2,2)
9683               vv(2)=pizda(1,2)+pizda(2,1)
9684               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9685                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9686                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9687             enddo
9688           enddo
9689         enddo
9690 !d        goto 1112
9691 ! Contribution from graph IV
9692 !d1110    continue
9693         call transpose2(EE(1,1,itl),auxmat(1,1))
9694         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9695         vv(1)=pizda(1,1)+pizda(2,2)
9696         vv(2)=pizda(2,1)-pizda(1,2)
9697         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9698          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9699 ! Explicit gradient in virtual-dihedral angles.
9700         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9701          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9702         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9703         vv(1)=pizda(1,1)+pizda(2,2)
9704         vv(2)=pizda(2,1)-pizda(1,2)
9705         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9706          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9707          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9708 ! Cartesian gradient
9709         do iii=1,2
9710           do kkk=1,5
9711             do lll=1,3
9712               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9713                 pizda(1,1))
9714               vv(1)=pizda(1,1)+pizda(2,2)
9715               vv(2)=pizda(2,1)-pizda(1,2)
9716               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9717                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9718                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9719             enddo
9720           enddo
9721         enddo
9722       else
9723 ! Antiparallel orientation
9724 ! Contribution from graph III
9725 !        goto 1110
9726         call transpose2(EUg(1,1,j),auxmat(1,1))
9727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9728         vv(1)=pizda(1,1)-pizda(2,2)
9729         vv(2)=pizda(1,2)+pizda(2,1)
9730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9731          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9732 ! Explicit gradient in virtual-dihedral angles.
9733         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9734          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9735          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9736         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9737         vv(1)=pizda(1,1)-pizda(2,2)
9738         vv(2)=pizda(1,2)+pizda(2,1)
9739         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9740          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9741          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9742         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9743         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9744         vv(1)=pizda(1,1)-pizda(2,2)
9745         vv(2)=pizda(1,2)+pizda(2,1)
9746         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9747          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9748          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9749 ! Cartesian gradient
9750         do iii=1,2
9751           do kkk=1,5
9752             do lll=1,3
9753               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9754                 pizda(1,1))
9755               vv(1)=pizda(1,1)-pizda(2,2)
9756               vv(2)=pizda(1,2)+pizda(2,1)
9757               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9758                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9759                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9760             enddo
9761           enddo
9762         enddo
9763 !d        goto 1112
9764 ! Contribution from graph IV
9765 1110    continue
9766         call transpose2(EE(1,1,itj),auxmat(1,1))
9767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9768         vv(1)=pizda(1,1)+pizda(2,2)
9769         vv(2)=pizda(2,1)-pizda(1,2)
9770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9771          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9772 ! Explicit gradient in virtual-dihedral angles.
9773         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9774          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9775         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9776         vv(1)=pizda(1,1)+pizda(2,2)
9777         vv(2)=pizda(2,1)-pizda(1,2)
9778         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9779          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9780          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9781 ! Cartesian gradient
9782         do iii=1,2
9783           do kkk=1,5
9784             do lll=1,3
9785               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9786                 pizda(1,1))
9787               vv(1)=pizda(1,1)+pizda(2,2)
9788               vv(2)=pizda(2,1)-pizda(1,2)
9789               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9790                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9791                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9792             enddo
9793           enddo
9794         enddo
9795       endif
9796 1112  continue
9797       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9798 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9799 !d        write (2,*) 'ijkl',i,j,k,l
9800 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9801 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9802 !d      endif
9803 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9804 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9805 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9806 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9807       if (j.lt.nres-1) then
9808         j1=j+1
9809         j2=j-1
9810       else
9811         j1=j-1
9812         j2=j-2
9813       endif
9814       if (l.lt.nres-1) then
9815         l1=l+1
9816         l2=l-1
9817       else
9818         l1=l-1
9819         l2=l-2
9820       endif
9821 !d      eij=1.0d0
9822 !d      ekl=1.0d0
9823 !d      ekont=1.0d0
9824 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9825 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9826 !        summed up outside the subrouine as for the other subroutines
9827 !        handling long-range interactions. The old code is commented out
9828 !        with "cgrad" to keep track of changes.
9829       do ll=1,3
9830 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9831 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9832         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9833         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9834 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9835 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9836 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9837 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9838 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9839 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9840 !     &   gradcorr5ij,
9841 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9842 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9843 !grad        ghalf=0.5d0*ggg1(ll)
9844 !d        ghalf=0.0d0
9845         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9846         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9847         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9848         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9849         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9850         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9851 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9852 !grad        ghalf=0.5d0*ggg2(ll)
9853         ghalf=0.0d0
9854         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9855         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9856         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9857         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9858         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9859         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9860       enddo
9861 !d      goto 1112
9862 !grad      do m=i+1,j-1
9863 !grad        do ll=1,3
9864 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9865 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9866 !grad        enddo
9867 !grad      enddo
9868 !grad      do m=k+1,l-1
9869 !grad        do ll=1,3
9870 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9871 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9872 !grad        enddo
9873 !grad      enddo
9874 !1112  continue
9875 !grad      do m=i+2,j2
9876 !grad        do ll=1,3
9877 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9878 !grad        enddo
9879 !grad      enddo
9880 !grad      do m=k+2,l2
9881 !grad        do ll=1,3
9882 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9883 !grad        enddo
9884 !grad      enddo
9885 !d      do iii=1,nres-3
9886 !d        write (2,*) iii,g_corr5_loc(iii)
9887 !d      enddo
9888       eello5=ekont*eel5
9889 !d      write (2,*) 'ekont',ekont
9890 !d      write (iout,*) 'eello5',ekont*eel5
9891       return
9892       end function eello5
9893 !-----------------------------------------------------------------------------
9894       real(kind=8) function eello6(i,j,k,l,jj,kk)
9895 !      implicit real*8 (a-h,o-z)
9896 !      include 'DIMENSIONS'
9897 !      include 'COMMON.IOUNITS'
9898 !      include 'COMMON.CHAIN'
9899 !      include 'COMMON.DERIV'
9900 !      include 'COMMON.INTERACT'
9901 !      include 'COMMON.CONTACTS'
9902 !      include 'COMMON.TORSION'
9903 !      include 'COMMON.VAR'
9904 !      include 'COMMON.GEO'
9905 !      include 'COMMON.FFIELD'
9906       real(kind=8),dimension(3) :: ggg1,ggg2
9907       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9908                    eello6_6,eel6
9909       real(kind=8) :: gradcorr6ij,gradcorr6kl
9910       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9911 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9912 !d        eello6=0.0d0
9913 !d        return
9914 !d      endif
9915 !d      write (iout,*)
9916 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9917 !d     &   ' and',k,l
9918       eello6_1=0.0d0
9919       eello6_2=0.0d0
9920       eello6_3=0.0d0
9921       eello6_4=0.0d0
9922       eello6_5=0.0d0
9923       eello6_6=0.0d0
9924 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9925 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9926       do iii=1,2
9927         do kkk=1,5
9928           do lll=1,3
9929             derx(lll,kkk,iii)=0.0d0
9930           enddo
9931         enddo
9932       enddo
9933 !d      eij=facont_hb(jj,i)
9934 !d      ekl=facont_hb(kk,k)
9935 !d      ekont=eij*ekl
9936 !d      eij=1.0d0
9937 !d      ekl=1.0d0
9938 !d      ekont=1.0d0
9939       if (l.eq.j+1) then
9940         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9941         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9942         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9943         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9944         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9945         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9946       else
9947         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9948         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9949         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9950         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9951         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9952           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9953         else
9954           eello6_5=0.0d0
9955         endif
9956         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9957       endif
9958 ! If turn contributions are considered, they will be handled separately.
9959       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9960 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9961 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9962 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9963 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9964 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9965 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9966 !d      goto 1112
9967       if (j.lt.nres-1) then
9968         j1=j+1
9969         j2=j-1
9970       else
9971         j1=j-1
9972         j2=j-2
9973       endif
9974       if (l.lt.nres-1) then
9975         l1=l+1
9976         l2=l-1
9977       else
9978         l1=l-1
9979         l2=l-2
9980       endif
9981       do ll=1,3
9982 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9983 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9984 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9985 !grad        ghalf=0.5d0*ggg1(ll)
9986 !d        ghalf=0.0d0
9987         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9988         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9989         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9990         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9991         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9992         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9993         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9994         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9995 !grad        ghalf=0.5d0*ggg2(ll)
9996 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9997 !d        ghalf=0.0d0
9998         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9999         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10000         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10001         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10002         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10003         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10004       enddo
10005 !d      goto 1112
10006 !grad      do m=i+1,j-1
10007 !grad        do ll=1,3
10008 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10009 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10010 !grad        enddo
10011 !grad      enddo
10012 !grad      do m=k+1,l-1
10013 !grad        do ll=1,3
10014 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10015 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10016 !grad        enddo
10017 !grad      enddo
10018 !grad1112  continue
10019 !grad      do m=i+2,j2
10020 !grad        do ll=1,3
10021 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10022 !grad        enddo
10023 !grad      enddo
10024 !grad      do m=k+2,l2
10025 !grad        do ll=1,3
10026 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10027 !grad        enddo
10028 !grad      enddo
10029 !d      do iii=1,nres-3
10030 !d        write (2,*) iii,g_corr6_loc(iii)
10031 !d      enddo
10032       eello6=ekont*eel6
10033 !d      write (2,*) 'ekont',ekont
10034 !d      write (iout,*) 'eello6',ekont*eel6
10035       return
10036       end function eello6
10037 !-----------------------------------------------------------------------------
10038       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10039       use comm_kut
10040 !      implicit real*8 (a-h,o-z)
10041 !      include 'DIMENSIONS'
10042 !      include 'COMMON.IOUNITS'
10043 !      include 'COMMON.CHAIN'
10044 !      include 'COMMON.DERIV'
10045 !      include 'COMMON.INTERACT'
10046 !      include 'COMMON.CONTACTS'
10047 !      include 'COMMON.TORSION'
10048 !      include 'COMMON.VAR'
10049 !      include 'COMMON.GEO'
10050       real(kind=8),dimension(2) :: vv,vv1
10051       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10052       logical :: swap
10053 !el      logical :: lprn
10054 !el      common /kutas/ lprn
10055       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10056       real(kind=8) :: s1,s2,s3,s4,s5
10057 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10058 !                                                                              C
10059 !      Parallel       Antiparallel                                             C
10060 !                                                                              C
10061 !          o             o                                                     C
10062 !         /l\           /j\                                                    C
10063 !        /   \         /   \                                                   C
10064 !       /| o |         | o |\                                                  C
10065 !     \ j|/k\|  /   \  |/k\|l /                                                C
10066 !      \ /   \ /     \ /   \ /                                                 C
10067 !       o     o       o     o                                                  C
10068 !       i             i                                                        C
10069 !                                                                              C
10070 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10071       itk=itortyp(itype(k,1))
10072       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10073       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10074       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10075       call transpose2(EUgC(1,1,k),auxmat(1,1))
10076       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10077       vv1(1)=pizda1(1,1)-pizda1(2,2)
10078       vv1(2)=pizda1(1,2)+pizda1(2,1)
10079       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10080       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10081       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10082       s5=scalar2(vv(1),Dtobr2(1,i))
10083 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10084       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10085       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10086        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10087        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10088        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10089        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10090        +scalar2(vv(1),Dtobr2der(1,i)))
10091       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10092       vv1(1)=pizda1(1,1)-pizda1(2,2)
10093       vv1(2)=pizda1(1,2)+pizda1(2,1)
10094       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10095       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10096       if (l.eq.j+1) then
10097         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10098        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10099        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10100        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10101        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10102       else
10103         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10104        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10105        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10106        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10107        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10108       endif
10109       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10110       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10111       vv1(1)=pizda1(1,1)-pizda1(2,2)
10112       vv1(2)=pizda1(1,2)+pizda1(2,1)
10113       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10114        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10115        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10116        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10117       do iii=1,2
10118         if (swap) then
10119           ind=3-iii
10120         else
10121           ind=iii
10122         endif
10123         do kkk=1,5
10124           do lll=1,3
10125             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10126             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10127             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10128             call transpose2(EUgC(1,1,k),auxmat(1,1))
10129             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10130               pizda1(1,1))
10131             vv1(1)=pizda1(1,1)-pizda1(2,2)
10132             vv1(2)=pizda1(1,2)+pizda1(2,1)
10133             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10134             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10135              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10136             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10137              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10138             s5=scalar2(vv(1),Dtobr2(1,i))
10139             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10140           enddo
10141         enddo
10142       enddo
10143       return
10144       end function eello6_graph1
10145 !-----------------------------------------------------------------------------
10146       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10147       use comm_kut
10148 !      implicit real*8 (a-h,o-z)
10149 !      include 'DIMENSIONS'
10150 !      include 'COMMON.IOUNITS'
10151 !      include 'COMMON.CHAIN'
10152 !      include 'COMMON.DERIV'
10153 !      include 'COMMON.INTERACT'
10154 !      include 'COMMON.CONTACTS'
10155 !      include 'COMMON.TORSION'
10156 !      include 'COMMON.VAR'
10157 !      include 'COMMON.GEO'
10158       logical :: swap
10159       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10160       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10161 !el      logical :: lprn
10162 !el      common /kutas/ lprn
10163       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10164       real(kind=8) :: s2,s3,s4
10165 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10166 !                                                                              C
10167 !      Parallel       Antiparallel                                             C
10168 !                                                                              C
10169 !          o             o                                                     C
10170 !     \   /l\           /j\   /                                                C
10171 !      \ /   \         /   \ /                                                 C
10172 !       o| o |         | o |o                                                  C
10173 !     \ j|/k\|      \  |/k\|l                                                  C
10174 !      \ /   \       \ /   \                                                   C
10175 !       o             o                                                        C
10176 !       i             i                                                        C
10177 !                                                                              C
10178 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10179 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10180 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10181 !           but not in a cluster cumulant
10182 #ifdef MOMENT
10183       s1=dip(1,jj,i)*dip(1,kk,k)
10184 #endif
10185       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10186       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10187       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10188       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10189       call transpose2(EUg(1,1,k),auxmat(1,1))
10190       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10191       vv(1)=pizda(1,1)-pizda(2,2)
10192       vv(2)=pizda(1,2)+pizda(2,1)
10193       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10194 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10195 #ifdef MOMENT
10196       eello6_graph2=-(s1+s2+s3+s4)
10197 #else
10198       eello6_graph2=-(s2+s3+s4)
10199 #endif
10200 !      eello6_graph2=-s3
10201 ! Derivatives in gamma(i-1)
10202       if (i.gt.1) then
10203 #ifdef MOMENT
10204         s1=dipderg(1,jj,i)*dip(1,kk,k)
10205 #endif
10206         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10207         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10208         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10209         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10210 #ifdef MOMENT
10211         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10212 #else
10213         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10214 #endif
10215 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10216       endif
10217 ! Derivatives in gamma(k-1)
10218 #ifdef MOMENT
10219       s1=dip(1,jj,i)*dipderg(1,kk,k)
10220 #endif
10221       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10222       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10223       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10224       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10225       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10226       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10227       vv(1)=pizda(1,1)-pizda(2,2)
10228       vv(2)=pizda(1,2)+pizda(2,1)
10229       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10230 #ifdef MOMENT
10231       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10232 #else
10233       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10234 #endif
10235 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10236 ! Derivatives in gamma(j-1) or gamma(l-1)
10237       if (j.gt.1) then
10238 #ifdef MOMENT
10239         s1=dipderg(3,jj,i)*dip(1,kk,k)
10240 #endif
10241         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10242         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10243         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10244         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10245         vv(1)=pizda(1,1)-pizda(2,2)
10246         vv(2)=pizda(1,2)+pizda(2,1)
10247         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10248 #ifdef MOMENT
10249         if (swap) then
10250           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10251         else
10252           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10253         endif
10254 #endif
10255         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10256 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10257       endif
10258 ! Derivatives in gamma(l-1) or gamma(j-1)
10259       if (l.gt.1) then
10260 #ifdef MOMENT
10261         s1=dip(1,jj,i)*dipderg(3,kk,k)
10262 #endif
10263         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10264         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10265         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10266         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10267         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10268         vv(1)=pizda(1,1)-pizda(2,2)
10269         vv(2)=pizda(1,2)+pizda(2,1)
10270         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10271 #ifdef MOMENT
10272         if (swap) then
10273           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10274         else
10275           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10276         endif
10277 #endif
10278         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10279 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10280       endif
10281 ! Cartesian derivatives.
10282       if (lprn) then
10283         write (2,*) 'In eello6_graph2'
10284         do iii=1,2
10285           write (2,*) 'iii=',iii
10286           do kkk=1,5
10287             write (2,*) 'kkk=',kkk
10288             do jjj=1,2
10289               write (2,'(3(2f10.5),5x)') &
10290               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10291             enddo
10292           enddo
10293         enddo
10294       endif
10295       do iii=1,2
10296         do kkk=1,5
10297           do lll=1,3
10298 #ifdef MOMENT
10299             if (iii.eq.1) then
10300               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10301             else
10302               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10303             endif
10304 #endif
10305             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10306               auxvec(1))
10307             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10308             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10309               auxvec(1))
10310             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10311             call transpose2(EUg(1,1,k),auxmat(1,1))
10312             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10313               pizda(1,1))
10314             vv(1)=pizda(1,1)-pizda(2,2)
10315             vv(2)=pizda(1,2)+pizda(2,1)
10316             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10317 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10318 #ifdef MOMENT
10319             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10320 #else
10321             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10322 #endif
10323             if (swap) then
10324               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10325             else
10326               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10327             endif
10328           enddo
10329         enddo
10330       enddo
10331       return
10332       end function eello6_graph2
10333 !-----------------------------------------------------------------------------
10334       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10335 !      implicit real*8 (a-h,o-z)
10336 !      include 'DIMENSIONS'
10337 !      include 'COMMON.IOUNITS'
10338 !      include 'COMMON.CHAIN'
10339 !      include 'COMMON.DERIV'
10340 !      include 'COMMON.INTERACT'
10341 !      include 'COMMON.CONTACTS'
10342 !      include 'COMMON.TORSION'
10343 !      include 'COMMON.VAR'
10344 !      include 'COMMON.GEO'
10345       real(kind=8),dimension(2) :: vv,auxvec
10346       real(kind=8),dimension(2,2) :: pizda,auxmat
10347       logical :: swap
10348       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10349       real(kind=8) :: s1,s2,s3,s4
10350 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10351 !                                                                              C
10352 !      Parallel       Antiparallel                                             C
10353 !                                                                              C
10354 !          o             o                                                     C
10355 !         /l\   /   \   /j\                                                    C
10356 !        /   \ /     \ /   \                                                   C
10357 !       /| o |o       o| o |\                                                  C
10358 !       j|/k\|  /      |/k\|l /                                                C
10359 !        /   \ /       /   \ /                                                 C
10360 !       /     o       /     o                                                  C
10361 !       i             i                                                        C
10362 !                                                                              C
10363 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10364 !
10365 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10366 !           energy moment and not to the cluster cumulant.
10367       iti=itortyp(itype(i,1))
10368       if (j.lt.nres-1) then
10369         itj1=itortyp(itype(j+1,1))
10370       else
10371         itj1=ntortyp+1
10372       endif
10373       itk=itortyp(itype(k,1))
10374       itk1=itortyp(itype(k+1,1))
10375       if (l.lt.nres-1) then
10376         itl1=itortyp(itype(l+1,1))
10377       else
10378         itl1=ntortyp+1
10379       endif
10380 #ifdef MOMENT
10381       s1=dip(4,jj,i)*dip(4,kk,k)
10382 #endif
10383       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10384       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10385       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10386       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10387       call transpose2(EE(1,1,itk),auxmat(1,1))
10388       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10389       vv(1)=pizda(1,1)+pizda(2,2)
10390       vv(2)=pizda(2,1)-pizda(1,2)
10391       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10392 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10393 !d     & "sum",-(s2+s3+s4)
10394 #ifdef MOMENT
10395       eello6_graph3=-(s1+s2+s3+s4)
10396 #else
10397       eello6_graph3=-(s2+s3+s4)
10398 #endif
10399 !      eello6_graph3=-s4
10400 ! Derivatives in gamma(k-1)
10401       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10402       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10403       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10404       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10405 ! Derivatives in gamma(l-1)
10406       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10407       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10408       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10409       vv(1)=pizda(1,1)+pizda(2,2)
10410       vv(2)=pizda(2,1)-pizda(1,2)
10411       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10412       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10413 ! Cartesian derivatives.
10414       do iii=1,2
10415         do kkk=1,5
10416           do lll=1,3
10417 #ifdef MOMENT
10418             if (iii.eq.1) then
10419               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10420             else
10421               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10422             endif
10423 #endif
10424             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10425               auxvec(1))
10426             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10427             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10428               auxvec(1))
10429             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10430             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10431               pizda(1,1))
10432             vv(1)=pizda(1,1)+pizda(2,2)
10433             vv(2)=pizda(2,1)-pizda(1,2)
10434             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10435 #ifdef MOMENT
10436             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10437 #else
10438             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10439 #endif
10440             if (swap) then
10441               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10442             else
10443               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10444             endif
10445 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10446           enddo
10447         enddo
10448       enddo
10449       return
10450       end function eello6_graph3
10451 !-----------------------------------------------------------------------------
10452       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10453 !      implicit real*8 (a-h,o-z)
10454 !      include 'DIMENSIONS'
10455 !      include 'COMMON.IOUNITS'
10456 !      include 'COMMON.CHAIN'
10457 !      include 'COMMON.DERIV'
10458 !      include 'COMMON.INTERACT'
10459 !      include 'COMMON.CONTACTS'
10460 !      include 'COMMON.TORSION'
10461 !      include 'COMMON.VAR'
10462 !      include 'COMMON.GEO'
10463 !      include 'COMMON.FFIELD'
10464       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10465       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10466       logical :: swap
10467       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10468               iii,kkk,lll
10469       real(kind=8) :: s1,s2,s3,s4
10470 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10471 !                                                                              C
10472 !      Parallel       Antiparallel                                             C
10473 !                                                                              C
10474 !          o             o                                                     C
10475 !         /l\   /   \   /j\                                                    C
10476 !        /   \ /     \ /   \                                                   C
10477 !       /| o |o       o| o |\                                                  C
10478 !     \ j|/k\|      \  |/k\|l                                                  C
10479 !      \ /   \       \ /   \                                                   C
10480 !       o     \       o     \                                                  C
10481 !       i             i                                                        C
10482 !                                                                              C
10483 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10484 !
10485 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10486 !           energy moment and not to the cluster cumulant.
10487 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10488       iti=itortyp(itype(i,1))
10489       itj=itortyp(itype(j,1))
10490       if (j.lt.nres-1) then
10491         itj1=itortyp(itype(j+1,1))
10492       else
10493         itj1=ntortyp+1
10494       endif
10495       itk=itortyp(itype(k,1))
10496       if (k.lt.nres-1) then
10497         itk1=itortyp(itype(k+1,1))
10498       else
10499         itk1=ntortyp+1
10500       endif
10501       itl=itortyp(itype(l,1))
10502       if (l.lt.nres-1) then
10503         itl1=itortyp(itype(l+1,1))
10504       else
10505         itl1=ntortyp+1
10506       endif
10507 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10508 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10509 !d     & ' itl',itl,' itl1',itl1
10510 #ifdef MOMENT
10511       if (imat.eq.1) then
10512         s1=dip(3,jj,i)*dip(3,kk,k)
10513       else
10514         s1=dip(2,jj,j)*dip(2,kk,l)
10515       endif
10516 #endif
10517       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10518       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10519       if (j.eq.l+1) then
10520         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10521         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10522       else
10523         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10524         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10525       endif
10526       call transpose2(EUg(1,1,k),auxmat(1,1))
10527       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10528       vv(1)=pizda(1,1)-pizda(2,2)
10529       vv(2)=pizda(2,1)+pizda(1,2)
10530       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10531 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10532 #ifdef MOMENT
10533       eello6_graph4=-(s1+s2+s3+s4)
10534 #else
10535       eello6_graph4=-(s2+s3+s4)
10536 #endif
10537 ! Derivatives in gamma(i-1)
10538       if (i.gt.1) then
10539 #ifdef MOMENT
10540         if (imat.eq.1) then
10541           s1=dipderg(2,jj,i)*dip(3,kk,k)
10542         else
10543           s1=dipderg(4,jj,j)*dip(2,kk,l)
10544         endif
10545 #endif
10546         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10547         if (j.eq.l+1) then
10548           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10549           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10550         else
10551           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10552           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10553         endif
10554         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10555         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10556 !d          write (2,*) 'turn6 derivatives'
10557 #ifdef MOMENT
10558           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10559 #else
10560           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10561 #endif
10562         else
10563 #ifdef MOMENT
10564           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10565 #else
10566           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10567 #endif
10568         endif
10569       endif
10570 ! Derivatives in gamma(k-1)
10571 #ifdef MOMENT
10572       if (imat.eq.1) then
10573         s1=dip(3,jj,i)*dipderg(2,kk,k)
10574       else
10575         s1=dip(2,jj,j)*dipderg(4,kk,l)
10576       endif
10577 #endif
10578       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10579       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10580       if (j.eq.l+1) then
10581         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10582         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10583       else
10584         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10585         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10586       endif
10587       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10588       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10589       vv(1)=pizda(1,1)-pizda(2,2)
10590       vv(2)=pizda(2,1)+pizda(1,2)
10591       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10592       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10593 #ifdef MOMENT
10594         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10595 #else
10596         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10597 #endif
10598       else
10599 #ifdef MOMENT
10600         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10601 #else
10602         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10603 #endif
10604       endif
10605 ! Derivatives in gamma(j-1) or gamma(l-1)
10606       if (l.eq.j+1 .and. l.gt.1) then
10607         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10608         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10609         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10610         vv(1)=pizda(1,1)-pizda(2,2)
10611         vv(2)=pizda(2,1)+pizda(1,2)
10612         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10613         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10614       else if (j.gt.1) then
10615         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10616         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10617         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10618         vv(1)=pizda(1,1)-pizda(2,2)
10619         vv(2)=pizda(2,1)+pizda(1,2)
10620         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10621         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10622           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10623         else
10624           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10625         endif
10626       endif
10627 ! Cartesian derivatives.
10628       do iii=1,2
10629         do kkk=1,5
10630           do lll=1,3
10631 #ifdef MOMENT
10632             if (iii.eq.1) then
10633               if (imat.eq.1) then
10634                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10635               else
10636                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10637               endif
10638             else
10639               if (imat.eq.1) then
10640                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10641               else
10642                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10643               endif
10644             endif
10645 #endif
10646             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10647               auxvec(1))
10648             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10649             if (j.eq.l+1) then
10650               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10651                 b1(1,itj1),auxvec(1))
10652               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10653             else
10654               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10655                 b1(1,itl1),auxvec(1))
10656               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10657             endif
10658             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10659               pizda(1,1))
10660             vv(1)=pizda(1,1)-pizda(2,2)
10661             vv(2)=pizda(2,1)+pizda(1,2)
10662             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10663             if (swap) then
10664               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10665 #ifdef MOMENT
10666                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10667                    -(s1+s2+s4)
10668 #else
10669                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10670                    -(s2+s4)
10671 #endif
10672                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10673               else
10674 #ifdef MOMENT
10675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10676 #else
10677                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10678 #endif
10679                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10680               endif
10681             else
10682 #ifdef MOMENT
10683               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10684 #else
10685               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10686 #endif
10687               if (l.eq.j+1) then
10688                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10689               else
10690                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10691               endif
10692             endif
10693           enddo
10694         enddo
10695       enddo
10696       return
10697       end function eello6_graph4
10698 !-----------------------------------------------------------------------------
10699       real(kind=8) function eello_turn6(i,jj,kk)
10700 !      implicit real*8 (a-h,o-z)
10701 !      include 'DIMENSIONS'
10702 !      include 'COMMON.IOUNITS'
10703 !      include 'COMMON.CHAIN'
10704 !      include 'COMMON.DERIV'
10705 !      include 'COMMON.INTERACT'
10706 !      include 'COMMON.CONTACTS'
10707 !      include 'COMMON.TORSION'
10708 !      include 'COMMON.VAR'
10709 !      include 'COMMON.GEO'
10710       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10711       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10712       real(kind=8),dimension(3) :: ggg1,ggg2
10713       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10714       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10715 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10716 !           the respective energy moment and not to the cluster cumulant.
10717 !el local variables
10718       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10719       integer :: j1,j2,l1,l2,ll
10720       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10721       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10722       s1=0.0d0
10723       s8=0.0d0
10724       s13=0.0d0
10725 !
10726       eello_turn6=0.0d0
10727       j=i+4
10728       k=i+1
10729       l=i+3
10730       iti=itortyp(itype(i,1))
10731       itk=itortyp(itype(k,1))
10732       itk1=itortyp(itype(k+1,1))
10733       itl=itortyp(itype(l,1))
10734       itj=itortyp(itype(j,1))
10735 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10736 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10737 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10738 !d        eello6=0.0d0
10739 !d        return
10740 !d      endif
10741 !d      write (iout,*)
10742 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10743 !d     &   ' and',k,l
10744 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10745       do iii=1,2
10746         do kkk=1,5
10747           do lll=1,3
10748             derx_turn(lll,kkk,iii)=0.0d0
10749           enddo
10750         enddo
10751       enddo
10752 !d      eij=1.0d0
10753 !d      ekl=1.0d0
10754 !d      ekont=1.0d0
10755       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10756 !d      eello6_5=0.0d0
10757 !d      write (2,*) 'eello6_5',eello6_5
10758 #ifdef MOMENT
10759       call transpose2(AEA(1,1,1),auxmat(1,1))
10760       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10761       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10762       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10763 #endif
10764       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10765       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10766       s2 = scalar2(b1(1,itk),vtemp1(1))
10767 #ifdef MOMENT
10768       call transpose2(AEA(1,1,2),atemp(1,1))
10769       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10770       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10771       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10772 #endif
10773       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10774       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10775       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10776 #ifdef MOMENT
10777       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10778       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10779       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10780       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10781       ss13 = scalar2(b1(1,itk),vtemp4(1))
10782       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10783 #endif
10784 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10785 !      s1=0.0d0
10786 !      s2=0.0d0
10787 !      s8=0.0d0
10788 !      s12=0.0d0
10789 !      s13=0.0d0
10790       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10791 ! Derivatives in gamma(i+2)
10792       s1d =0.0d0
10793       s8d =0.0d0
10794 #ifdef MOMENT
10795       call transpose2(AEA(1,1,1),auxmatd(1,1))
10796       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10797       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10798       call transpose2(AEAderg(1,1,2),atempd(1,1))
10799       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10800       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10801 #endif
10802       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10803       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10804       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10805 !      s1d=0.0d0
10806 !      s2d=0.0d0
10807 !      s8d=0.0d0
10808 !      s12d=0.0d0
10809 !      s13d=0.0d0
10810       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10811 ! Derivatives in gamma(i+3)
10812 #ifdef MOMENT
10813       call transpose2(AEA(1,1,1),auxmatd(1,1))
10814       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10815       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10816       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10817 #endif
10818       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10819       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10820       s2d = scalar2(b1(1,itk),vtemp1d(1))
10821 #ifdef MOMENT
10822       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10823       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10824 #endif
10825       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10826 #ifdef MOMENT
10827       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10828       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10829       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10830 #endif
10831 !      s1d=0.0d0
10832 !      s2d=0.0d0
10833 !      s8d=0.0d0
10834 !      s12d=0.0d0
10835 !      s13d=0.0d0
10836 #ifdef MOMENT
10837       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10838                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10839 #else
10840       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10841                     -0.5d0*ekont*(s2d+s12d)
10842 #endif
10843 ! Derivatives in gamma(i+4)
10844       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10845       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10846       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10847 #ifdef MOMENT
10848       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10849       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10850       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10851 #endif
10852 !      s1d=0.0d0
10853 !      s2d=0.0d0
10854 !      s8d=0.0d0
10855 !      s12d=0.0d0
10856 !      s13d=0.0d0
10857 #ifdef MOMENT
10858       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10859 #else
10860       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10861 #endif
10862 ! Derivatives in gamma(i+5)
10863 #ifdef MOMENT
10864       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10865       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10866       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10867 #endif
10868       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10869       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10870       s2d = scalar2(b1(1,itk),vtemp1d(1))
10871 #ifdef MOMENT
10872       call transpose2(AEA(1,1,2),atempd(1,1))
10873       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10874       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10875 #endif
10876       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10877       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10878 #ifdef MOMENT
10879       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10880       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10881       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10882 #endif
10883 !      s1d=0.0d0
10884 !      s2d=0.0d0
10885 !      s8d=0.0d0
10886 !      s12d=0.0d0
10887 !      s13d=0.0d0
10888 #ifdef MOMENT
10889       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10890                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10891 #else
10892       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10893                     -0.5d0*ekont*(s2d+s12d)
10894 #endif
10895 ! Cartesian derivatives
10896       do iii=1,2
10897         do kkk=1,5
10898           do lll=1,3
10899 #ifdef MOMENT
10900             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10901             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10902             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10903 #endif
10904             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10905             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10906                 vtemp1d(1))
10907             s2d = scalar2(b1(1,itk),vtemp1d(1))
10908 #ifdef MOMENT
10909             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10910             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10911             s8d = -(atempd(1,1)+atempd(2,2))* &
10912                  scalar2(cc(1,1,itl),vtemp2(1))
10913 #endif
10914             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10915                  auxmatd(1,1))
10916             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10917             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10918 !      s1d=0.0d0
10919 !      s2d=0.0d0
10920 !      s8d=0.0d0
10921 !      s12d=0.0d0
10922 !      s13d=0.0d0
10923 #ifdef MOMENT
10924             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10925               - 0.5d0*(s1d+s2d)
10926 #else
10927             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10928               - 0.5d0*s2d
10929 #endif
10930 #ifdef MOMENT
10931             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10932               - 0.5d0*(s8d+s12d)
10933 #else
10934             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10935               - 0.5d0*s12d
10936 #endif
10937           enddo
10938         enddo
10939       enddo
10940 #ifdef MOMENT
10941       do kkk=1,5
10942         do lll=1,3
10943           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10944             achuj_tempd(1,1))
10945           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10946           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10947           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10948           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10949           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10950             vtemp4d(1))
10951           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10952           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10953           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10954         enddo
10955       enddo
10956 #endif
10957 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10958 !d     &  16*eel_turn6_num
10959 !d      goto 1112
10960       if (j.lt.nres-1) then
10961         j1=j+1
10962         j2=j-1
10963       else
10964         j1=j-1
10965         j2=j-2
10966       endif
10967       if (l.lt.nres-1) then
10968         l1=l+1
10969         l2=l-1
10970       else
10971         l1=l-1
10972         l2=l-2
10973       endif
10974       do ll=1,3
10975 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10976 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10977 !grad        ghalf=0.5d0*ggg1(ll)
10978 !d        ghalf=0.0d0
10979         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10980         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10981         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10982           +ekont*derx_turn(ll,2,1)
10983         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10984         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10985           +ekont*derx_turn(ll,4,1)
10986         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10987         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10988         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10989 !grad        ghalf=0.5d0*ggg2(ll)
10990 !d        ghalf=0.0d0
10991         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10992           +ekont*derx_turn(ll,2,2)
10993         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10994         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10995           +ekont*derx_turn(ll,4,2)
10996         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10997         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10998         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10999       enddo
11000 !d      goto 1112
11001 !grad      do m=i+1,j-1
11002 !grad        do ll=1,3
11003 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11004 !grad        enddo
11005 !grad      enddo
11006 !grad      do m=k+1,l-1
11007 !grad        do ll=1,3
11008 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11009 !grad        enddo
11010 !grad      enddo
11011 !grad1112  continue
11012 !grad      do m=i+2,j2
11013 !grad        do ll=1,3
11014 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11015 !grad        enddo
11016 !grad      enddo
11017 !grad      do m=k+2,l2
11018 !grad        do ll=1,3
11019 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11020 !grad        enddo
11021 !grad      enddo
11022 !d      do iii=1,nres-3
11023 !d        write (2,*) iii,g_corr6_loc(iii)
11024 !d      enddo
11025       eello_turn6=ekont*eel_turn6
11026 !d      write (2,*) 'ekont',ekont
11027 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11028       return
11029       end function eello_turn6
11030 !-----------------------------------------------------------------------------
11031       subroutine MATVEC2(A1,V1,V2)
11032 !DIR$ INLINEALWAYS MATVEC2
11033 #ifndef OSF
11034 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11035 #endif
11036 !      implicit real*8 (a-h,o-z)
11037 !      include 'DIMENSIONS'
11038       real(kind=8),dimension(2) :: V1,V2
11039       real(kind=8),dimension(2,2) :: A1
11040       real(kind=8) :: vaux1,vaux2
11041 !      DO 1 I=1,2
11042 !        VI=0.0
11043 !        DO 3 K=1,2
11044 !    3     VI=VI+A1(I,K)*V1(K)
11045 !        Vaux(I)=VI
11046 !    1 CONTINUE
11047
11048       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11049       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11050
11051       v2(1)=vaux1
11052       v2(2)=vaux2
11053       end subroutine MATVEC2
11054 !-----------------------------------------------------------------------------
11055       subroutine MATMAT2(A1,A2,A3)
11056 #ifndef OSF
11057 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11058 #endif
11059 !      implicit real*8 (a-h,o-z)
11060 !      include 'DIMENSIONS'
11061       real(kind=8),dimension(2,2) :: A1,A2,A3
11062       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11063 !      DIMENSION AI3(2,2)
11064 !        DO  J=1,2
11065 !          A3IJ=0.0
11066 !          DO K=1,2
11067 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11068 !          enddo
11069 !          A3(I,J)=A3IJ
11070 !       enddo
11071 !      enddo
11072
11073       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11074       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11075       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11076       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11077
11078       A3(1,1)=AI3_11
11079       A3(2,1)=AI3_21
11080       A3(1,2)=AI3_12
11081       A3(2,2)=AI3_22
11082       end subroutine MATMAT2
11083 !-----------------------------------------------------------------------------
11084       real(kind=8) function scalar2(u,v)
11085 !DIR$ INLINEALWAYS scalar2
11086       implicit none
11087       real(kind=8),dimension(2) :: u,v
11088       real(kind=8) :: sc
11089       integer :: i
11090       scalar2=u(1)*v(1)+u(2)*v(2)
11091       return
11092       end function scalar2
11093 !-----------------------------------------------------------------------------
11094       subroutine transpose2(a,at)
11095 !DIR$ INLINEALWAYS transpose2
11096 #ifndef OSF
11097 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11098 #endif
11099       implicit none
11100       real(kind=8),dimension(2,2) :: a,at
11101       at(1,1)=a(1,1)
11102       at(1,2)=a(2,1)
11103       at(2,1)=a(1,2)
11104       at(2,2)=a(2,2)
11105       return
11106       end subroutine transpose2
11107 !-----------------------------------------------------------------------------
11108       subroutine transpose(n,a,at)
11109       implicit none
11110       integer :: n,i,j
11111       real(kind=8),dimension(n,n) :: a,at
11112       do i=1,n
11113         do j=1,n
11114           at(j,i)=a(i,j)
11115         enddo
11116       enddo
11117       return
11118       end subroutine transpose
11119 !-----------------------------------------------------------------------------
11120       subroutine prodmat3(a1,a2,kk,transp,prod)
11121 !DIR$ INLINEALWAYS prodmat3
11122 #ifndef OSF
11123 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11124 #endif
11125       implicit none
11126       integer :: i,j
11127       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11128       logical :: transp
11129 !rc      double precision auxmat(2,2),prod_(2,2)
11130
11131       if (transp) then
11132 !rc        call transpose2(kk(1,1),auxmat(1,1))
11133 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11134 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11135
11136            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11137        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11138            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11139        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11140            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11141        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11142            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11143        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11144
11145       else
11146 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11147 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11148
11149            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11150         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11151            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11152         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11153            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11154         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11155            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11156         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11157
11158       endif
11159 !      call transpose2(a2(1,1),a2t(1,1))
11160
11161 !rc      print *,transp
11162 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11163 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11164
11165       return
11166       end subroutine prodmat3
11167 !-----------------------------------------------------------------------------
11168 ! energy_p_new_barrier.F
11169 !-----------------------------------------------------------------------------
11170       subroutine sum_gradient
11171 !      implicit real*8 (a-h,o-z)
11172       use io_base, only: pdbout
11173 !      include 'DIMENSIONS'
11174 #ifndef ISNAN
11175       external proc_proc
11176 #ifdef WINPGI
11177 !MS$ATTRIBUTES C ::  proc_proc
11178 #endif
11179 #endif
11180 #ifdef MPI
11181       include 'mpif.h'
11182 #endif
11183       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11184                    gloc_scbuf !(3,maxres)
11185
11186       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11187 !#endif
11188 !el local variables
11189       integer :: i,j,k,ierror,ierr
11190       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11191                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11192                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11193                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11194                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11195                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11196                    gsccorr_max,gsccorrx_max,time00
11197
11198 !      include 'COMMON.SETUP'
11199 !      include 'COMMON.IOUNITS'
11200 !      include 'COMMON.FFIELD'
11201 !      include 'COMMON.DERIV'
11202 !      include 'COMMON.INTERACT'
11203 !      include 'COMMON.SBRIDGE'
11204 !      include 'COMMON.CHAIN'
11205 !      include 'COMMON.VAR'
11206 !      include 'COMMON.CONTROL'
11207 !      include 'COMMON.TIME1'
11208 !      include 'COMMON.MAXGRAD'
11209 !      include 'COMMON.SCCOR'
11210 #ifdef TIMING
11211       time01=MPI_Wtime()
11212 #endif
11213 !#define DEBUG
11214 #ifdef DEBUG
11215       write (iout,*) "sum_gradient gvdwc, gvdwx"
11216       do i=1,nres
11217         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11218          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11219       enddo
11220       call flush(iout)
11221 #endif
11222 #ifdef MPI
11223         gradbufc=0.0d0
11224         gradbufx=0.0d0
11225         gradbufc_sum=0.0d0
11226         gloc_scbuf=0.0d0
11227         glocbuf=0.0d0
11228 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11229         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11230           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11231 #endif
11232 !
11233 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11234 !            in virtual-bond-vector coordinates
11235 !
11236 #ifdef DEBUG
11237 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11238 !      do i=1,nres-1
11239 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11240 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11241 !      enddo
11242 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11243 !      do i=1,nres-1
11244 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11245 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11246 !      enddo
11247 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11248 !      do i=1,nres
11249 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11250 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11251 !         (gvdwc_scpp(j,i),j=1,3)
11252 !      enddo
11253 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11254 !      do i=1,nres
11255 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11256 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11257 !         (gelc_loc_long(j,i),j=1,3)
11258 !      enddo
11259       call flush(iout)
11260 #endif
11261 #ifdef SPLITELE
11262       do i=0,nct
11263         do j=1,3
11264           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11265                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11266                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11267                       wel_loc*gel_loc_long(j,i)+ &
11268                       wcorr*gradcorr_long(j,i)+ &
11269                       wcorr5*gradcorr5_long(j,i)+ &
11270                       wcorr6*gradcorr6_long(j,i)+ &
11271                       wturn6*gcorr6_turn_long(j,i)+ &
11272                       wstrain*ghpbc(j,i) &
11273                      +wliptran*gliptranc(j,i) &
11274                      +gradafm(j,i) &
11275                      +welec*gshieldc(j,i) &
11276                      +wcorr*gshieldc_ec(j,i) &
11277                      +wturn3*gshieldc_t3(j,i)&
11278                      +wturn4*gshieldc_t4(j,i)&
11279                      +wel_loc*gshieldc_ll(j,i)&
11280                      +wtube*gg_tube(j,i) &
11281                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11282                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11283                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11284                      wcorr_nucl*gradcorr_nucl(j,i)&
11285                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11286                      wcatprot* gradpepcat(j,i)+ &
11287                      wcatcat*gradcatcat(j,i)+   &
11288                      wscbase*gvdwc_scbase(j,i)+ &
11289                      wpepbase*gvdwc_pepbase(j,i)+&
11290                      wscpho*gvdwc_scpho(j,i)+   &
11291                      wpeppho*gvdwc_peppho(j,i)
11292
11293
11294
11295
11296
11297         enddo
11298       enddo
11299 #else
11300       do i=0,nct
11301         do j=1,3
11302           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11303                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11304                       welec*gelc_long(j,i)+ &
11305                       wbond*gradb(j,i)+ &
11306                       wel_loc*gel_loc_long(j,i)+ &
11307                       wcorr*gradcorr_long(j,i)+ &
11308                       wcorr5*gradcorr5_long(j,i)+ &
11309                       wcorr6*gradcorr6_long(j,i)+ &
11310                       wturn6*gcorr6_turn_long(j,i)+ &
11311                       wstrain*ghpbc(j,i) &
11312                      +wliptran*gliptranc(j,i) &
11313                      +gradafm(j,i) &
11314                      +welec*gshieldc(j,i)&
11315                      +wcorr*gshieldc_ec(j,i) &
11316                      +wturn4*gshieldc_t4(j,i) &
11317                      +wel_loc*gshieldc_ll(j,i)&
11318                      +wtube*gg_tube(j,i) &
11319                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11320                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11321                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11322                      wcorr_nucl*gradcorr_nucl(j,i) &
11323                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11324                      wcatprot* gradpepcat(j,i)+ &
11325                      wcatcat*gradcatcat(j,i)+   &
11326                      wscbase*gvdwc_scbase(j,i)+ &
11327                      wpepbase*gvdwc_pepbase(j,i)+&
11328                      wscpho*gvdwc_scpho(j,i)+&
11329                      wpeppho*gvdwc_peppho(j,i)
11330
11331
11332         enddo
11333       enddo
11334 #endif
11335 #ifdef MPI
11336       if (nfgtasks.gt.1) then
11337       time00=MPI_Wtime()
11338 #ifdef DEBUG
11339       write (iout,*) "gradbufc before allreduce"
11340       do i=1,nres
11341         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11342       enddo
11343       call flush(iout)
11344 #endif
11345       do i=0,nres
11346         do j=1,3
11347           gradbufc_sum(j,i)=gradbufc(j,i)
11348         enddo
11349       enddo
11350 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11351 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11352 !      time_reduce=time_reduce+MPI_Wtime()-time00
11353 #ifdef DEBUG
11354 !      write (iout,*) "gradbufc_sum after allreduce"
11355 !      do i=1,nres
11356 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11357 !      enddo
11358 !      call flush(iout)
11359 #endif
11360 #ifdef TIMING
11361 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11362 #endif
11363       do i=0,nres
11364         do k=1,3
11365           gradbufc(k,i)=0.0d0
11366         enddo
11367       enddo
11368 #ifdef DEBUG
11369       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11370       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11371                         " jgrad_end  ",jgrad_end(i),&
11372                         i=igrad_start,igrad_end)
11373 #endif
11374 !
11375 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11376 ! do not parallelize this part.
11377 !
11378 !      do i=igrad_start,igrad_end
11379 !        do j=jgrad_start(i),jgrad_end(i)
11380 !          do k=1,3
11381 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11382 !          enddo
11383 !        enddo
11384 !      enddo
11385       do j=1,3
11386         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11387       enddo
11388       do i=nres-2,-1,-1
11389         do j=1,3
11390           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11391         enddo
11392       enddo
11393 #ifdef DEBUG
11394       write (iout,*) "gradbufc after summing"
11395       do i=1,nres
11396         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11397       enddo
11398       call flush(iout)
11399 #endif
11400       else
11401 #endif
11402 !el#define DEBUG
11403 #ifdef DEBUG
11404       write (iout,*) "gradbufc"
11405       do i=1,nres
11406         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11407       enddo
11408       call flush(iout)
11409 #endif
11410 !el#undef DEBUG
11411       do i=-1,nres
11412         do j=1,3
11413           gradbufc_sum(j,i)=gradbufc(j,i)
11414           gradbufc(j,i)=0.0d0
11415         enddo
11416       enddo
11417       do j=1,3
11418         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11419       enddo
11420       do i=nres-2,-1,-1
11421         do j=1,3
11422           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11423         enddo
11424       enddo
11425 !      do i=nnt,nres-1
11426 !        do k=1,3
11427 !          gradbufc(k,i)=0.0d0
11428 !        enddo
11429 !        do j=i+1,nres
11430 !          do k=1,3
11431 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11432 !          enddo
11433 !        enddo
11434 !      enddo
11435 !el#define DEBUG
11436 #ifdef DEBUG
11437       write (iout,*) "gradbufc after summing"
11438       do i=1,nres
11439         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11440       enddo
11441       call flush(iout)
11442 #endif
11443 !el#undef DEBUG
11444 #ifdef MPI
11445       endif
11446 #endif
11447       do k=1,3
11448         gradbufc(k,nres)=0.0d0
11449       enddo
11450 !el----------------
11451 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11452 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11453 !el-----------------
11454       do i=-1,nct
11455         do j=1,3
11456 #ifdef SPLITELE
11457           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11458                       wel_loc*gel_loc(j,i)+ &
11459                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11460                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11461                       wel_loc*gel_loc_long(j,i)+ &
11462                       wcorr*gradcorr_long(j,i)+ &
11463                       wcorr5*gradcorr5_long(j,i)+ &
11464                       wcorr6*gradcorr6_long(j,i)+ &
11465                       wturn6*gcorr6_turn_long(j,i))+ &
11466                       wbond*gradb(j,i)+ &
11467                       wcorr*gradcorr(j,i)+ &
11468                       wturn3*gcorr3_turn(j,i)+ &
11469                       wturn4*gcorr4_turn(j,i)+ &
11470                       wcorr5*gradcorr5(j,i)+ &
11471                       wcorr6*gradcorr6(j,i)+ &
11472                       wturn6*gcorr6_turn(j,i)+ &
11473                       wsccor*gsccorc(j,i) &
11474                      +wscloc*gscloc(j,i)  &
11475                      +wliptran*gliptranc(j,i) &
11476                      +gradafm(j,i) &
11477                      +welec*gshieldc(j,i) &
11478                      +welec*gshieldc_loc(j,i) &
11479                      +wcorr*gshieldc_ec(j,i) &
11480                      +wcorr*gshieldc_loc_ec(j,i) &
11481                      +wturn3*gshieldc_t3(j,i) &
11482                      +wturn3*gshieldc_loc_t3(j,i) &
11483                      +wturn4*gshieldc_t4(j,i) &
11484                      +wturn4*gshieldc_loc_t4(j,i) &
11485                      +wel_loc*gshieldc_ll(j,i) &
11486                      +wel_loc*gshieldc_loc_ll(j,i) &
11487                      +wtube*gg_tube(j,i) &
11488                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11489                      +wvdwpsb*gvdwpsb1(j,i))&
11490                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11491 !                      if (i.eq.21) then
11492 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11493 !                      wturn4*gshieldc_t4(j,i), &
11494 !                     wturn4*gshieldc_loc_t4(j,i)
11495 !                       endif
11496 !                 if ((i.le.2).and.(i.ge.1))
11497 !                       print *,gradc(j,i,icg),&
11498 !                      gradbufc(j,i),welec*gelc(j,i), &
11499 !                      wel_loc*gel_loc(j,i), &
11500 !                      wscp*gvdwc_scpp(j,i), &
11501 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11502 !                      wel_loc*gel_loc_long(j,i), &
11503 !                      wcorr*gradcorr_long(j,i), &
11504 !                      wcorr5*gradcorr5_long(j,i), &
11505 !                      wcorr6*gradcorr6_long(j,i), &
11506 !                      wturn6*gcorr6_turn_long(j,i), &
11507 !                      wbond*gradb(j,i), &
11508 !                      wcorr*gradcorr(j,i), &
11509 !                      wturn3*gcorr3_turn(j,i), &
11510 !                      wturn4*gcorr4_turn(j,i), &
11511 !                      wcorr5*gradcorr5(j,i), &
11512 !                      wcorr6*gradcorr6(j,i), &
11513 !                      wturn6*gcorr6_turn(j,i), &
11514 !                      wsccor*gsccorc(j,i) &
11515 !                     ,wscloc*gscloc(j,i)  &
11516 !                     ,wliptran*gliptranc(j,i) &
11517 !                    ,gradafm(j,i) &
11518 !                     ,welec*gshieldc(j,i) &
11519 !                     ,welec*gshieldc_loc(j,i) &
11520 !                     ,wcorr*gshieldc_ec(j,i) &
11521 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11522 !                     ,wturn3*gshieldc_t3(j,i) &
11523 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11524 !                     ,wturn4*gshieldc_t4(j,i) &
11525 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11526 !                     ,wel_loc*gshieldc_ll(j,i) &
11527 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11528 !                     ,wtube*gg_tube(j,i) &
11529 !                     ,wbond_nucl*gradb_nucl(j,i) &
11530 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11531 !                     wvdwpsb*gvdwpsb1(j,i)&
11532 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11533 !
11534
11535 #else
11536           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11537                       wel_loc*gel_loc(j,i)+ &
11538                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11539                       welec*gelc_long(j,i)+ &
11540                       wel_loc*gel_loc_long(j,i)+ &
11541 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11542                       wcorr5*gradcorr5_long(j,i)+ &
11543                       wcorr6*gradcorr6_long(j,i)+ &
11544                       wturn6*gcorr6_turn_long(j,i))+ &
11545                       wbond*gradb(j,i)+ &
11546                       wcorr*gradcorr(j,i)+ &
11547                       wturn3*gcorr3_turn(j,i)+ &
11548                       wturn4*gcorr4_turn(j,i)+ &
11549                       wcorr5*gradcorr5(j,i)+ &
11550                       wcorr6*gradcorr6(j,i)+ &
11551                       wturn6*gcorr6_turn(j,i)+ &
11552                       wsccor*gsccorc(j,i) &
11553                      +wscloc*gscloc(j,i) &
11554                      +gradafm(j,i) &
11555                      +wliptran*gliptranc(j,i) &
11556                      +welec*gshieldc(j,i) &
11557                      +welec*gshieldc_loc(j,i) &
11558                      +wcorr*gshieldc_ec(j,i) &
11559                      +wcorr*gshieldc_loc_ec(j,i) &
11560                      +wturn3*gshieldc_t3(j,i) &
11561                      +wturn3*gshieldc_loc_t3(j,i) &
11562                      +wturn4*gshieldc_t4(j,i) &
11563                      +wturn4*gshieldc_loc_t4(j,i) &
11564                      +wel_loc*gshieldc_ll(j,i) &
11565                      +wel_loc*gshieldc_loc_ll(j,i) &
11566                      +wtube*gg_tube(j,i) &
11567                      +wbond_nucl*gradb_nucl(j,i) &
11568                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11569                      +wvdwpsb*gvdwpsb1(j,i))&
11570                      +wsbloc*gsbloc(j,i)
11571
11572
11573
11574
11575 #endif
11576           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11577                         wbond*gradbx(j,i)+ &
11578                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11579                         wsccor*gsccorx(j,i) &
11580                        +wscloc*gsclocx(j,i) &
11581                        +wliptran*gliptranx(j,i) &
11582                        +welec*gshieldx(j,i)     &
11583                        +wcorr*gshieldx_ec(j,i)  &
11584                        +wturn3*gshieldx_t3(j,i) &
11585                        +wturn4*gshieldx_t4(j,i) &
11586                        +wel_loc*gshieldx_ll(j,i)&
11587                        +wtube*gg_tube_sc(j,i)   &
11588                        +wbond_nucl*gradbx_nucl(j,i) &
11589                        +wvdwsb*gvdwsbx(j,i) &
11590                        +welsb*gelsbx(j,i) &
11591                        +wcorr_nucl*gradxorr_nucl(j,i)&
11592                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11593                        +wsbloc*gsblocx(j,i) &
11594                        +wcatprot* gradpepcatx(j,i)&
11595                        +wscbase*gvdwx_scbase(j,i) &
11596                        +wpepbase*gvdwx_pepbase(j,i)&
11597                        +wscpho*gvdwx_scpho(j,i)
11598 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11599
11600         enddo
11601       enddo
11602 !#define DEBUG
11603 #ifdef DEBUG
11604       write (iout,*) "gloc before adding corr"
11605       do i=1,4*nres
11606         write (iout,*) i,gloc(i,icg)
11607       enddo
11608 #endif
11609       do i=1,nres-3
11610         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11611          +wcorr5*g_corr5_loc(i) &
11612          +wcorr6*g_corr6_loc(i) &
11613          +wturn4*gel_loc_turn4(i) &
11614          +wturn3*gel_loc_turn3(i) &
11615          +wturn6*gel_loc_turn6(i) &
11616          +wel_loc*gel_loc_loc(i)
11617       enddo
11618 #ifdef DEBUG
11619       write (iout,*) "gloc after adding corr"
11620       do i=1,4*nres
11621         write (iout,*) i,gloc(i,icg)
11622       enddo
11623 #endif
11624 !#undef DEBUG
11625 #ifdef MPI
11626       if (nfgtasks.gt.1) then
11627         do j=1,3
11628           do i=0,nres
11629             gradbufc(j,i)=gradc(j,i,icg)
11630             gradbufx(j,i)=gradx(j,i,icg)
11631           enddo
11632         enddo
11633         do i=1,4*nres
11634           glocbuf(i)=gloc(i,icg)
11635         enddo
11636 !#define DEBUG
11637 #ifdef DEBUG
11638       write (iout,*) "gloc_sc before reduce"
11639       do i=1,nres
11640        do j=1,1
11641         write (iout,*) i,j,gloc_sc(j,i,icg)
11642        enddo
11643       enddo
11644 #endif
11645 !#undef DEBUG
11646         do i=1,nres
11647          do j=1,3
11648           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11649          enddo
11650         enddo
11651         time00=MPI_Wtime()
11652         call MPI_Barrier(FG_COMM,IERR)
11653         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11654         time00=MPI_Wtime()
11655         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11656           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11657         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11658           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11659         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11660           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11661         time_reduce=time_reduce+MPI_Wtime()-time00
11662         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11663           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11664         time_reduce=time_reduce+MPI_Wtime()-time00
11665 !#define DEBUG
11666 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11667 #ifdef DEBUG
11668       write (iout,*) "gloc_sc after reduce"
11669       do i=1,nres
11670        do j=1,1
11671         write (iout,*) i,j,gloc_sc(j,i,icg)
11672        enddo
11673       enddo
11674 #endif
11675 !#undef DEBUG
11676 #ifdef DEBUG
11677       write (iout,*) "gloc after reduce"
11678       do i=1,4*nres
11679         write (iout,*) i,gloc(i,icg)
11680       enddo
11681 #endif
11682       endif
11683 #endif
11684       if (gnorm_check) then
11685 !
11686 ! Compute the maximum elements of the gradient
11687 !
11688       gvdwc_max=0.0d0
11689       gvdwc_scp_max=0.0d0
11690       gelc_max=0.0d0
11691       gvdwpp_max=0.0d0
11692       gradb_max=0.0d0
11693       ghpbc_max=0.0d0
11694       gradcorr_max=0.0d0
11695       gel_loc_max=0.0d0
11696       gcorr3_turn_max=0.0d0
11697       gcorr4_turn_max=0.0d0
11698       gradcorr5_max=0.0d0
11699       gradcorr6_max=0.0d0
11700       gcorr6_turn_max=0.0d0
11701       gsccorc_max=0.0d0
11702       gscloc_max=0.0d0
11703       gvdwx_max=0.0d0
11704       gradx_scp_max=0.0d0
11705       ghpbx_max=0.0d0
11706       gradxorr_max=0.0d0
11707       gsccorx_max=0.0d0
11708       gsclocx_max=0.0d0
11709       do i=1,nct
11710         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11711         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11712         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11713         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11714          gvdwc_scp_max=gvdwc_scp_norm
11715         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11716         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11717         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11718         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11719         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11720         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11721         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11722         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11723         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11724         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11725         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11726         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11727         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11728           gcorr3_turn(1,i)))
11729         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11730           gcorr3_turn_max=gcorr3_turn_norm
11731         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11732           gcorr4_turn(1,i)))
11733         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11734           gcorr4_turn_max=gcorr4_turn_norm
11735         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11736         if (gradcorr5_norm.gt.gradcorr5_max) &
11737           gradcorr5_max=gradcorr5_norm
11738         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11739         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11740         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11741           gcorr6_turn(1,i)))
11742         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11743           gcorr6_turn_max=gcorr6_turn_norm
11744         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11745         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11746         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11747         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11748         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11749         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11750         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11751         if (gradx_scp_norm.gt.gradx_scp_max) &
11752           gradx_scp_max=gradx_scp_norm
11753         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11754         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11755         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11756         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11757         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11758         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11759         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11760         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11761       enddo
11762       if (gradout) then
11763 #ifdef AIX
11764         open(istat,file=statname,position="append")
11765 #else
11766         open(istat,file=statname,access="append")
11767 #endif
11768         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11769            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11770            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11771            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11772            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11773            gsccorx_max,gsclocx_max
11774         close(istat)
11775         if (gvdwc_max.gt.1.0d4) then
11776           write (iout,*) "gvdwc gvdwx gradb gradbx"
11777           do i=nnt,nct
11778             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11779               gradb(j,i),gradbx(j,i),j=1,3)
11780           enddo
11781           call pdbout(0.0d0,'cipiszcze',iout)
11782           call flush(iout)
11783         endif
11784       endif
11785       endif
11786 !#define DEBUG
11787 #ifdef DEBUG
11788       write (iout,*) "gradc gradx gloc"
11789       do i=1,nres
11790         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11791          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11792       enddo
11793 #endif
11794 !#undef DEBUG
11795 #ifdef TIMING
11796       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11797 #endif
11798       return
11799       end subroutine sum_gradient
11800 !-----------------------------------------------------------------------------
11801       subroutine sc_grad
11802 !      implicit real*8 (a-h,o-z)
11803       use calc_data
11804 !      include 'DIMENSIONS'
11805 !      include 'COMMON.CHAIN'
11806 !      include 'COMMON.DERIV'
11807 !      include 'COMMON.CALC'
11808 !      include 'COMMON.IOUNITS'
11809       real(kind=8), dimension(3) :: dcosom1,dcosom2
11810 !      print *,"wchodze"
11811       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11812           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11813       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11814           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11815
11816       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11817            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11818            +dCAVdOM12+ dGCLdOM12
11819 ! diagnostics only
11820 !      eom1=0.0d0
11821 !      eom2=0.0d0
11822 !      eom12=evdwij*eps1_om12
11823 ! end diagnostics
11824 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11825 !       " sigder",sigder
11826 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11827 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11828 !C      print *,sss_ele_cut,'in sc_grad'
11829       do k=1,3
11830         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11831         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11832       enddo
11833       do k=1,3
11834         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11835 !C      print *,'gg',k,gg(k)
11836        enddo
11837 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11838 !      write (iout,*) "gg",(gg(k),k=1,3)
11839       do k=1,3
11840         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11841                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11842                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11843                   *sss_ele_cut
11844
11845         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11846                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11847                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11848                   *sss_ele_cut
11849
11850 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11851 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11852 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11853 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11854       enddo
11855 !
11856 ! Calculate the components of the gradient in DC and X
11857 !
11858 !grad      do k=i,j-1
11859 !grad        do l=1,3
11860 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11861 !grad        enddo
11862 !grad      enddo
11863       do l=1,3
11864         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11865         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11866       enddo
11867       return
11868       end subroutine sc_grad
11869 #ifdef CRYST_THETA
11870 !-----------------------------------------------------------------------------
11871       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11872
11873       use comm_calcthet
11874 !      implicit real*8 (a-h,o-z)
11875 !      include 'DIMENSIONS'
11876 !      include 'COMMON.LOCAL'
11877 !      include 'COMMON.IOUNITS'
11878 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11879 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11880 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11881       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11882       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11883 !el      integer :: it
11884 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11885 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11886 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11887 !el local variables
11888
11889       delthec=thetai-thet_pred_mean
11890       delthe0=thetai-theta0i
11891 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11892       t3 = thetai-thet_pred_mean
11893       t6 = t3**2
11894       t9 = term1
11895       t12 = t3*sigcsq
11896       t14 = t12+t6*sigsqtc
11897       t16 = 1.0d0
11898       t21 = thetai-theta0i
11899       t23 = t21**2
11900       t26 = term2
11901       t27 = t21*t26
11902       t32 = termexp
11903       t40 = t32**2
11904       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11905        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11906        *(-t12*t9-ak*sig0inv*t27)
11907       return
11908       end subroutine mixder
11909 #endif
11910 !-----------------------------------------------------------------------------
11911 ! cartder.F
11912 !-----------------------------------------------------------------------------
11913       subroutine cartder
11914 !-----------------------------------------------------------------------------
11915 ! This subroutine calculates the derivatives of the consecutive virtual
11916 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11917 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11918 ! in the angles alpha and omega, describing the location of a side chain
11919 ! in its local coordinate system.
11920 !
11921 ! The derivatives are stored in the following arrays:
11922 !
11923 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11924 ! The structure is as follows:
11925 !
11926 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11927 ! 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)
11928 !         . . . . . . . . . . . .  . . . . . .
11929 ! 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)
11930 !                          .
11931 !                          .
11932 !                          .
11933 ! 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)
11934 !
11935 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11936 ! The structure is same as above.
11937 !
11938 ! DCDS - the derivatives of the side chain vectors in the local spherical
11939 ! andgles alph and omega:
11940 !
11941 ! 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)
11942 ! 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)
11943 !                          .
11944 !                          .
11945 !                          .
11946 ! 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)
11947 !
11948 ! Version of March '95, based on an early version of November '91.
11949 !
11950 !**********************************************************************
11951 !      implicit real*8 (a-h,o-z)
11952 !      include 'DIMENSIONS'
11953 !      include 'COMMON.VAR'
11954 !      include 'COMMON.CHAIN'
11955 !      include 'COMMON.DERIV'
11956 !      include 'COMMON.GEO'
11957 !      include 'COMMON.LOCAL'
11958 !      include 'COMMON.INTERACT'
11959       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11960       real(kind=8),dimension(3,3) :: dp,temp
11961 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11962       real(kind=8),dimension(3) :: xx,xx1
11963 !el local variables
11964       integer :: i,k,l,j,m,ind,ind1,jjj
11965       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11966                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11967                  sint2,xp,yp,xxp,yyp,zzp,dj
11968
11969 !      common /przechowalnia/ fromto
11970       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11971 ! get the position of the jth ijth fragment of the chain coordinate system
11972 ! in the fromto array.
11973 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11974 !
11975 !      maxdim=(nres-1)*(nres-2)/2
11976 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11977 ! calculate the derivatives of transformation matrix elements in theta
11978 !
11979
11980 !el      call flush(iout) !el
11981       do i=1,nres-2
11982         rdt(1,1,i)=-rt(1,2,i)
11983         rdt(1,2,i)= rt(1,1,i)
11984         rdt(1,3,i)= 0.0d0
11985         rdt(2,1,i)=-rt(2,2,i)
11986         rdt(2,2,i)= rt(2,1,i)
11987         rdt(2,3,i)= 0.0d0
11988         rdt(3,1,i)=-rt(3,2,i)
11989         rdt(3,2,i)= rt(3,1,i)
11990         rdt(3,3,i)= 0.0d0
11991       enddo
11992 !
11993 ! derivatives in phi
11994 !
11995       do i=2,nres-2
11996         drt(1,1,i)= 0.0d0
11997         drt(1,2,i)= 0.0d0
11998         drt(1,3,i)= 0.0d0
11999         drt(2,1,i)= rt(3,1,i)
12000         drt(2,2,i)= rt(3,2,i)
12001         drt(2,3,i)= rt(3,3,i)
12002         drt(3,1,i)=-rt(2,1,i)
12003         drt(3,2,i)=-rt(2,2,i)
12004         drt(3,3,i)=-rt(2,3,i)
12005       enddo
12006 !
12007 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12008 !
12009       do i=2,nres-2
12010         ind=indmat(i,i+1)
12011         do k=1,3
12012           do l=1,3
12013             temp(k,l)=rt(k,l,i)
12014           enddo
12015         enddo
12016         do k=1,3
12017           do l=1,3
12018             fromto(k,l,ind)=temp(k,l)
12019           enddo
12020         enddo
12021         do j=i+1,nres-2
12022           ind=indmat(i,j+1)
12023           do k=1,3
12024             do l=1,3
12025               dpkl=0.0d0
12026               do m=1,3
12027                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12028               enddo
12029               dp(k,l)=dpkl
12030               fromto(k,l,ind)=dpkl
12031             enddo
12032           enddo
12033           do k=1,3
12034             do l=1,3
12035               temp(k,l)=dp(k,l)
12036             enddo
12037           enddo
12038         enddo
12039       enddo
12040 !
12041 ! Calculate derivatives.
12042 !
12043       ind1=0
12044       do i=1,nres-2
12045       ind1=ind1+1
12046 !
12047 ! Derivatives of DC(i+1) in theta(i+2)
12048 !
12049         do j=1,3
12050           do k=1,2
12051             dpjk=0.0D0
12052             do l=1,3
12053               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12054             enddo
12055             dp(j,k)=dpjk
12056             prordt(j,k,i)=dp(j,k)
12057           enddo
12058           dp(j,3)=0.0D0
12059           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12060         enddo
12061 !
12062 ! Derivatives of SC(i+1) in theta(i+2)
12063 !
12064         xx1(1)=-0.5D0*xloc(2,i+1)
12065         xx1(2)= 0.5D0*xloc(1,i+1)
12066         do j=1,3
12067           xj=0.0D0
12068           do k=1,2
12069             xj=xj+r(j,k,i)*xx1(k)
12070           enddo
12071           xx(j)=xj
12072         enddo
12073         do j=1,3
12074           rj=0.0D0
12075           do k=1,3
12076             rj=rj+prod(j,k,i)*xx(k)
12077           enddo
12078           dxdv(j,ind1)=rj
12079         enddo
12080 !
12081 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12082 ! than the other off-diagonal derivatives.
12083 !
12084         do j=1,3
12085           dxoiij=0.0D0
12086           do k=1,3
12087             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12088           enddo
12089           dxdv(j,ind1+1)=dxoiij
12090         enddo
12091 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12092 !
12093 ! Derivatives of DC(i+1) in phi(i+2)
12094 !
12095         do j=1,3
12096           do k=1,3
12097             dpjk=0.0
12098             do l=2,3
12099               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12100             enddo
12101             dp(j,k)=dpjk
12102             prodrt(j,k,i)=dp(j,k)
12103           enddo
12104           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12105         enddo
12106 !
12107 ! Derivatives of SC(i+1) in phi(i+2)
12108 !
12109         xx(1)= 0.0D0
12110         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12111         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12112         do j=1,3
12113           rj=0.0D0
12114           do k=2,3
12115             rj=rj+prod(j,k,i)*xx(k)
12116           enddo
12117           dxdv(j+3,ind1)=-rj
12118         enddo
12119 !
12120 ! Derivatives of SC(i+1) in phi(i+3).
12121 !
12122         do j=1,3
12123           dxoiij=0.0D0
12124           do k=1,3
12125             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12126           enddo
12127           dxdv(j+3,ind1+1)=dxoiij
12128         enddo
12129 !
12130 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12131 ! theta(nres) and phi(i+3) thru phi(nres).
12132 !
12133         do j=i+1,nres-2
12134         ind1=ind1+1
12135         ind=indmat(i+1,j+1)
12136 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12137           do k=1,3
12138             do l=1,3
12139               tempkl=0.0D0
12140               do m=1,2
12141                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12142               enddo
12143               temp(k,l)=tempkl
12144             enddo
12145           enddo
12146 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12147 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12148 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12149 ! Derivatives of virtual-bond vectors in theta
12150           do k=1,3
12151             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12152           enddo
12153 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12154 ! Derivatives of SC vectors in theta
12155           do k=1,3
12156             dxoijk=0.0D0
12157             do l=1,3
12158               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12159             enddo
12160             dxdv(k,ind1+1)=dxoijk
12161           enddo
12162 !
12163 !--- Calculate the derivatives in phi
12164 !
12165           do k=1,3
12166             do l=1,3
12167               tempkl=0.0D0
12168               do m=1,3
12169                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12170               enddo
12171               temp(k,l)=tempkl
12172             enddo
12173           enddo
12174           do k=1,3
12175             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12176         enddo
12177           do k=1,3
12178             dxoijk=0.0D0
12179             do l=1,3
12180               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12181             enddo
12182             dxdv(k+3,ind1+1)=dxoijk
12183           enddo
12184         enddo
12185       enddo
12186 !
12187 ! Derivatives in alpha and omega:
12188 !
12189       do i=2,nres-1
12190 !       dsci=dsc(itype(i,1))
12191         dsci=vbld(i+nres)
12192 #ifdef OSF
12193         alphi=alph(i)
12194         omegi=omeg(i)
12195         if(alphi.ne.alphi) alphi=100.0
12196         if(omegi.ne.omegi) omegi=-100.0
12197 #else
12198       alphi=alph(i)
12199       omegi=omeg(i)
12200 #endif
12201 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12202       cosalphi=dcos(alphi)
12203       sinalphi=dsin(alphi)
12204       cosomegi=dcos(omegi)
12205       sinomegi=dsin(omegi)
12206       temp(1,1)=-dsci*sinalphi
12207       temp(2,1)= dsci*cosalphi*cosomegi
12208       temp(3,1)=-dsci*cosalphi*sinomegi
12209       temp(1,2)=0.0D0
12210       temp(2,2)=-dsci*sinalphi*sinomegi
12211       temp(3,2)=-dsci*sinalphi*cosomegi
12212       theta2=pi-0.5D0*theta(i+1)
12213       cost2=dcos(theta2)
12214       sint2=dsin(theta2)
12215       jjj=0
12216 !d      print *,((temp(l,k),l=1,3),k=1,2)
12217         do j=1,2
12218         xp=temp(1,j)
12219         yp=temp(2,j)
12220         xxp= xp*cost2+yp*sint2
12221         yyp=-xp*sint2+yp*cost2
12222         zzp=temp(3,j)
12223         xx(1)=xxp
12224         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12225         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12226         do k=1,3
12227           dj=0.0D0
12228           do l=1,3
12229             dj=dj+prod(k,l,i-1)*xx(l)
12230             enddo
12231           dxds(jjj+k,i)=dj
12232           enddo
12233         jjj=jjj+3
12234       enddo
12235       enddo
12236       return
12237       end subroutine cartder
12238 !-----------------------------------------------------------------------------
12239 ! checkder_p.F
12240 !-----------------------------------------------------------------------------
12241       subroutine check_cartgrad
12242 ! Check the gradient of Cartesian coordinates in internal coordinates.
12243 !      implicit real*8 (a-h,o-z)
12244 !      include 'DIMENSIONS'
12245 !      include 'COMMON.IOUNITS'
12246 !      include 'COMMON.VAR'
12247 !      include 'COMMON.CHAIN'
12248 !      include 'COMMON.GEO'
12249 !      include 'COMMON.LOCAL'
12250 !      include 'COMMON.DERIV'
12251       real(kind=8),dimension(6,nres) :: temp
12252       real(kind=8),dimension(3) :: xx,gg
12253       integer :: i,k,j,ii
12254       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12255 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12256 !
12257 ! Check the gradient of the virtual-bond and SC vectors in the internal
12258 ! coordinates.
12259 !
12260       aincr=1.0d-6
12261       aincr2=5.0d-7
12262       call cartder
12263       write (iout,'(a)') '**************** dx/dalpha'
12264       write (iout,'(a)')
12265       do i=2,nres-1
12266       alphi=alph(i)
12267       alph(i)=alph(i)+aincr
12268       do k=1,3
12269         temp(k,i)=dc(k,nres+i)
12270         enddo
12271       call chainbuild
12272       do k=1,3
12273         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12274         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12275         enddo
12276         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12277         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12278         write (iout,'(a)')
12279       alph(i)=alphi
12280       call chainbuild
12281       enddo
12282       write (iout,'(a)')
12283       write (iout,'(a)') '**************** dx/domega'
12284       write (iout,'(a)')
12285       do i=2,nres-1
12286       omegi=omeg(i)
12287       omeg(i)=omeg(i)+aincr
12288       do k=1,3
12289         temp(k,i)=dc(k,nres+i)
12290         enddo
12291       call chainbuild
12292       do k=1,3
12293           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12294           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12295                 (aincr*dabs(dxds(k+3,i))+aincr))
12296         enddo
12297         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12298             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12299         write (iout,'(a)')
12300       omeg(i)=omegi
12301       call chainbuild
12302       enddo
12303       write (iout,'(a)')
12304       write (iout,'(a)') '**************** dx/dtheta'
12305       write (iout,'(a)')
12306       do i=3,nres
12307       theti=theta(i)
12308         theta(i)=theta(i)+aincr
12309         do j=i-1,nres-1
12310           do k=1,3
12311             temp(k,j)=dc(k,nres+j)
12312           enddo
12313         enddo
12314         call chainbuild
12315         do j=i-1,nres-1
12316         ii = indmat(i-2,j)
12317 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12318         do k=1,3
12319           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12320           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12321                   (aincr*dabs(dxdv(k,ii))+aincr))
12322           enddo
12323           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12324               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12325           write(iout,'(a)')
12326         enddo
12327         write (iout,'(a)')
12328         theta(i)=theti
12329         call chainbuild
12330       enddo
12331       write (iout,'(a)') '***************** dx/dphi'
12332       write (iout,'(a)')
12333       do i=4,nres
12334         phi(i)=phi(i)+aincr
12335         do j=i-1,nres-1
12336           do k=1,3
12337             temp(k,j)=dc(k,nres+j)
12338           enddo
12339         enddo
12340         call chainbuild
12341         do j=i-1,nres-1
12342         ii = indmat(i-2,j)
12343 !         print *,'ii=',ii
12344         do k=1,3
12345           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12346             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12347                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12348           enddo
12349           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12350               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12351           write(iout,'(a)')
12352         enddo
12353         phi(i)=phi(i)-aincr
12354         call chainbuild
12355       enddo
12356       write (iout,'(a)') '****************** ddc/dtheta'
12357       do i=1,nres-2
12358         thet=theta(i+2)
12359         theta(i+2)=thet+aincr
12360         do j=i,nres
12361           do k=1,3
12362             temp(k,j)=dc(k,j)
12363           enddo
12364         enddo
12365         call chainbuild
12366         do j=i+1,nres-1
12367         ii = indmat(i,j)
12368 !         print *,'ii=',ii
12369         do k=1,3
12370           gg(k)=(dc(k,j)-temp(k,j))/aincr
12371           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12372                  (aincr*dabs(dcdv(k,ii))+aincr))
12373           enddo
12374           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12375                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12376         write (iout,'(a)')
12377         enddo
12378         do j=1,nres
12379           do k=1,3
12380             dc(k,j)=temp(k,j)
12381           enddo
12382         enddo
12383         theta(i+2)=thet
12384       enddo
12385       write (iout,'(a)') '******************* ddc/dphi'
12386       do i=1,nres-3
12387         phii=phi(i+3)
12388         phi(i+3)=phii+aincr
12389         do j=1,nres
12390           do k=1,3
12391             temp(k,j)=dc(k,j)
12392           enddo
12393         enddo
12394         call chainbuild
12395         do j=i+2,nres-1
12396         ii = indmat(i+1,j)
12397 !         print *,'ii=',ii
12398         do k=1,3
12399           gg(k)=(dc(k,j)-temp(k,j))/aincr
12400             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12401                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12402           enddo
12403           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12404                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12405         write (iout,'(a)')
12406         enddo
12407         do j=1,nres
12408           do k=1,3
12409             dc(k,j)=temp(k,j)
12410           enddo
12411         enddo
12412         phi(i+3)=phii
12413       enddo
12414       return
12415       end subroutine check_cartgrad
12416 !-----------------------------------------------------------------------------
12417       subroutine check_ecart
12418 ! Check the gradient of the energy in Cartesian coordinates.
12419 !     implicit real*8 (a-h,o-z)
12420 !     include 'DIMENSIONS'
12421 !     include 'COMMON.CHAIN'
12422 !     include 'COMMON.DERIV'
12423 !     include 'COMMON.IOUNITS'
12424 !     include 'COMMON.VAR'
12425 !     include 'COMMON.CONTACTS'
12426       use comm_srutu
12427 !el      integer :: icall
12428 !el      common /srutu/ icall
12429       real(kind=8),dimension(6) :: ggg
12430       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12431       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12432       real(kind=8),dimension(6,nres) :: grad_s
12433       real(kind=8),dimension(0:n_ene) :: energia,energia1
12434       integer :: uiparm(1)
12435       real(kind=8) :: urparm(1)
12436 !EL      external fdum
12437       integer :: nf,i,j,k
12438       real(kind=8) :: aincr,etot,etot1
12439       icg=1
12440       nf=0
12441       nfl=0
12442       call zerograd
12443       aincr=1.0D-5
12444       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12445       nf=0
12446       icall=0
12447       call geom_to_var(nvar,x)
12448       call etotal(energia)
12449       etot=energia(0)
12450 !el      call enerprint(energia)
12451       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12452       icall =1
12453       do i=1,nres
12454         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12455       enddo
12456       do i=1,nres
12457       do j=1,3
12458         grad_s(j,i)=gradc(j,i,icg)
12459         grad_s(j+3,i)=gradx(j,i,icg)
12460         enddo
12461       enddo
12462       call flush(iout)
12463       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12464       do i=1,nres
12465         do j=1,3
12466         xx(j)=c(j,i+nres)
12467         ddc(j)=dc(j,i)
12468         ddx(j)=dc(j,i+nres)
12469         enddo
12470       do j=1,3
12471         dc(j,i)=dc(j,i)+aincr
12472         do k=i+1,nres
12473           c(j,k)=c(j,k)+aincr
12474           c(j,k+nres)=c(j,k+nres)+aincr
12475           enddo
12476           call zerograd
12477           call etotal(energia1)
12478           etot1=energia1(0)
12479         ggg(j)=(etot1-etot)/aincr
12480         dc(j,i)=ddc(j)
12481         do k=i+1,nres
12482           c(j,k)=c(j,k)-aincr
12483           c(j,k+nres)=c(j,k+nres)-aincr
12484           enddo
12485         enddo
12486       do j=1,3
12487         c(j,i+nres)=c(j,i+nres)+aincr
12488         dc(j,i+nres)=dc(j,i+nres)+aincr
12489           call zerograd
12490           call etotal(energia1)
12491           etot1=energia1(0)
12492         ggg(j+3)=(etot1-etot)/aincr
12493         c(j,i+nres)=xx(j)
12494         dc(j,i+nres)=ddx(j)
12495         enddo
12496       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12497          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12498       enddo
12499       return
12500       end subroutine check_ecart
12501 #ifdef CARGRAD
12502 !-----------------------------------------------------------------------------
12503       subroutine check_ecartint
12504 ! Check the gradient of the energy in Cartesian coordinates.
12505       use io_base, only: intout
12506 !      implicit real*8 (a-h,o-z)
12507 !      include 'DIMENSIONS'
12508 !      include 'COMMON.CONTROL'
12509 !      include 'COMMON.CHAIN'
12510 !      include 'COMMON.DERIV'
12511 !      include 'COMMON.IOUNITS'
12512 !      include 'COMMON.VAR'
12513 !      include 'COMMON.CONTACTS'
12514 !      include 'COMMON.MD'
12515 !      include 'COMMON.LOCAL'
12516 !      include 'COMMON.SPLITELE'
12517       use comm_srutu
12518 !el      integer :: icall
12519 !el      common /srutu/ icall
12520       real(kind=8),dimension(6) :: ggg,ggg1
12521       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12522       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12523       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12524       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12525       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12526       real(kind=8),dimension(0:n_ene) :: energia,energia1
12527       integer :: uiparm(1)
12528       real(kind=8) :: urparm(1)
12529 !EL      external fdum
12530       integer :: i,j,k,nf
12531       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12532                    etot21,etot22
12533       r_cut=2.0d0
12534       rlambd=0.3d0
12535       icg=1
12536       nf=0
12537       nfl=0
12538       call intout
12539 !      call intcartderiv
12540 !      call checkintcartgrad
12541       call zerograd
12542       aincr=1.0D-4
12543       write(iout,*) 'Calling CHECK_ECARTINT.'
12544       nf=0
12545       icall=0
12546       call geom_to_var(nvar,x)
12547       write (iout,*) "split_ene ",split_ene
12548       call flush(iout)
12549       if (.not.split_ene) then
12550         call zerograd
12551         call etotal(energia)
12552         etot=energia(0)
12553         call cartgrad
12554         icall =1
12555         do i=1,nres
12556           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12557         enddo
12558         do j=1,3
12559           grad_s(j,0)=gcart(j,0)
12560         enddo
12561         do i=1,nres
12562           do j=1,3
12563             grad_s(j,i)=gcart(j,i)
12564             grad_s(j+3,i)=gxcart(j,i)
12565           enddo
12566         enddo
12567       else
12568 !- split gradient check
12569         call zerograd
12570         call etotal_long(energia)
12571 !el        call enerprint(energia)
12572         call cartgrad
12573         icall =1
12574         do i=1,nres
12575           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12576           (gxcart(j,i),j=1,3)
12577         enddo
12578         do j=1,3
12579           grad_s(j,0)=gcart(j,0)
12580         enddo
12581         do i=1,nres
12582           do j=1,3
12583             grad_s(j,i)=gcart(j,i)
12584             grad_s(j+3,i)=gxcart(j,i)
12585           enddo
12586         enddo
12587         call zerograd
12588         call etotal_short(energia)
12589         call enerprint(energia)
12590         call cartgrad
12591         icall =1
12592         do i=1,nres
12593           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12594           (gxcart(j,i),j=1,3)
12595         enddo
12596         do j=1,3
12597           grad_s1(j,0)=gcart(j,0)
12598         enddo
12599         do i=1,nres
12600           do j=1,3
12601             grad_s1(j,i)=gcart(j,i)
12602             grad_s1(j+3,i)=gxcart(j,i)
12603           enddo
12604         enddo
12605       endif
12606       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12607 !      do i=1,nres
12608       do i=nnt,nct
12609         do j=1,3
12610           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12611           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12612         ddc(j)=c(j,i)
12613         ddx(j)=c(j,i+nres)
12614           dcnorm_safe1(j)=dc_norm(j,i-1)
12615           dcnorm_safe2(j)=dc_norm(j,i)
12616           dxnorm_safe(j)=dc_norm(j,i+nres)
12617         enddo
12618       do j=1,3
12619         c(j,i)=ddc(j)+aincr
12620           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12621           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12622           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12623           dc(j,i)=c(j,i+1)-c(j,i)
12624           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12625           call int_from_cart1(.false.)
12626           if (.not.split_ene) then
12627            call zerograd
12628             call etotal(energia1)
12629             etot1=energia1(0)
12630             write (iout,*) "ij",i,j," etot1",etot1
12631           else
12632 !- split gradient
12633             call etotal_long(energia1)
12634             etot11=energia1(0)
12635             call etotal_short(energia1)
12636             etot12=energia1(0)
12637           endif
12638 !- end split gradient
12639 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12640         c(j,i)=ddc(j)-aincr
12641           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12642           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12643           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12644           dc(j,i)=c(j,i+1)-c(j,i)
12645           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12646           call int_from_cart1(.false.)
12647           if (.not.split_ene) then
12648             call zerograd
12649             call etotal(energia1)
12650             etot2=energia1(0)
12651             write (iout,*) "ij",i,j," etot2",etot2
12652           ggg(j)=(etot1-etot2)/(2*aincr)
12653           else
12654 !- split gradient
12655             call etotal_long(energia1)
12656             etot21=energia1(0)
12657           ggg(j)=(etot11-etot21)/(2*aincr)
12658             call etotal_short(energia1)
12659             etot22=energia1(0)
12660           ggg1(j)=(etot12-etot22)/(2*aincr)
12661 !- end split gradient
12662 !            write (iout,*) "etot21",etot21," etot22",etot22
12663           endif
12664 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12665         c(j,i)=ddc(j)
12666           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12667           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12668           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12669           dc(j,i)=c(j,i+1)-c(j,i)
12670           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12671           dc_norm(j,i-1)=dcnorm_safe1(j)
12672           dc_norm(j,i)=dcnorm_safe2(j)
12673           dc_norm(j,i+nres)=dxnorm_safe(j)
12674         enddo
12675       do j=1,3
12676         c(j,i+nres)=ddx(j)+aincr
12677           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12678           call int_from_cart1(.false.)
12679           if (.not.split_ene) then
12680             call zerograd
12681             call etotal(energia1)
12682             etot1=energia1(0)
12683           else
12684 !- split gradient
12685             call etotal_long(energia1)
12686             etot11=energia1(0)
12687             call etotal_short(energia1)
12688             etot12=energia1(0)
12689           endif
12690 !- end split gradient
12691         c(j,i+nres)=ddx(j)-aincr
12692           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12693           call int_from_cart1(.false.)
12694           if (.not.split_ene) then
12695            call zerograd
12696            call etotal(energia1)
12697             etot2=energia1(0)
12698           ggg(j+3)=(etot1-etot2)/(2*aincr)
12699           else
12700 !- split gradient
12701             call etotal_long(energia1)
12702             etot21=energia1(0)
12703           ggg(j+3)=(etot11-etot21)/(2*aincr)
12704             call etotal_short(energia1)
12705             etot22=energia1(0)
12706           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12707 !- end split gradient
12708           endif
12709 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12710         c(j,i+nres)=ddx(j)
12711           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12712           dc_norm(j,i+nres)=dxnorm_safe(j)
12713           call int_from_cart1(.false.)
12714         enddo
12715       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12716          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12717         if (split_ene) then
12718           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12719          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12720          k=1,6)
12721          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12722          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12723          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12724         endif
12725       enddo
12726       return
12727       end subroutine check_ecartint
12728 #else
12729 !-----------------------------------------------------------------------------
12730       subroutine check_ecartint
12731 ! Check the gradient of the energy in Cartesian coordinates.
12732       use io_base, only: intout
12733 !      implicit real*8 (a-h,o-z)
12734 !      include 'DIMENSIONS'
12735 !      include 'COMMON.CONTROL'
12736 !      include 'COMMON.CHAIN'
12737 !      include 'COMMON.DERIV'
12738 !      include 'COMMON.IOUNITS'
12739 !      include 'COMMON.VAR'
12740 !      include 'COMMON.CONTACTS'
12741 !      include 'COMMON.MD'
12742 !      include 'COMMON.LOCAL'
12743 !      include 'COMMON.SPLITELE'
12744       use comm_srutu
12745 !el      integer :: icall
12746 !el      common /srutu/ icall
12747       real(kind=8),dimension(6) :: ggg,ggg1
12748       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12749       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12750       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12751       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12752       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12753       real(kind=8),dimension(0:n_ene) :: energia,energia1
12754       integer :: uiparm(1)
12755       real(kind=8) :: urparm(1)
12756 !EL      external fdum
12757       integer :: i,j,k,nf
12758       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12759                    etot21,etot22
12760       r_cut=2.0d0
12761       rlambd=0.3d0
12762       icg=1
12763       nf=0
12764       nfl=0
12765       call intout
12766 !      call intcartderiv
12767 !      call checkintcartgrad
12768       call zerograd
12769       aincr=1.0D-7
12770       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12771       nf=0
12772       icall=0
12773       call geom_to_var(nvar,x)
12774       if (.not.split_ene) then
12775         call etotal(energia)
12776         etot=energia(0)
12777 !el        call enerprint(energia)
12778         call cartgrad
12779         icall =1
12780         do i=1,nres
12781           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12782         enddo
12783         do j=1,3
12784           grad_s(j,0)=gcart(j,0)
12785         enddo
12786         do i=1,nres
12787           do j=1,3
12788             grad_s(j,i)=gcart(j,i)
12789 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12790
12791 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12792             grad_s(j+3,i)=gxcart(j,i)
12793           enddo
12794         enddo
12795       else
12796 !- split gradient check
12797         call zerograd
12798         call etotal_long(energia)
12799 !el        call enerprint(energia)
12800         call cartgrad
12801         icall =1
12802         do i=1,nres
12803           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12804           (gxcart(j,i),j=1,3)
12805         enddo
12806         do j=1,3
12807           grad_s(j,0)=gcart(j,0)
12808         enddo
12809         do i=1,nres
12810           do j=1,3
12811             grad_s(j,i)=gcart(j,i)
12812 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12813             grad_s(j+3,i)=gxcart(j,i)
12814           enddo
12815         enddo
12816         call zerograd
12817         call etotal_short(energia)
12818 !el        call enerprint(energia)
12819         call cartgrad
12820         icall =1
12821         do i=1,nres
12822           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12823           (gxcart(j,i),j=1,3)
12824         enddo
12825         do j=1,3
12826           grad_s1(j,0)=gcart(j,0)
12827         enddo
12828         do i=1,nres
12829           do j=1,3
12830             grad_s1(j,i)=gcart(j,i)
12831             grad_s1(j+3,i)=gxcart(j,i)
12832           enddo
12833         enddo
12834       endif
12835       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12836       do i=0,nres
12837         do j=1,3
12838         xx(j)=c(j,i+nres)
12839         ddc(j)=dc(j,i)
12840         ddx(j)=dc(j,i+nres)
12841           do k=1,3
12842             dcnorm_safe(k)=dc_norm(k,i)
12843             dxnorm_safe(k)=dc_norm(k,i+nres)
12844           enddo
12845         enddo
12846       do j=1,3
12847         dc(j,i)=ddc(j)+aincr
12848           call chainbuild_cart
12849 #ifdef MPI
12850 ! Broadcast the order to compute internal coordinates to the slaves.
12851 !          if (nfgtasks.gt.1)
12852 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12853 #endif
12854 !          call int_from_cart1(.false.)
12855           if (.not.split_ene) then
12856            call zerograd
12857             call etotal(energia1)
12858             etot1=energia1(0)
12859 !            call enerprint(energia1)
12860           else
12861 !- split gradient
12862             call etotal_long(energia1)
12863             etot11=energia1(0)
12864             call etotal_short(energia1)
12865             etot12=energia1(0)
12866 !            write (iout,*) "etot11",etot11," etot12",etot12
12867           endif
12868 !- end split gradient
12869 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12870         dc(j,i)=ddc(j)-aincr
12871           call chainbuild_cart
12872 !          call int_from_cart1(.false.)
12873           if (.not.split_ene) then
12874                   call zerograd
12875             call etotal(energia1)
12876             etot2=energia1(0)
12877           ggg(j)=(etot1-etot2)/(2*aincr)
12878           else
12879 !- split gradient
12880             call etotal_long(energia1)
12881             etot21=energia1(0)
12882           ggg(j)=(etot11-etot21)/(2*aincr)
12883             call etotal_short(energia1)
12884             etot22=energia1(0)
12885           ggg1(j)=(etot12-etot22)/(2*aincr)
12886 !- end split gradient
12887 !            write (iout,*) "etot21",etot21," etot22",etot22
12888           endif
12889 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12890         dc(j,i)=ddc(j)
12891           call chainbuild_cart
12892         enddo
12893       do j=1,3
12894         dc(j,i+nres)=ddx(j)+aincr
12895           call chainbuild_cart
12896 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12897 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12898 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12899 !          write (iout,*) "dxnormnorm",dsqrt(
12900 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12901 !          write (iout,*) "dxnormnormsafe",dsqrt(
12902 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12903 !          write (iout,*)
12904           if (.not.split_ene) then
12905             call zerograd
12906             call etotal(energia1)
12907             etot1=energia1(0)
12908           else
12909 !- split gradient
12910             call etotal_long(energia1)
12911             etot11=energia1(0)
12912             call etotal_short(energia1)
12913             etot12=energia1(0)
12914           endif
12915 !- end split gradient
12916 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12917         dc(j,i+nres)=ddx(j)-aincr
12918           call chainbuild_cart
12919 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12920 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12921 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12922 !          write (iout,*)
12923 !          write (iout,*) "dxnormnorm",dsqrt(
12924 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12925 !          write (iout,*) "dxnormnormsafe",dsqrt(
12926 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12927           if (.not.split_ene) then
12928             call zerograd
12929             call etotal(energia1)
12930             etot2=energia1(0)
12931           ggg(j+3)=(etot1-etot2)/(2*aincr)
12932           else
12933 !- split gradient
12934             call etotal_long(energia1)
12935             etot21=energia1(0)
12936           ggg(j+3)=(etot11-etot21)/(2*aincr)
12937             call etotal_short(energia1)
12938             etot22=energia1(0)
12939           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12940 !- end split gradient
12941           endif
12942 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12943         dc(j,i+nres)=ddx(j)
12944           call chainbuild_cart
12945         enddo
12946       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12947          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12948         if (split_ene) then
12949           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12950          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12951          k=1,6)
12952          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12953          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12954          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12955         endif
12956       enddo
12957       return
12958       end subroutine check_ecartint
12959 #endif
12960 !-----------------------------------------------------------------------------
12961       subroutine check_eint
12962 ! Check the gradient of energy in internal coordinates.
12963 !      implicit real*8 (a-h,o-z)
12964 !      include 'DIMENSIONS'
12965 !      include 'COMMON.CHAIN'
12966 !      include 'COMMON.DERIV'
12967 !      include 'COMMON.IOUNITS'
12968 !      include 'COMMON.VAR'
12969 !      include 'COMMON.GEO'
12970       use comm_srutu
12971 !el      integer :: icall
12972 !el      common /srutu/ icall
12973       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12974       integer :: uiparm(1)
12975       real(kind=8) :: urparm(1)
12976       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12977       character(len=6) :: key
12978 !EL      external fdum
12979       integer :: i,ii,nf
12980       real(kind=8) :: xi,aincr,etot,etot1,etot2
12981       call zerograd
12982       aincr=1.0D-7
12983       print '(a)','Calling CHECK_INT.'
12984       nf=0
12985       nfl=0
12986       icg=1
12987       call geom_to_var(nvar,x)
12988       call var_to_geom(nvar,x)
12989       call chainbuild
12990       icall=1
12991 !      print *,'ICG=',ICG
12992       call etotal(energia)
12993       etot = energia(0)
12994 !el      call enerprint(energia)
12995 !      print *,'ICG=',ICG
12996 #ifdef MPL
12997       if (MyID.ne.BossID) then
12998         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12999         nf=x(nvar+1)
13000         nfl=x(nvar+2)
13001         icg=x(nvar+3)
13002       endif
13003 #endif
13004       nf=1
13005       nfl=3
13006 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13007       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13008 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13009       icall=1
13010       do i=1,nvar
13011         xi=x(i)
13012         x(i)=xi-0.5D0*aincr
13013         call var_to_geom(nvar,x)
13014         call chainbuild
13015         call etotal(energia1)
13016         etot1=energia1(0)
13017         x(i)=xi+0.5D0*aincr
13018         call var_to_geom(nvar,x)
13019         call chainbuild
13020         call etotal(energia2)
13021         etot2=energia2(0)
13022         gg(i)=(etot2-etot1)/aincr
13023         write (iout,*) i,etot1,etot2
13024         x(i)=xi
13025       enddo
13026       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13027           '     RelDiff*100% '
13028       do i=1,nvar
13029         if (i.le.nphi) then
13030           ii=i
13031           key = ' phi'
13032         else if (i.le.nphi+ntheta) then
13033           ii=i-nphi
13034           key=' theta'
13035         else if (i.le.nphi+ntheta+nside) then
13036            ii=i-(nphi+ntheta)
13037            key=' alpha'
13038         else
13039            ii=i-(nphi+ntheta+nside)
13040            key=' omega'
13041         endif
13042         write (iout,'(i3,a,i3,3(1pd16.6))') &
13043        i,key,ii,gg(i),gana(i),&
13044        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13045       enddo
13046       return
13047       end subroutine check_eint
13048 !-----------------------------------------------------------------------------
13049 ! econstr_local.F
13050 !-----------------------------------------------------------------------------
13051       subroutine Econstr_back
13052 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13053 !      implicit real*8 (a-h,o-z)
13054 !      include 'DIMENSIONS'
13055 !      include 'COMMON.CONTROL'
13056 !      include 'COMMON.VAR'
13057 !      include 'COMMON.MD'
13058       use MD_data
13059 !#ifndef LANG0
13060 !      include 'COMMON.LANGEVIN'
13061 !#else
13062 !      include 'COMMON.LANGEVIN.lang0'
13063 !#endif
13064 !      include 'COMMON.CHAIN'
13065 !      include 'COMMON.DERIV'
13066 !      include 'COMMON.GEO'
13067 !      include 'COMMON.LOCAL'
13068 !      include 'COMMON.INTERACT'
13069 !      include 'COMMON.IOUNITS'
13070 !      include 'COMMON.NAMES'
13071 !      include 'COMMON.TIME1'
13072       integer :: i,j,ii,k
13073       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13074
13075       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13076       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13077       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13078
13079       Uconst_back=0.0d0
13080       do i=1,nres
13081         dutheta(i)=0.0d0
13082         dugamma(i)=0.0d0
13083         do j=1,3
13084           duscdiff(j,i)=0.0d0
13085           duscdiffx(j,i)=0.0d0
13086         enddo
13087       enddo
13088       do i=1,nfrag_back
13089         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13090 !
13091 ! Deviations from theta angles
13092 !
13093         utheta_i=0.0d0
13094         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13095           dtheta_i=theta(j)-thetaref(j)
13096           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13097           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13098         enddo
13099         utheta(i)=utheta_i/(ii-1)
13100 !
13101 ! Deviations from gamma angles
13102 !
13103         ugamma_i=0.0d0
13104         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13105           dgamma_i=pinorm(phi(j)-phiref(j))
13106 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13107           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13108           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13109 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13110         enddo
13111         ugamma(i)=ugamma_i/(ii-2)
13112 !
13113 ! Deviations from local SC geometry
13114 !
13115         uscdiff(i)=0.0d0
13116         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13117           dxx=xxtab(j)-xxref(j)
13118           dyy=yytab(j)-yyref(j)
13119           dzz=zztab(j)-zzref(j)
13120           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13121           do k=1,3
13122             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13123              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13124              (ii-1)
13125             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13126              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13127              (ii-1)
13128             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13129            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13130             /(ii-1)
13131           enddo
13132 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13133 !     &      xxref(j),yyref(j),zzref(j)
13134         enddo
13135         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13136 !        write (iout,*) i," uscdiff",uscdiff(i)
13137 !
13138 ! Put together deviations from local geometry
13139 !
13140         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13141           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13142 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13143 !     &   " uconst_back",uconst_back
13144         utheta(i)=dsqrt(utheta(i))
13145         ugamma(i)=dsqrt(ugamma(i))
13146         uscdiff(i)=dsqrt(uscdiff(i))
13147       enddo
13148       return
13149       end subroutine Econstr_back
13150 !-----------------------------------------------------------------------------
13151 ! energy_p_new-sep_barrier.F
13152 !-----------------------------------------------------------------------------
13153       real(kind=8) function sscale(r)
13154 !      include "COMMON.SPLITELE"
13155       real(kind=8) :: r,gamm
13156       if(r.lt.r_cut-rlamb) then
13157         sscale=1.0d0
13158       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13159         gamm=(r-(r_cut-rlamb))/rlamb
13160         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13161       else
13162         sscale=0d0
13163       endif
13164       return
13165       end function sscale
13166       real(kind=8) function sscale_grad(r)
13167 !      include "COMMON.SPLITELE"
13168       real(kind=8) :: r,gamm
13169       if(r.lt.r_cut-rlamb) then
13170         sscale_grad=0.0d0
13171       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13172         gamm=(r-(r_cut-rlamb))/rlamb
13173         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13174       else
13175         sscale_grad=0d0
13176       endif
13177       return
13178       end function sscale_grad
13179
13180 !!!!!!!!!! PBCSCALE
13181       real(kind=8) function sscale_ele(r)
13182 !      include "COMMON.SPLITELE"
13183       real(kind=8) :: r,gamm
13184       if(r.lt.r_cut_ele-rlamb_ele) then
13185         sscale_ele=1.0d0
13186       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13187         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13188         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13189       else
13190         sscale_ele=0d0
13191       endif
13192       return
13193       end function sscale_ele
13194
13195       real(kind=8)  function sscagrad_ele(r)
13196       real(kind=8) :: r,gamm
13197 !      include "COMMON.SPLITELE"
13198       if(r.lt.r_cut_ele-rlamb_ele) then
13199         sscagrad_ele=0.0d0
13200       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13201         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13202         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13203       else
13204         sscagrad_ele=0.0d0
13205       endif
13206       return
13207       end function sscagrad_ele
13208       real(kind=8) function sscalelip(r)
13209       real(kind=8) r,gamm
13210         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13211       return
13212       end function sscalelip
13213 !C-----------------------------------------------------------------------
13214       real(kind=8) function sscagradlip(r)
13215       real(kind=8) r,gamm
13216         sscagradlip=r*(6.0d0*r-6.0d0)
13217       return
13218       end function sscagradlip
13219
13220 !!!!!!!!!!!!!!!
13221 !-----------------------------------------------------------------------------
13222       subroutine elj_long(evdw)
13223 !
13224 ! This subroutine calculates the interaction energy of nonbonded side chains
13225 ! assuming the LJ potential of interaction.
13226 !
13227 !      implicit real*8 (a-h,o-z)
13228 !      include 'DIMENSIONS'
13229 !      include 'COMMON.GEO'
13230 !      include 'COMMON.VAR'
13231 !      include 'COMMON.LOCAL'
13232 !      include 'COMMON.CHAIN'
13233 !      include 'COMMON.DERIV'
13234 !      include 'COMMON.INTERACT'
13235 !      include 'COMMON.TORSION'
13236 !      include 'COMMON.SBRIDGE'
13237 !      include 'COMMON.NAMES'
13238 !      include 'COMMON.IOUNITS'
13239 !      include 'COMMON.CONTACTS'
13240       real(kind=8),parameter :: accur=1.0d-10
13241       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13242 !el local variables
13243       integer :: i,iint,j,k,itypi,itypi1,itypj
13244       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13245       real(kind=8) :: e1,e2,evdwij,evdw
13246 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13247       evdw=0.0D0
13248       do i=iatsc_s,iatsc_e
13249         itypi=itype(i,1)
13250         if (itypi.eq.ntyp1) cycle
13251         itypi1=itype(i+1,1)
13252         xi=c(1,nres+i)
13253         yi=c(2,nres+i)
13254         zi=c(3,nres+i)
13255 !
13256 ! Calculate SC interaction energy.
13257 !
13258         do iint=1,nint_gr(i)
13259 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13260 !d   &                  'iend=',iend(i,iint)
13261           do j=istart(i,iint),iend(i,iint)
13262             itypj=itype(j,1)
13263             if (itypj.eq.ntyp1) cycle
13264             xj=c(1,nres+j)-xi
13265             yj=c(2,nres+j)-yi
13266             zj=c(3,nres+j)-zi
13267             rij=xj*xj+yj*yj+zj*zj
13268             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13269             if (sss.lt.1.0d0) then
13270               rrij=1.0D0/rij
13271               eps0ij=eps(itypi,itypj)
13272               fac=rrij**expon2
13273               e1=fac*fac*aa_aq(itypi,itypj)
13274               e2=fac*bb_aq(itypi,itypj)
13275               evdwij=e1+e2
13276               evdw=evdw+(1.0d0-sss)*evdwij
13277 !
13278 ! Calculate the components of the gradient in DC and X
13279 !
13280               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13281               gg(1)=xj*fac
13282               gg(2)=yj*fac
13283               gg(3)=zj*fac
13284               do k=1,3
13285                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13286                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13287                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13288                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13289               enddo
13290             endif
13291           enddo      ! j
13292         enddo        ! iint
13293       enddo          ! i
13294       do i=1,nct
13295         do j=1,3
13296           gvdwc(j,i)=expon*gvdwc(j,i)
13297           gvdwx(j,i)=expon*gvdwx(j,i)
13298         enddo
13299       enddo
13300 !******************************************************************************
13301 !
13302 !                              N O T E !!!
13303 !
13304 ! To save time, the factor of EXPON has been extracted from ALL components
13305 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13306 ! use!
13307 !
13308 !******************************************************************************
13309       return
13310       end subroutine elj_long
13311 !-----------------------------------------------------------------------------
13312       subroutine elj_short(evdw)
13313 !
13314 ! This subroutine calculates the interaction energy of nonbonded side chains
13315 ! assuming the LJ potential of interaction.
13316 !
13317 !      implicit real*8 (a-h,o-z)
13318 !      include 'DIMENSIONS'
13319 !      include 'COMMON.GEO'
13320 !      include 'COMMON.VAR'
13321 !      include 'COMMON.LOCAL'
13322 !      include 'COMMON.CHAIN'
13323 !      include 'COMMON.DERIV'
13324 !      include 'COMMON.INTERACT'
13325 !      include 'COMMON.TORSION'
13326 !      include 'COMMON.SBRIDGE'
13327 !      include 'COMMON.NAMES'
13328 !      include 'COMMON.IOUNITS'
13329 !      include 'COMMON.CONTACTS'
13330       real(kind=8),parameter :: accur=1.0d-10
13331       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13332 !el local variables
13333       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13334       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13335       real(kind=8) :: e1,e2,evdwij,evdw
13336 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13337       evdw=0.0D0
13338       do i=iatsc_s,iatsc_e
13339         itypi=itype(i,1)
13340         if (itypi.eq.ntyp1) cycle
13341         itypi1=itype(i+1,1)
13342         xi=c(1,nres+i)
13343         yi=c(2,nres+i)
13344         zi=c(3,nres+i)
13345 ! Change 12/1/95
13346         num_conti=0
13347 !
13348 ! Calculate SC interaction energy.
13349 !
13350         do iint=1,nint_gr(i)
13351 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13352 !d   &                  'iend=',iend(i,iint)
13353           do j=istart(i,iint),iend(i,iint)
13354             itypj=itype(j,1)
13355             if (itypj.eq.ntyp1) cycle
13356             xj=c(1,nres+j)-xi
13357             yj=c(2,nres+j)-yi
13358             zj=c(3,nres+j)-zi
13359 ! Change 12/1/95 to calculate four-body interactions
13360             rij=xj*xj+yj*yj+zj*zj
13361             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13362             if (sss.gt.0.0d0) then
13363               rrij=1.0D0/rij
13364               eps0ij=eps(itypi,itypj)
13365               fac=rrij**expon2
13366               e1=fac*fac*aa_aq(itypi,itypj)
13367               e2=fac*bb_aq(itypi,itypj)
13368               evdwij=e1+e2
13369               evdw=evdw+sss*evdwij
13370 !
13371 ! Calculate the components of the gradient in DC and X
13372 !
13373               fac=-rrij*(e1+evdwij)*sss
13374               gg(1)=xj*fac
13375               gg(2)=yj*fac
13376               gg(3)=zj*fac
13377               do k=1,3
13378                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13379                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13380                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13381                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13382               enddo
13383             endif
13384           enddo      ! j
13385         enddo        ! iint
13386       enddo          ! i
13387       do i=1,nct
13388         do j=1,3
13389           gvdwc(j,i)=expon*gvdwc(j,i)
13390           gvdwx(j,i)=expon*gvdwx(j,i)
13391         enddo
13392       enddo
13393 !******************************************************************************
13394 !
13395 !                              N O T E !!!
13396 !
13397 ! To save time, the factor of EXPON has been extracted from ALL components
13398 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13399 ! use!
13400 !
13401 !******************************************************************************
13402       return
13403       end subroutine elj_short
13404 !-----------------------------------------------------------------------------
13405       subroutine eljk_long(evdw)
13406 !
13407 ! This subroutine calculates the interaction energy of nonbonded side chains
13408 ! assuming the LJK potential of interaction.
13409 !
13410 !      implicit real*8 (a-h,o-z)
13411 !      include 'DIMENSIONS'
13412 !      include 'COMMON.GEO'
13413 !      include 'COMMON.VAR'
13414 !      include 'COMMON.LOCAL'
13415 !      include 'COMMON.CHAIN'
13416 !      include 'COMMON.DERIV'
13417 !      include 'COMMON.INTERACT'
13418 !      include 'COMMON.IOUNITS'
13419 !      include 'COMMON.NAMES'
13420       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13421       logical :: scheck
13422 !el local variables
13423       integer :: i,iint,j,k,itypi,itypi1,itypj
13424       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13425                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13426 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13427       evdw=0.0D0
13428       do i=iatsc_s,iatsc_e
13429         itypi=itype(i,1)
13430         if (itypi.eq.ntyp1) cycle
13431         itypi1=itype(i+1,1)
13432         xi=c(1,nres+i)
13433         yi=c(2,nres+i)
13434         zi=c(3,nres+i)
13435 !
13436 ! Calculate SC interaction energy.
13437 !
13438         do iint=1,nint_gr(i)
13439           do j=istart(i,iint),iend(i,iint)
13440             itypj=itype(j,1)
13441             if (itypj.eq.ntyp1) cycle
13442             xj=c(1,nres+j)-xi
13443             yj=c(2,nres+j)-yi
13444             zj=c(3,nres+j)-zi
13445             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13446             fac_augm=rrij**expon
13447             e_augm=augm(itypi,itypj)*fac_augm
13448             r_inv_ij=dsqrt(rrij)
13449             rij=1.0D0/r_inv_ij
13450             sss=sscale(rij/sigma(itypi,itypj))
13451             if (sss.lt.1.0d0) then
13452               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13453               fac=r_shift_inv**expon
13454               e1=fac*fac*aa_aq(itypi,itypj)
13455               e2=fac*bb_aq(itypi,itypj)
13456               evdwij=e_augm+e1+e2
13457 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13458 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13459 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13460 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13461 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13462 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13463 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13464               evdw=evdw+(1.0d0-sss)*evdwij
13465 !
13466 ! Calculate the components of the gradient in DC and X
13467 !
13468               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13469               fac=fac*(1.0d0-sss)
13470               gg(1)=xj*fac
13471               gg(2)=yj*fac
13472               gg(3)=zj*fac
13473               do k=1,3
13474                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13475                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13476                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13477                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13478               enddo
13479             endif
13480           enddo      ! j
13481         enddo        ! iint
13482       enddo          ! i
13483       do i=1,nct
13484         do j=1,3
13485           gvdwc(j,i)=expon*gvdwc(j,i)
13486           gvdwx(j,i)=expon*gvdwx(j,i)
13487         enddo
13488       enddo
13489       return
13490       end subroutine eljk_long
13491 !-----------------------------------------------------------------------------
13492       subroutine eljk_short(evdw)
13493 !
13494 ! This subroutine calculates the interaction energy of nonbonded side chains
13495 ! assuming the LJK potential of interaction.
13496 !
13497 !      implicit real*8 (a-h,o-z)
13498 !      include 'DIMENSIONS'
13499 !      include 'COMMON.GEO'
13500 !      include 'COMMON.VAR'
13501 !      include 'COMMON.LOCAL'
13502 !      include 'COMMON.CHAIN'
13503 !      include 'COMMON.DERIV'
13504 !      include 'COMMON.INTERACT'
13505 !      include 'COMMON.IOUNITS'
13506 !      include 'COMMON.NAMES'
13507       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13508       logical :: scheck
13509 !el local variables
13510       integer :: i,iint,j,k,itypi,itypi1,itypj
13511       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13512                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13513 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13514       evdw=0.0D0
13515       do i=iatsc_s,iatsc_e
13516         itypi=itype(i,1)
13517         if (itypi.eq.ntyp1) cycle
13518         itypi1=itype(i+1,1)
13519         xi=c(1,nres+i)
13520         yi=c(2,nres+i)
13521         zi=c(3,nres+i)
13522 !
13523 ! Calculate SC interaction energy.
13524 !
13525         do iint=1,nint_gr(i)
13526           do j=istart(i,iint),iend(i,iint)
13527             itypj=itype(j,1)
13528             if (itypj.eq.ntyp1) cycle
13529             xj=c(1,nres+j)-xi
13530             yj=c(2,nres+j)-yi
13531             zj=c(3,nres+j)-zi
13532             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13533             fac_augm=rrij**expon
13534             e_augm=augm(itypi,itypj)*fac_augm
13535             r_inv_ij=dsqrt(rrij)
13536             rij=1.0D0/r_inv_ij
13537             sss=sscale(rij/sigma(itypi,itypj))
13538             if (sss.gt.0.0d0) then
13539               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13540               fac=r_shift_inv**expon
13541               e1=fac*fac*aa_aq(itypi,itypj)
13542               e2=fac*bb_aq(itypi,itypj)
13543               evdwij=e_augm+e1+e2
13544 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13545 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13546 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13547 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13548 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13549 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13550 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13551               evdw=evdw+sss*evdwij
13552 !
13553 ! Calculate the components of the gradient in DC and X
13554 !
13555               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13556               fac=fac*sss
13557               gg(1)=xj*fac
13558               gg(2)=yj*fac
13559               gg(3)=zj*fac
13560               do k=1,3
13561                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13562                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13563                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13564                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13565               enddo
13566             endif
13567           enddo      ! j
13568         enddo        ! iint
13569       enddo          ! i
13570       do i=1,nct
13571         do j=1,3
13572           gvdwc(j,i)=expon*gvdwc(j,i)
13573           gvdwx(j,i)=expon*gvdwx(j,i)
13574         enddo
13575       enddo
13576       return
13577       end subroutine eljk_short
13578 !-----------------------------------------------------------------------------
13579       subroutine ebp_long(evdw)
13580 !
13581 ! This subroutine calculates the interaction energy of nonbonded side chains
13582 ! assuming the Berne-Pechukas potential of interaction.
13583 !
13584       use calc_data
13585 !      implicit real*8 (a-h,o-z)
13586 !      include 'DIMENSIONS'
13587 !      include 'COMMON.GEO'
13588 !      include 'COMMON.VAR'
13589 !      include 'COMMON.LOCAL'
13590 !      include 'COMMON.CHAIN'
13591 !      include 'COMMON.DERIV'
13592 !      include 'COMMON.NAMES'
13593 !      include 'COMMON.INTERACT'
13594 !      include 'COMMON.IOUNITS'
13595 !      include 'COMMON.CALC'
13596       use comm_srutu
13597 !el      integer :: icall
13598 !el      common /srutu/ icall
13599 !     double precision rrsave(maxdim)
13600       logical :: lprn
13601 !el local variables
13602       integer :: iint,itypi,itypi1,itypj
13603       real(kind=8) :: rrij,xi,yi,zi,fac
13604       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13605       evdw=0.0D0
13606 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13607       evdw=0.0D0
13608 !     if (icall.eq.0) then
13609 !       lprn=.true.
13610 !     else
13611         lprn=.false.
13612 !     endif
13613 !el      ind=0
13614       do i=iatsc_s,iatsc_e
13615         itypi=itype(i,1)
13616         if (itypi.eq.ntyp1) cycle
13617         itypi1=itype(i+1,1)
13618         xi=c(1,nres+i)
13619         yi=c(2,nres+i)
13620         zi=c(3,nres+i)
13621         dxi=dc_norm(1,nres+i)
13622         dyi=dc_norm(2,nres+i)
13623         dzi=dc_norm(3,nres+i)
13624 !        dsci_inv=dsc_inv(itypi)
13625         dsci_inv=vbld_inv(i+nres)
13626 !
13627 ! Calculate SC interaction energy.
13628 !
13629         do iint=1,nint_gr(i)
13630           do j=istart(i,iint),iend(i,iint)
13631 !el            ind=ind+1
13632             itypj=itype(j,1)
13633             if (itypj.eq.ntyp1) cycle
13634 !            dscj_inv=dsc_inv(itypj)
13635             dscj_inv=vbld_inv(j+nres)
13636             chi1=chi(itypi,itypj)
13637             chi2=chi(itypj,itypi)
13638             chi12=chi1*chi2
13639             chip1=chip(itypi)
13640             chip2=chip(itypj)
13641             chip12=chip1*chip2
13642             alf1=alp(itypi)
13643             alf2=alp(itypj)
13644             alf12=0.5D0*(alf1+alf2)
13645             xj=c(1,nres+j)-xi
13646             yj=c(2,nres+j)-yi
13647             zj=c(3,nres+j)-zi
13648             dxj=dc_norm(1,nres+j)
13649             dyj=dc_norm(2,nres+j)
13650             dzj=dc_norm(3,nres+j)
13651             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13652             rij=dsqrt(rrij)
13653             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13654
13655             if (sss.lt.1.0d0) then
13656
13657 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13658               call sc_angular
13659 ! Calculate whole angle-dependent part of epsilon and contributions
13660 ! to its derivatives
13661               fac=(rrij*sigsq)**expon2
13662               e1=fac*fac*aa_aq(itypi,itypj)
13663               e2=fac*bb_aq(itypi,itypj)
13664               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13665               eps2der=evdwij*eps3rt
13666               eps3der=evdwij*eps2rt
13667               evdwij=evdwij*eps2rt*eps3rt
13668               evdw=evdw+evdwij*(1.0d0-sss)
13669               if (lprn) then
13670               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13671               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13672 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13673 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13674 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13675 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13676 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13677 !d     &          evdwij
13678               endif
13679 ! Calculate gradient components.
13680               e1=e1*eps1*eps2rt**2*eps3rt**2
13681               fac=-expon*(e1+evdwij)
13682               sigder=fac/sigsq
13683               fac=rrij*fac
13684 ! Calculate radial part of the gradient
13685               gg(1)=xj*fac
13686               gg(2)=yj*fac
13687               gg(3)=zj*fac
13688 ! Calculate the angular part of the gradient and sum add the contributions
13689 ! to the appropriate components of the Cartesian gradient.
13690               call sc_grad_scale(1.0d0-sss)
13691             endif
13692           enddo      ! j
13693         enddo        ! iint
13694       enddo          ! i
13695 !     stop
13696       return
13697       end subroutine ebp_long
13698 !-----------------------------------------------------------------------------
13699       subroutine ebp_short(evdw)
13700 !
13701 ! This subroutine calculates the interaction energy of nonbonded side chains
13702 ! assuming the Berne-Pechukas potential of interaction.
13703 !
13704       use calc_data
13705 !      implicit real*8 (a-h,o-z)
13706 !      include 'DIMENSIONS'
13707 !      include 'COMMON.GEO'
13708 !      include 'COMMON.VAR'
13709 !      include 'COMMON.LOCAL'
13710 !      include 'COMMON.CHAIN'
13711 !      include 'COMMON.DERIV'
13712 !      include 'COMMON.NAMES'
13713 !      include 'COMMON.INTERACT'
13714 !      include 'COMMON.IOUNITS'
13715 !      include 'COMMON.CALC'
13716       use comm_srutu
13717 !el      integer :: icall
13718 !el      common /srutu/ icall
13719 !     double precision rrsave(maxdim)
13720       logical :: lprn
13721 !el local variables
13722       integer :: iint,itypi,itypi1,itypj
13723       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13724       real(kind=8) :: sss,e1,e2,evdw
13725       evdw=0.0D0
13726 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13727       evdw=0.0D0
13728 !     if (icall.eq.0) then
13729 !       lprn=.true.
13730 !     else
13731         lprn=.false.
13732 !     endif
13733 !el      ind=0
13734       do i=iatsc_s,iatsc_e
13735         itypi=itype(i,1)
13736         if (itypi.eq.ntyp1) cycle
13737         itypi1=itype(i+1,1)
13738         xi=c(1,nres+i)
13739         yi=c(2,nres+i)
13740         zi=c(3,nres+i)
13741         dxi=dc_norm(1,nres+i)
13742         dyi=dc_norm(2,nres+i)
13743         dzi=dc_norm(3,nres+i)
13744 !        dsci_inv=dsc_inv(itypi)
13745         dsci_inv=vbld_inv(i+nres)
13746 !
13747 ! Calculate SC interaction energy.
13748 !
13749         do iint=1,nint_gr(i)
13750           do j=istart(i,iint),iend(i,iint)
13751 !el            ind=ind+1
13752             itypj=itype(j,1)
13753             if (itypj.eq.ntyp1) cycle
13754 !            dscj_inv=dsc_inv(itypj)
13755             dscj_inv=vbld_inv(j+nres)
13756             chi1=chi(itypi,itypj)
13757             chi2=chi(itypj,itypi)
13758             chi12=chi1*chi2
13759             chip1=chip(itypi)
13760             chip2=chip(itypj)
13761             chip12=chip1*chip2
13762             alf1=alp(itypi)
13763             alf2=alp(itypj)
13764             alf12=0.5D0*(alf1+alf2)
13765             xj=c(1,nres+j)-xi
13766             yj=c(2,nres+j)-yi
13767             zj=c(3,nres+j)-zi
13768             dxj=dc_norm(1,nres+j)
13769             dyj=dc_norm(2,nres+j)
13770             dzj=dc_norm(3,nres+j)
13771             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13772             rij=dsqrt(rrij)
13773             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13774
13775             if (sss.gt.0.0d0) then
13776
13777 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13778               call sc_angular
13779 ! Calculate whole angle-dependent part of epsilon and contributions
13780 ! to its derivatives
13781               fac=(rrij*sigsq)**expon2
13782               e1=fac*fac*aa_aq(itypi,itypj)
13783               e2=fac*bb_aq(itypi,itypj)
13784               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13785               eps2der=evdwij*eps3rt
13786               eps3der=evdwij*eps2rt
13787               evdwij=evdwij*eps2rt*eps3rt
13788               evdw=evdw+evdwij*sss
13789               if (lprn) then
13790               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13791               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13792 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13793 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13794 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13795 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13796 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13797 !d     &          evdwij
13798               endif
13799 ! Calculate gradient components.
13800               e1=e1*eps1*eps2rt**2*eps3rt**2
13801               fac=-expon*(e1+evdwij)
13802               sigder=fac/sigsq
13803               fac=rrij*fac
13804 ! Calculate radial part of the gradient
13805               gg(1)=xj*fac
13806               gg(2)=yj*fac
13807               gg(3)=zj*fac
13808 ! Calculate the angular part of the gradient and sum add the contributions
13809 ! to the appropriate components of the Cartesian gradient.
13810               call sc_grad_scale(sss)
13811             endif
13812           enddo      ! j
13813         enddo        ! iint
13814       enddo          ! i
13815 !     stop
13816       return
13817       end subroutine ebp_short
13818 !-----------------------------------------------------------------------------
13819       subroutine egb_long(evdw)
13820 !
13821 ! This subroutine calculates the interaction energy of nonbonded side chains
13822 ! assuming the Gay-Berne potential of interaction.
13823 !
13824       use calc_data
13825 !      implicit real*8 (a-h,o-z)
13826 !      include 'DIMENSIONS'
13827 !      include 'COMMON.GEO'
13828 !      include 'COMMON.VAR'
13829 !      include 'COMMON.LOCAL'
13830 !      include 'COMMON.CHAIN'
13831 !      include 'COMMON.DERIV'
13832 !      include 'COMMON.NAMES'
13833 !      include 'COMMON.INTERACT'
13834 !      include 'COMMON.IOUNITS'
13835 !      include 'COMMON.CALC'
13836 !      include 'COMMON.CONTROL'
13837       logical :: lprn
13838 !el local variables
13839       integer :: iint,itypi,itypi1,itypj,subchap
13840       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13841       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13842       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13843                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13844                     ssgradlipi,ssgradlipj
13845
13846
13847       evdw=0.0D0
13848 !cccc      energy_dec=.false.
13849 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13850       evdw=0.0D0
13851       lprn=.false.
13852 !     if (icall.eq.0) lprn=.false.
13853 !el      ind=0
13854       do i=iatsc_s,iatsc_e
13855         itypi=itype(i,1)
13856         if (itypi.eq.ntyp1) cycle
13857         itypi1=itype(i+1,1)
13858         xi=c(1,nres+i)
13859         yi=c(2,nres+i)
13860         zi=c(3,nres+i)
13861           xi=mod(xi,boxxsize)
13862           if (xi.lt.0) xi=xi+boxxsize
13863           yi=mod(yi,boxysize)
13864           if (yi.lt.0) yi=yi+boxysize
13865           zi=mod(zi,boxzsize)
13866           if (zi.lt.0) zi=zi+boxzsize
13867        if ((zi.gt.bordlipbot)    &
13868         .and.(zi.lt.bordliptop)) then
13869 !C the energy transfer exist
13870         if (zi.lt.buflipbot) then
13871 !C what fraction I am in
13872          fracinbuf=1.0d0-    &
13873              ((zi-bordlipbot)/lipbufthick)
13874 !C lipbufthick is thickenes of lipid buffore
13875          sslipi=sscalelip(fracinbuf)
13876          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13877         elseif (zi.gt.bufliptop) then
13878          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13879          sslipi=sscalelip(fracinbuf)
13880          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13881         else
13882          sslipi=1.0d0
13883          ssgradlipi=0.0
13884         endif
13885        else
13886          sslipi=0.0d0
13887          ssgradlipi=0.0
13888        endif
13889
13890         dxi=dc_norm(1,nres+i)
13891         dyi=dc_norm(2,nres+i)
13892         dzi=dc_norm(3,nres+i)
13893 !        dsci_inv=dsc_inv(itypi)
13894         dsci_inv=vbld_inv(i+nres)
13895 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13896 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13897 !
13898 ! Calculate SC interaction energy.
13899 !
13900         do iint=1,nint_gr(i)
13901           do j=istart(i,iint),iend(i,iint)
13902             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13903 !              call dyn_ssbond_ene(i,j,evdwij)
13904 !              evdw=evdw+evdwij
13905 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13906 !                              'evdw',i,j,evdwij,' ss'
13907 !              if (energy_dec) write (iout,*) &
13908 !                              'evdw',i,j,evdwij,' ss'
13909 !             do k=j+1,iend(i,iint)
13910 !C search over all next residues
13911 !              if (dyn_ss_mask(k)) then
13912 !C check if they are cysteins
13913 !C              write(iout,*) 'k=',k
13914
13915 !c              write(iout,*) "PRZED TRI", evdwij
13916 !               evdwij_przed_tri=evdwij
13917 !              call triple_ssbond_ene(i,j,k,evdwij)
13918 !c               if(evdwij_przed_tri.ne.evdwij) then
13919 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13920 !c               endif
13921
13922 !c              write(iout,*) "PO TRI", evdwij
13923 !C call the energy function that removes the artifical triple disulfide
13924 !C bond the soubroutine is located in ssMD.F
13925 !              evdw=evdw+evdwij
13926               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13927                             'evdw',i,j,evdwij,'tss'
13928 !              endif!dyn_ss_mask(k)
13929 !             enddo! k
13930
13931             ELSE
13932 !el            ind=ind+1
13933             itypj=itype(j,1)
13934             if (itypj.eq.ntyp1) cycle
13935 !            dscj_inv=dsc_inv(itypj)
13936             dscj_inv=vbld_inv(j+nres)
13937 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13938 !     &       1.0d0/vbld(j+nres)
13939 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13940             sig0ij=sigma(itypi,itypj)
13941             chi1=chi(itypi,itypj)
13942             chi2=chi(itypj,itypi)
13943             chi12=chi1*chi2
13944             chip1=chip(itypi)
13945             chip2=chip(itypj)
13946             chip12=chip1*chip2
13947             alf1=alp(itypi)
13948             alf2=alp(itypj)
13949             alf12=0.5D0*(alf1+alf2)
13950             xj=c(1,nres+j)
13951             yj=c(2,nres+j)
13952             zj=c(3,nres+j)
13953 ! Searching for nearest neighbour
13954           xj=mod(xj,boxxsize)
13955           if (xj.lt.0) xj=xj+boxxsize
13956           yj=mod(yj,boxysize)
13957           if (yj.lt.0) yj=yj+boxysize
13958           zj=mod(zj,boxzsize)
13959           if (zj.lt.0) zj=zj+boxzsize
13960        if ((zj.gt.bordlipbot)   &
13961       .and.(zj.lt.bordliptop)) then
13962 !C the energy transfer exist
13963         if (zj.lt.buflipbot) then
13964 !C what fraction I am in
13965          fracinbuf=1.0d0-  &
13966              ((zj-bordlipbot)/lipbufthick)
13967 !C lipbufthick is thickenes of lipid buffore
13968          sslipj=sscalelip(fracinbuf)
13969          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13970         elseif (zj.gt.bufliptop) then
13971          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13972          sslipj=sscalelip(fracinbuf)
13973          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13974         else
13975          sslipj=1.0d0
13976          ssgradlipj=0.0
13977         endif
13978        else
13979          sslipj=0.0d0
13980          ssgradlipj=0.0
13981        endif
13982       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13983        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13984       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13985        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13986
13987           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13988           xj_safe=xj
13989           yj_safe=yj
13990           zj_safe=zj
13991           subchap=0
13992           do xshift=-1,1
13993           do yshift=-1,1
13994           do zshift=-1,1
13995           xj=xj_safe+xshift*boxxsize
13996           yj=yj_safe+yshift*boxysize
13997           zj=zj_safe+zshift*boxzsize
13998           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13999           if(dist_temp.lt.dist_init) then
14000             dist_init=dist_temp
14001             xj_temp=xj
14002             yj_temp=yj
14003             zj_temp=zj
14004             subchap=1
14005           endif
14006           enddo
14007           enddo
14008           enddo
14009           if (subchap.eq.1) then
14010           xj=xj_temp-xi
14011           yj=yj_temp-yi
14012           zj=zj_temp-zi
14013           else
14014           xj=xj_safe-xi
14015           yj=yj_safe-yi
14016           zj=zj_safe-zi
14017           endif
14018
14019             dxj=dc_norm(1,nres+j)
14020             dyj=dc_norm(2,nres+j)
14021             dzj=dc_norm(3,nres+j)
14022             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14023             rij=dsqrt(rrij)
14024             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14025             sss_ele_cut=sscale_ele(1.0d0/(rij))
14026             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14027             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14028             if (sss_ele_cut.le.0.0) cycle
14029             if (sss.lt.1.0d0) then
14030
14031 ! Calculate angle-dependent terms of energy and contributions to their
14032 ! derivatives.
14033               call sc_angular
14034               sigsq=1.0D0/sigsq
14035               sig=sig0ij*dsqrt(sigsq)
14036               rij_shift=1.0D0/rij-sig+sig0ij
14037 ! for diagnostics; uncomment
14038 !              rij_shift=1.2*sig0ij
14039 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14040               if (rij_shift.le.0.0D0) then
14041                 evdw=1.0D20
14042 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14043 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14044 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14045                 return
14046               endif
14047               sigder=-sig*sigsq
14048 !---------------------------------------------------------------
14049               rij_shift=1.0D0/rij_shift
14050               fac=rij_shift**expon
14051               e1=fac*fac*aa
14052               e2=fac*bb
14053               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14054               eps2der=evdwij*eps3rt
14055               eps3der=evdwij*eps2rt
14056 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14057 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14058               evdwij=evdwij*eps2rt*eps3rt
14059               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14060               if (lprn) then
14061               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14062               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14063               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14064                 restyp(itypi,1),i,restyp(itypj,1),j,&
14065                 epsi,sigm,chi1,chi2,chip1,chip2,&
14066                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14067                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14068                 evdwij
14069               endif
14070
14071               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14072                               'evdw',i,j,evdwij
14073 !              if (energy_dec) write (iout,*) &
14074 !                              'evdw',i,j,evdwij,"egb_long"
14075
14076 ! Calculate gradient components.
14077               e1=e1*eps1*eps2rt**2*eps3rt**2
14078               fac=-expon*(e1+evdwij)*rij_shift
14079               sigder=fac*sigder
14080               fac=rij*fac
14081               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14082               *rij-sss_grad/(1.0-sss)*rij  &
14083             /sigmaii(itypi,itypj))
14084 !              fac=0.0d0
14085 ! Calculate the radial part of the gradient
14086               gg(1)=xj*fac
14087               gg(2)=yj*fac
14088               gg(3)=zj*fac
14089 ! Calculate angular part of the gradient.
14090               call sc_grad_scale(1.0d0-sss)
14091             ENDIF    !mask_dyn_ss
14092             endif
14093           enddo      ! j
14094         enddo        ! iint
14095       enddo          ! i
14096 !      write (iout,*) "Number of loop steps in EGB:",ind
14097 !ccc      energy_dec=.false.
14098       return
14099       end subroutine egb_long
14100 !-----------------------------------------------------------------------------
14101       subroutine egb_short(evdw)
14102 !
14103 ! This subroutine calculates the interaction energy of nonbonded side chains
14104 ! assuming the Gay-Berne potential of interaction.
14105 !
14106       use calc_data
14107 !      implicit real*8 (a-h,o-z)
14108 !      include 'DIMENSIONS'
14109 !      include 'COMMON.GEO'
14110 !      include 'COMMON.VAR'
14111 !      include 'COMMON.LOCAL'
14112 !      include 'COMMON.CHAIN'
14113 !      include 'COMMON.DERIV'
14114 !      include 'COMMON.NAMES'
14115 !      include 'COMMON.INTERACT'
14116 !      include 'COMMON.IOUNITS'
14117 !      include 'COMMON.CALC'
14118 !      include 'COMMON.CONTROL'
14119       logical :: lprn
14120 !el local variables
14121       integer :: iint,itypi,itypi1,itypj,subchap
14122       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14123       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14124       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14125                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14126                     ssgradlipi,ssgradlipj
14127       evdw=0.0D0
14128 !cccc      energy_dec=.false.
14129 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14130       evdw=0.0D0
14131       lprn=.false.
14132 !     if (icall.eq.0) lprn=.false.
14133 !el      ind=0
14134       do i=iatsc_s,iatsc_e
14135         itypi=itype(i,1)
14136         if (itypi.eq.ntyp1) cycle
14137         itypi1=itype(i+1,1)
14138         xi=c(1,nres+i)
14139         yi=c(2,nres+i)
14140         zi=c(3,nres+i)
14141           xi=mod(xi,boxxsize)
14142           if (xi.lt.0) xi=xi+boxxsize
14143           yi=mod(yi,boxysize)
14144           if (yi.lt.0) yi=yi+boxysize
14145           zi=mod(zi,boxzsize)
14146           if (zi.lt.0) zi=zi+boxzsize
14147        if ((zi.gt.bordlipbot)    &
14148         .and.(zi.lt.bordliptop)) then
14149 !C the energy transfer exist
14150         if (zi.lt.buflipbot) then
14151 !C what fraction I am in
14152          fracinbuf=1.0d0-    &
14153              ((zi-bordlipbot)/lipbufthick)
14154 !C lipbufthick is thickenes of lipid buffore
14155          sslipi=sscalelip(fracinbuf)
14156          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14157         elseif (zi.gt.bufliptop) then
14158          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14159          sslipi=sscalelip(fracinbuf)
14160          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14161         else
14162          sslipi=1.0d0
14163          ssgradlipi=0.0
14164         endif
14165        else
14166          sslipi=0.0d0
14167          ssgradlipi=0.0
14168        endif
14169
14170         dxi=dc_norm(1,nres+i)
14171         dyi=dc_norm(2,nres+i)
14172         dzi=dc_norm(3,nres+i)
14173 !        dsci_inv=dsc_inv(itypi)
14174         dsci_inv=vbld_inv(i+nres)
14175
14176         dxi=dc_norm(1,nres+i)
14177         dyi=dc_norm(2,nres+i)
14178         dzi=dc_norm(3,nres+i)
14179 !        dsci_inv=dsc_inv(itypi)
14180         dsci_inv=vbld_inv(i+nres)
14181 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14182 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14183 !
14184 ! Calculate SC interaction energy.
14185 !
14186         do iint=1,nint_gr(i)
14187           do j=istart(i,iint),iend(i,iint)
14188             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14189               call dyn_ssbond_ene(i,j,evdwij)
14190               evdw=evdw+evdwij
14191               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14192                               'evdw',i,j,evdwij,' ss'
14193              do k=j+1,iend(i,iint)
14194 !C search over all next residues
14195               if (dyn_ss_mask(k)) then
14196 !C check if they are cysteins
14197 !C              write(iout,*) 'k=',k
14198
14199 !c              write(iout,*) "PRZED TRI", evdwij
14200 !               evdwij_przed_tri=evdwij
14201               call triple_ssbond_ene(i,j,k,evdwij)
14202 !c               if(evdwij_przed_tri.ne.evdwij) then
14203 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14204 !c               endif
14205
14206 !c              write(iout,*) "PO TRI", evdwij
14207 !C call the energy function that removes the artifical triple disulfide
14208 !C bond the soubroutine is located in ssMD.F
14209               evdw=evdw+evdwij
14210               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14211                             'evdw',i,j,evdwij,'tss'
14212               endif!dyn_ss_mask(k)
14213              enddo! k
14214
14215 !              if (energy_dec) write (iout,*) &
14216 !                              'evdw',i,j,evdwij,' ss'
14217             ELSE
14218 !el            ind=ind+1
14219             itypj=itype(j,1)
14220             if (itypj.eq.ntyp1) cycle
14221 !            dscj_inv=dsc_inv(itypj)
14222             dscj_inv=vbld_inv(j+nres)
14223 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14224 !     &       1.0d0/vbld(j+nres)
14225 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14226             sig0ij=sigma(itypi,itypj)
14227             chi1=chi(itypi,itypj)
14228             chi2=chi(itypj,itypi)
14229             chi12=chi1*chi2
14230             chip1=chip(itypi)
14231             chip2=chip(itypj)
14232             chip12=chip1*chip2
14233             alf1=alp(itypi)
14234             alf2=alp(itypj)
14235             alf12=0.5D0*(alf1+alf2)
14236 !            xj=c(1,nres+j)-xi
14237 !            yj=c(2,nres+j)-yi
14238 !            zj=c(3,nres+j)-zi
14239             xj=c(1,nres+j)
14240             yj=c(2,nres+j)
14241             zj=c(3,nres+j)
14242 ! Searching for nearest neighbour
14243           xj=mod(xj,boxxsize)
14244           if (xj.lt.0) xj=xj+boxxsize
14245           yj=mod(yj,boxysize)
14246           if (yj.lt.0) yj=yj+boxysize
14247           zj=mod(zj,boxzsize)
14248           if (zj.lt.0) zj=zj+boxzsize
14249        if ((zj.gt.bordlipbot)   &
14250       .and.(zj.lt.bordliptop)) then
14251 !C the energy transfer exist
14252         if (zj.lt.buflipbot) then
14253 !C what fraction I am in
14254          fracinbuf=1.0d0-  &
14255              ((zj-bordlipbot)/lipbufthick)
14256 !C lipbufthick is thickenes of lipid buffore
14257          sslipj=sscalelip(fracinbuf)
14258          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14259         elseif (zj.gt.bufliptop) then
14260          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14261          sslipj=sscalelip(fracinbuf)
14262          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14263         else
14264          sslipj=1.0d0
14265          ssgradlipj=0.0
14266         endif
14267        else
14268          sslipj=0.0d0
14269          ssgradlipj=0.0
14270        endif
14271       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14272        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14273       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14274        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14275
14276           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14277           xj_safe=xj
14278           yj_safe=yj
14279           zj_safe=zj
14280           subchap=0
14281
14282           do xshift=-1,1
14283           do yshift=-1,1
14284           do zshift=-1,1
14285           xj=xj_safe+xshift*boxxsize
14286           yj=yj_safe+yshift*boxysize
14287           zj=zj_safe+zshift*boxzsize
14288           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14289           if(dist_temp.lt.dist_init) then
14290             dist_init=dist_temp
14291             xj_temp=xj
14292             yj_temp=yj
14293             zj_temp=zj
14294             subchap=1
14295           endif
14296           enddo
14297           enddo
14298           enddo
14299           if (subchap.eq.1) then
14300           xj=xj_temp-xi
14301           yj=yj_temp-yi
14302           zj=zj_temp-zi
14303           else
14304           xj=xj_safe-xi
14305           yj=yj_safe-yi
14306           zj=zj_safe-zi
14307           endif
14308
14309             dxj=dc_norm(1,nres+j)
14310             dyj=dc_norm(2,nres+j)
14311             dzj=dc_norm(3,nres+j)
14312             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14313             rij=dsqrt(rrij)
14314             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14315             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14316             sss_ele_cut=sscale_ele(1.0d0/(rij))
14317             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14318             if (sss_ele_cut.le.0.0) cycle
14319
14320             if (sss.gt.0.0d0) then
14321
14322 ! Calculate angle-dependent terms of energy and contributions to their
14323 ! derivatives.
14324               call sc_angular
14325               sigsq=1.0D0/sigsq
14326               sig=sig0ij*dsqrt(sigsq)
14327               rij_shift=1.0D0/rij-sig+sig0ij
14328 ! for diagnostics; uncomment
14329 !              rij_shift=1.2*sig0ij
14330 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14331               if (rij_shift.le.0.0D0) then
14332                 evdw=1.0D20
14333 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14334 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14335 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14336                 return
14337               endif
14338               sigder=-sig*sigsq
14339 !---------------------------------------------------------------
14340               rij_shift=1.0D0/rij_shift
14341               fac=rij_shift**expon
14342               e1=fac*fac*aa
14343               e2=fac*bb
14344               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14345               eps2der=evdwij*eps3rt
14346               eps3der=evdwij*eps2rt
14347 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14348 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14349               evdwij=evdwij*eps2rt*eps3rt
14350               evdw=evdw+evdwij*sss*sss_ele_cut
14351               if (lprn) then
14352               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14353               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14354               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14355                 restyp(itypi,1),i,restyp(itypj,1),j,&
14356                 epsi,sigm,chi1,chi2,chip1,chip2,&
14357                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14358                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14359                 evdwij
14360               endif
14361
14362               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14363                               'evdw',i,j,evdwij
14364 !              if (energy_dec) write (iout,*) &
14365 !                              'evdw',i,j,evdwij,"egb_short"
14366
14367 ! Calculate gradient components.
14368               e1=e1*eps1*eps2rt**2*eps3rt**2
14369               fac=-expon*(e1+evdwij)*rij_shift
14370               sigder=fac*sigder
14371               fac=rij*fac
14372               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14373             *rij+sss_grad/sss*rij  &
14374             /sigmaii(itypi,itypj))
14375
14376 !              fac=0.0d0
14377 ! Calculate the radial part of the gradient
14378               gg(1)=xj*fac
14379               gg(2)=yj*fac
14380               gg(3)=zj*fac
14381 ! Calculate angular part of the gradient.
14382               call sc_grad_scale(sss)
14383             endif
14384           ENDIF !mask_dyn_ss
14385           enddo      ! j
14386         enddo        ! iint
14387       enddo          ! i
14388 !      write (iout,*) "Number of loop steps in EGB:",ind
14389 !ccc      energy_dec=.false.
14390       return
14391       end subroutine egb_short
14392 !-----------------------------------------------------------------------------
14393       subroutine egbv_long(evdw)
14394 !
14395 ! This subroutine calculates the interaction energy of nonbonded side chains
14396 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14397 !
14398       use calc_data
14399 !      implicit real*8 (a-h,o-z)
14400 !      include 'DIMENSIONS'
14401 !      include 'COMMON.GEO'
14402 !      include 'COMMON.VAR'
14403 !      include 'COMMON.LOCAL'
14404 !      include 'COMMON.CHAIN'
14405 !      include 'COMMON.DERIV'
14406 !      include 'COMMON.NAMES'
14407 !      include 'COMMON.INTERACT'
14408 !      include 'COMMON.IOUNITS'
14409 !      include 'COMMON.CALC'
14410       use comm_srutu
14411 !el      integer :: icall
14412 !el      common /srutu/ icall
14413       logical :: lprn
14414 !el local variables
14415       integer :: iint,itypi,itypi1,itypj
14416       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14417       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14418       evdw=0.0D0
14419 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14420       evdw=0.0D0
14421       lprn=.false.
14422 !     if (icall.eq.0) lprn=.true.
14423 !el      ind=0
14424       do i=iatsc_s,iatsc_e
14425         itypi=itype(i,1)
14426         if (itypi.eq.ntyp1) cycle
14427         itypi1=itype(i+1,1)
14428         xi=c(1,nres+i)
14429         yi=c(2,nres+i)
14430         zi=c(3,nres+i)
14431         dxi=dc_norm(1,nres+i)
14432         dyi=dc_norm(2,nres+i)
14433         dzi=dc_norm(3,nres+i)
14434 !        dsci_inv=dsc_inv(itypi)
14435         dsci_inv=vbld_inv(i+nres)
14436 !
14437 ! Calculate SC interaction energy.
14438 !
14439         do iint=1,nint_gr(i)
14440           do j=istart(i,iint),iend(i,iint)
14441 !el            ind=ind+1
14442             itypj=itype(j,1)
14443             if (itypj.eq.ntyp1) cycle
14444 !            dscj_inv=dsc_inv(itypj)
14445             dscj_inv=vbld_inv(j+nres)
14446             sig0ij=sigma(itypi,itypj)
14447             r0ij=r0(itypi,itypj)
14448             chi1=chi(itypi,itypj)
14449             chi2=chi(itypj,itypi)
14450             chi12=chi1*chi2
14451             chip1=chip(itypi)
14452             chip2=chip(itypj)
14453             chip12=chip1*chip2
14454             alf1=alp(itypi)
14455             alf2=alp(itypj)
14456             alf12=0.5D0*(alf1+alf2)
14457             xj=c(1,nres+j)-xi
14458             yj=c(2,nres+j)-yi
14459             zj=c(3,nres+j)-zi
14460             dxj=dc_norm(1,nres+j)
14461             dyj=dc_norm(2,nres+j)
14462             dzj=dc_norm(3,nres+j)
14463             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14464             rij=dsqrt(rrij)
14465
14466             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14467
14468             if (sss.lt.1.0d0) then
14469
14470 ! Calculate angle-dependent terms of energy and contributions to their
14471 ! derivatives.
14472               call sc_angular
14473               sigsq=1.0D0/sigsq
14474               sig=sig0ij*dsqrt(sigsq)
14475               rij_shift=1.0D0/rij-sig+r0ij
14476 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14477               if (rij_shift.le.0.0D0) then
14478                 evdw=1.0D20
14479                 return
14480               endif
14481               sigder=-sig*sigsq
14482 !---------------------------------------------------------------
14483               rij_shift=1.0D0/rij_shift
14484               fac=rij_shift**expon
14485               e1=fac*fac*aa_aq(itypi,itypj)
14486               e2=fac*bb_aq(itypi,itypj)
14487               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14488               eps2der=evdwij*eps3rt
14489               eps3der=evdwij*eps2rt
14490               fac_augm=rrij**expon
14491               e_augm=augm(itypi,itypj)*fac_augm
14492               evdwij=evdwij*eps2rt*eps3rt
14493               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14494               if (lprn) then
14495               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14496               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14497               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14498                 restyp(itypi,1),i,restyp(itypj,1),j,&
14499                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14500                 chi1,chi2,chip1,chip2,&
14501                 eps1,eps2rt**2,eps3rt**2,&
14502                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14503                 evdwij+e_augm
14504               endif
14505 ! Calculate gradient components.
14506               e1=e1*eps1*eps2rt**2*eps3rt**2
14507               fac=-expon*(e1+evdwij)*rij_shift
14508               sigder=fac*sigder
14509               fac=rij*fac-2*expon*rrij*e_augm
14510 ! Calculate the radial part of the gradient
14511               gg(1)=xj*fac
14512               gg(2)=yj*fac
14513               gg(3)=zj*fac
14514 ! Calculate angular part of the gradient.
14515               call sc_grad_scale(1.0d0-sss)
14516             endif
14517           enddo      ! j
14518         enddo        ! iint
14519       enddo          ! i
14520       end subroutine egbv_long
14521 !-----------------------------------------------------------------------------
14522       subroutine egbv_short(evdw)
14523 !
14524 ! This subroutine calculates the interaction energy of nonbonded side chains
14525 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14526 !
14527       use calc_data
14528 !      implicit real*8 (a-h,o-z)
14529 !      include 'DIMENSIONS'
14530 !      include 'COMMON.GEO'
14531 !      include 'COMMON.VAR'
14532 !      include 'COMMON.LOCAL'
14533 !      include 'COMMON.CHAIN'
14534 !      include 'COMMON.DERIV'
14535 !      include 'COMMON.NAMES'
14536 !      include 'COMMON.INTERACT'
14537 !      include 'COMMON.IOUNITS'
14538 !      include 'COMMON.CALC'
14539       use comm_srutu
14540 !el      integer :: icall
14541 !el      common /srutu/ icall
14542       logical :: lprn
14543 !el local variables
14544       integer :: iint,itypi,itypi1,itypj
14545       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14546       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14547       evdw=0.0D0
14548 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14549       evdw=0.0D0
14550       lprn=.false.
14551 !     if (icall.eq.0) lprn=.true.
14552 !el      ind=0
14553       do i=iatsc_s,iatsc_e
14554         itypi=itype(i,1)
14555         if (itypi.eq.ntyp1) cycle
14556         itypi1=itype(i+1,1)
14557         xi=c(1,nres+i)
14558         yi=c(2,nres+i)
14559         zi=c(3,nres+i)
14560         dxi=dc_norm(1,nres+i)
14561         dyi=dc_norm(2,nres+i)
14562         dzi=dc_norm(3,nres+i)
14563 !        dsci_inv=dsc_inv(itypi)
14564         dsci_inv=vbld_inv(i+nres)
14565 !
14566 ! Calculate SC interaction energy.
14567 !
14568         do iint=1,nint_gr(i)
14569           do j=istart(i,iint),iend(i,iint)
14570 !el            ind=ind+1
14571             itypj=itype(j,1)
14572             if (itypj.eq.ntyp1) cycle
14573 !            dscj_inv=dsc_inv(itypj)
14574             dscj_inv=vbld_inv(j+nres)
14575             sig0ij=sigma(itypi,itypj)
14576             r0ij=r0(itypi,itypj)
14577             chi1=chi(itypi,itypj)
14578             chi2=chi(itypj,itypi)
14579             chi12=chi1*chi2
14580             chip1=chip(itypi)
14581             chip2=chip(itypj)
14582             chip12=chip1*chip2
14583             alf1=alp(itypi)
14584             alf2=alp(itypj)
14585             alf12=0.5D0*(alf1+alf2)
14586             xj=c(1,nres+j)-xi
14587             yj=c(2,nres+j)-yi
14588             zj=c(3,nres+j)-zi
14589             dxj=dc_norm(1,nres+j)
14590             dyj=dc_norm(2,nres+j)
14591             dzj=dc_norm(3,nres+j)
14592             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14593             rij=dsqrt(rrij)
14594
14595             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14596
14597             if (sss.gt.0.0d0) then
14598
14599 ! Calculate angle-dependent terms of energy and contributions to their
14600 ! derivatives.
14601               call sc_angular
14602               sigsq=1.0D0/sigsq
14603               sig=sig0ij*dsqrt(sigsq)
14604               rij_shift=1.0D0/rij-sig+r0ij
14605 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14606               if (rij_shift.le.0.0D0) then
14607                 evdw=1.0D20
14608                 return
14609               endif
14610               sigder=-sig*sigsq
14611 !---------------------------------------------------------------
14612               rij_shift=1.0D0/rij_shift
14613               fac=rij_shift**expon
14614               e1=fac*fac*aa_aq(itypi,itypj)
14615               e2=fac*bb_aq(itypi,itypj)
14616               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14617               eps2der=evdwij*eps3rt
14618               eps3der=evdwij*eps2rt
14619               fac_augm=rrij**expon
14620               e_augm=augm(itypi,itypj)*fac_augm
14621               evdwij=evdwij*eps2rt*eps3rt
14622               evdw=evdw+(evdwij+e_augm)*sss
14623               if (lprn) then
14624               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14625               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14626               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14627                 restyp(itypi,1),i,restyp(itypj,1),j,&
14628                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14629                 chi1,chi2,chip1,chip2,&
14630                 eps1,eps2rt**2,eps3rt**2,&
14631                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14632                 evdwij+e_augm
14633               endif
14634 ! Calculate gradient components.
14635               e1=e1*eps1*eps2rt**2*eps3rt**2
14636               fac=-expon*(e1+evdwij)*rij_shift
14637               sigder=fac*sigder
14638               fac=rij*fac-2*expon*rrij*e_augm
14639 ! Calculate the radial part of the gradient
14640               gg(1)=xj*fac
14641               gg(2)=yj*fac
14642               gg(3)=zj*fac
14643 ! Calculate angular part of the gradient.
14644               call sc_grad_scale(sss)
14645             endif
14646           enddo      ! j
14647         enddo        ! iint
14648       enddo          ! i
14649       end subroutine egbv_short
14650 !-----------------------------------------------------------------------------
14651       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14652 !
14653 ! This subroutine calculates the average interaction energy and its gradient
14654 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14655 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14656 ! The potential depends both on the distance of peptide-group centers and on
14657 ! the orientation of the CA-CA virtual bonds.
14658 !
14659 !      implicit real*8 (a-h,o-z)
14660
14661       use comm_locel
14662 #ifdef MPI
14663       include 'mpif.h'
14664 #endif
14665 !      include 'DIMENSIONS'
14666 !      include 'COMMON.CONTROL'
14667 !      include 'COMMON.SETUP'
14668 !      include 'COMMON.IOUNITS'
14669 !      include 'COMMON.GEO'
14670 !      include 'COMMON.VAR'
14671 !      include 'COMMON.LOCAL'
14672 !      include 'COMMON.CHAIN'
14673 !      include 'COMMON.DERIV'
14674 !      include 'COMMON.INTERACT'
14675 !      include 'COMMON.CONTACTS'
14676 !      include 'COMMON.TORSION'
14677 !      include 'COMMON.VECTORS'
14678 !      include 'COMMON.FFIELD'
14679 !      include 'COMMON.TIME1'
14680       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14681       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14682       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14683 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14684       real(kind=8),dimension(4) :: muij
14685 !el      integer :: num_conti,j1,j2
14686 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14687 !el                   dz_normi,xmedi,ymedi,zmedi
14688 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14689 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14690 !el          num_conti,j1,j2
14691 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14692 #ifdef MOMENT
14693       real(kind=8) :: scal_el=1.0d0
14694 #else
14695       real(kind=8) :: scal_el=0.5d0
14696 #endif
14697 ! 12/13/98
14698 ! 13-go grudnia roku pamietnego...
14699       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14700                                              0.0d0,1.0d0,0.0d0,&
14701                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14702 !el local variables
14703       integer :: i,j,k
14704       real(kind=8) :: fac
14705       real(kind=8) :: dxj,dyj,dzj
14706       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14707
14708 !      allocate(num_cont_hb(nres)) !(maxres)
14709 !d      write(iout,*) 'In EELEC'
14710 !d      do i=1,nloctyp
14711 !d        write(iout,*) 'Type',i
14712 !d        write(iout,*) 'B1',B1(:,i)
14713 !d        write(iout,*) 'B2',B2(:,i)
14714 !d        write(iout,*) 'CC',CC(:,:,i)
14715 !d        write(iout,*) 'DD',DD(:,:,i)
14716 !d        write(iout,*) 'EE',EE(:,:,i)
14717 !d      enddo
14718 !d      call check_vecgrad
14719 !d      stop
14720       if (icheckgrad.eq.1) then
14721         do i=1,nres-1
14722           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14723           do k=1,3
14724             dc_norm(k,i)=dc(k,i)*fac
14725           enddo
14726 !          write (iout,*) 'i',i,' fac',fac
14727         enddo
14728       endif
14729       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14730           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14731           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14732 !        call vec_and_deriv
14733 #ifdef TIMING
14734         time01=MPI_Wtime()
14735 #endif
14736 !        print *, "before set matrices"
14737         call set_matrices
14738 !        print *,"after set martices"
14739 #ifdef TIMING
14740         time_mat=time_mat+MPI_Wtime()-time01
14741 #endif
14742       endif
14743 !d      do i=1,nres-1
14744 !d        write (iout,*) 'i=',i
14745 !d        do k=1,3
14746 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14747 !d        enddo
14748 !d        do k=1,3
14749 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14750 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14751 !d        enddo
14752 !d      enddo
14753       t_eelecij=0.0d0
14754       ees=0.0D0
14755       evdw1=0.0D0
14756       eel_loc=0.0d0
14757       eello_turn3=0.0d0
14758       eello_turn4=0.0d0
14759 !el      ind=0
14760       do i=1,nres
14761         num_cont_hb(i)=0
14762       enddo
14763 !d      print '(a)','Enter EELEC'
14764 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14765 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14766 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14767       do i=1,nres
14768         gel_loc_loc(i)=0.0d0
14769         gcorr_loc(i)=0.0d0
14770       enddo
14771 !
14772 !
14773 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14774 !
14775 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14776 !
14777       do i=iturn3_start,iturn3_end
14778         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14779         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14780         dxi=dc(1,i)
14781         dyi=dc(2,i)
14782         dzi=dc(3,i)
14783         dx_normi=dc_norm(1,i)
14784         dy_normi=dc_norm(2,i)
14785         dz_normi=dc_norm(3,i)
14786         xmedi=c(1,i)+0.5d0*dxi
14787         ymedi=c(2,i)+0.5d0*dyi
14788         zmedi=c(3,i)+0.5d0*dzi
14789           xmedi=dmod(xmedi,boxxsize)
14790           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14791           ymedi=dmod(ymedi,boxysize)
14792           if (ymedi.lt.0) ymedi=ymedi+boxysize
14793           zmedi=dmod(zmedi,boxzsize)
14794           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14795         num_conti=0
14796         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14797         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14798         num_cont_hb(i)=num_conti
14799       enddo
14800       do i=iturn4_start,iturn4_end
14801         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14802           .or. itype(i+3,1).eq.ntyp1 &
14803           .or. itype(i+4,1).eq.ntyp1) cycle
14804         dxi=dc(1,i)
14805         dyi=dc(2,i)
14806         dzi=dc(3,i)
14807         dx_normi=dc_norm(1,i)
14808         dy_normi=dc_norm(2,i)
14809         dz_normi=dc_norm(3,i)
14810         xmedi=c(1,i)+0.5d0*dxi
14811         ymedi=c(2,i)+0.5d0*dyi
14812         zmedi=c(3,i)+0.5d0*dzi
14813           xmedi=dmod(xmedi,boxxsize)
14814           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14815           ymedi=dmod(ymedi,boxysize)
14816           if (ymedi.lt.0) ymedi=ymedi+boxysize
14817           zmedi=dmod(zmedi,boxzsize)
14818           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14819         num_conti=num_cont_hb(i)
14820         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14821         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14822           call eturn4(i,eello_turn4)
14823         num_cont_hb(i)=num_conti
14824       enddo   ! i
14825 !
14826 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14827 !
14828       do i=iatel_s,iatel_e
14829         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14830         dxi=dc(1,i)
14831         dyi=dc(2,i)
14832         dzi=dc(3,i)
14833         dx_normi=dc_norm(1,i)
14834         dy_normi=dc_norm(2,i)
14835         dz_normi=dc_norm(3,i)
14836         xmedi=c(1,i)+0.5d0*dxi
14837         ymedi=c(2,i)+0.5d0*dyi
14838         zmedi=c(3,i)+0.5d0*dzi
14839           xmedi=dmod(xmedi,boxxsize)
14840           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14841           ymedi=dmod(ymedi,boxysize)
14842           if (ymedi.lt.0) ymedi=ymedi+boxysize
14843           zmedi=dmod(zmedi,boxzsize)
14844           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14845 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14846         num_conti=num_cont_hb(i)
14847         do j=ielstart(i),ielend(i)
14848           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14849           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14850         enddo ! j
14851         num_cont_hb(i)=num_conti
14852       enddo   ! i
14853 !      write (iout,*) "Number of loop steps in EELEC:",ind
14854 !d      do i=1,nres
14855 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14856 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14857 !d      enddo
14858 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14859 !cc      eel_loc=eel_loc+eello_turn3
14860 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14861       return
14862       end subroutine eelec_scale
14863 !-----------------------------------------------------------------------------
14864       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14865 !      implicit real*8 (a-h,o-z)
14866
14867       use comm_locel
14868 !      include 'DIMENSIONS'
14869 #ifdef MPI
14870       include "mpif.h"
14871 #endif
14872 !      include 'COMMON.CONTROL'
14873 !      include 'COMMON.IOUNITS'
14874 !      include 'COMMON.GEO'
14875 !      include 'COMMON.VAR'
14876 !      include 'COMMON.LOCAL'
14877 !      include 'COMMON.CHAIN'
14878 !      include 'COMMON.DERIV'
14879 !      include 'COMMON.INTERACT'
14880 !      include 'COMMON.CONTACTS'
14881 !      include 'COMMON.TORSION'
14882 !      include 'COMMON.VECTORS'
14883 !      include 'COMMON.FFIELD'
14884 !      include 'COMMON.TIME1'
14885       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14886       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14887       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14888 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14889       real(kind=8),dimension(4) :: muij
14890       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14891                     dist_temp, dist_init,sss_grad
14892       integer xshift,yshift,zshift
14893
14894 !el      integer :: num_conti,j1,j2
14895 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14896 !el                   dz_normi,xmedi,ymedi,zmedi
14897 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14898 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14899 !el          num_conti,j1,j2
14900 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14901 #ifdef MOMENT
14902       real(kind=8) :: scal_el=1.0d0
14903 #else
14904       real(kind=8) :: scal_el=0.5d0
14905 #endif
14906 ! 12/13/98
14907 ! 13-go grudnia roku pamietnego...
14908       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14909                                              0.0d0,1.0d0,0.0d0,&
14910                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14911 !el local variables
14912       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14913       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14914       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14915       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14916       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14917       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14918       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14919                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14920                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14921                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14922                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14923                   ecosam,ecosbm,ecosgm,ghalf,time00
14924 !      integer :: maxconts
14925 !      maxconts = nres/4
14926 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14927 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14928 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14929 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14930 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14931 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14932 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14933 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14934 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14935 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14936 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14937 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14938 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14939
14940 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14941 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14942
14943 #ifdef MPI
14944           time00=MPI_Wtime()
14945 #endif
14946 !d      write (iout,*) "eelecij",i,j
14947 !el          ind=ind+1
14948           iteli=itel(i)
14949           itelj=itel(j)
14950           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14951           aaa=app(iteli,itelj)
14952           bbb=bpp(iteli,itelj)
14953           ael6i=ael6(iteli,itelj)
14954           ael3i=ael3(iteli,itelj)
14955           dxj=dc(1,j)
14956           dyj=dc(2,j)
14957           dzj=dc(3,j)
14958           dx_normj=dc_norm(1,j)
14959           dy_normj=dc_norm(2,j)
14960           dz_normj=dc_norm(3,j)
14961 !          xj=c(1,j)+0.5D0*dxj-xmedi
14962 !          yj=c(2,j)+0.5D0*dyj-ymedi
14963 !          zj=c(3,j)+0.5D0*dzj-zmedi
14964           xj=c(1,j)+0.5D0*dxj
14965           yj=c(2,j)+0.5D0*dyj
14966           zj=c(3,j)+0.5D0*dzj
14967           xj=mod(xj,boxxsize)
14968           if (xj.lt.0) xj=xj+boxxsize
14969           yj=mod(yj,boxysize)
14970           if (yj.lt.0) yj=yj+boxysize
14971           zj=mod(zj,boxzsize)
14972           if (zj.lt.0) zj=zj+boxzsize
14973       isubchap=0
14974       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14975       xj_safe=xj
14976       yj_safe=yj
14977       zj_safe=zj
14978       do xshift=-1,1
14979       do yshift=-1,1
14980       do zshift=-1,1
14981           xj=xj_safe+xshift*boxxsize
14982           yj=yj_safe+yshift*boxysize
14983           zj=zj_safe+zshift*boxzsize
14984           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14985           if(dist_temp.lt.dist_init) then
14986             dist_init=dist_temp
14987             xj_temp=xj
14988             yj_temp=yj
14989             zj_temp=zj
14990             isubchap=1
14991           endif
14992        enddo
14993        enddo
14994        enddo
14995        if (isubchap.eq.1) then
14996 !C          print *,i,j
14997           xj=xj_temp-xmedi
14998           yj=yj_temp-ymedi
14999           zj=zj_temp-zmedi
15000        else
15001           xj=xj_safe-xmedi
15002           yj=yj_safe-ymedi
15003           zj=zj_safe-zmedi
15004        endif
15005
15006           rij=xj*xj+yj*yj+zj*zj
15007           rrmij=1.0D0/rij
15008           rij=dsqrt(rij)
15009           rmij=1.0D0/rij
15010 ! For extracting the short-range part of Evdwpp
15011           sss=sscale(rij/rpp(iteli,itelj))
15012             sss_ele_cut=sscale_ele(rij)
15013             sss_ele_grad=sscagrad_ele(rij)
15014             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15015 !             sss_ele_cut=1.0d0
15016 !             sss_ele_grad=0.0d0
15017             if (sss_ele_cut.le.0.0) go to 128
15018
15019           r3ij=rrmij*rmij
15020           r6ij=r3ij*r3ij
15021           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15022           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15023           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15024           fac=cosa-3.0D0*cosb*cosg
15025           ev1=aaa*r6ij*r6ij
15026 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15027           if (j.eq.i+2) ev1=scal_el*ev1
15028           ev2=bbb*r6ij
15029           fac3=ael6i*r6ij
15030           fac4=ael3i*r3ij
15031           evdwij=ev1+ev2
15032           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15033           el2=fac4*fac
15034           eesij=el1+el2
15035 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15036           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15037           ees=ees+eesij*sss_ele_cut
15038           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15039 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15040 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15041 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15042 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15043
15044           if (energy_dec) then
15045               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15046               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15047           endif
15048
15049 !
15050 ! Calculate contributions to the Cartesian gradient.
15051 !
15052 #ifdef SPLITELE
15053           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15054           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15055           fac1=fac
15056           erij(1)=xj*rmij
15057           erij(2)=yj*rmij
15058           erij(3)=zj*rmij
15059 !
15060 ! Radial derivatives. First process both termini of the fragment (i,j)
15061 !
15062           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15063           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15064           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15065 !          do k=1,3
15066 !            ghalf=0.5D0*ggg(k)
15067 !            gelc(k,i)=gelc(k,i)+ghalf
15068 !            gelc(k,j)=gelc(k,j)+ghalf
15069 !          enddo
15070 ! 9/28/08 AL Gradient compotents will be summed only at the end
15071           do k=1,3
15072             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15073             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15074           enddo
15075 !
15076 ! Loop over residues i+1 thru j-1.
15077 !
15078 !grad          do k=i+1,j-1
15079 !grad            do l=1,3
15080 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15081 !grad            enddo
15082 !grad          enddo
15083           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15084           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15085           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15086           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15087           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15088           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15089 !          do k=1,3
15090 !            ghalf=0.5D0*ggg(k)
15091 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15092 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15093 !          enddo
15094 ! 9/28/08 AL Gradient compotents will be summed only at the end
15095           do k=1,3
15096             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15097             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15098           enddo
15099 !
15100 ! Loop over residues i+1 thru j-1.
15101 !
15102 !grad          do k=i+1,j-1
15103 !grad            do l=1,3
15104 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15105 !grad            enddo
15106 !grad          enddo
15107 #else
15108           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15109           facel=(el1+eesij)*sss_ele_cut
15110           fac1=fac
15111           fac=-3*rrmij*(facvdw+facvdw+facel)
15112           erij(1)=xj*rmij
15113           erij(2)=yj*rmij
15114           erij(3)=zj*rmij
15115 !
15116 ! Radial derivatives. First process both termini of the fragment (i,j)
15117 !
15118           ggg(1)=fac*xj
15119           ggg(2)=fac*yj
15120           ggg(3)=fac*zj
15121 !          do k=1,3
15122 !            ghalf=0.5D0*ggg(k)
15123 !            gelc(k,i)=gelc(k,i)+ghalf
15124 !            gelc(k,j)=gelc(k,j)+ghalf
15125 !          enddo
15126 ! 9/28/08 AL Gradient compotents will be summed only at the end
15127           do k=1,3
15128             gelc_long(k,j)=gelc(k,j)+ggg(k)
15129             gelc_long(k,i)=gelc(k,i)-ggg(k)
15130           enddo
15131 !
15132 ! Loop over residues i+1 thru j-1.
15133 !
15134 !grad          do k=i+1,j-1
15135 !grad            do l=1,3
15136 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15137 !grad            enddo
15138 !grad          enddo
15139 ! 9/28/08 AL Gradient compotents will be summed only at the end
15140           ggg(1)=facvdw*xj
15141           ggg(2)=facvdw*yj
15142           ggg(3)=facvdw*zj
15143           do k=1,3
15144             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15145             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15146           enddo
15147 #endif
15148 !
15149 ! Angular part
15150 !
15151           ecosa=2.0D0*fac3*fac1+fac4
15152           fac4=-3.0D0*fac4
15153           fac3=-6.0D0*fac3
15154           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15155           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15156           do k=1,3
15157             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15158             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15159           enddo
15160 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15161 !d   &          (dcosg(k),k=1,3)
15162           do k=1,3
15163             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15164           enddo
15165 !          do k=1,3
15166 !            ghalf=0.5D0*ggg(k)
15167 !            gelc(k,i)=gelc(k,i)+ghalf
15168 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15169 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15170 !            gelc(k,j)=gelc(k,j)+ghalf
15171 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15172 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15173 !          enddo
15174 !grad          do k=i+1,j-1
15175 !grad            do l=1,3
15176 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15177 !grad            enddo
15178 !grad          enddo
15179           do k=1,3
15180             gelc(k,i)=gelc(k,i) &
15181                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15182                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15183                      *sss_ele_cut
15184             gelc(k,j)=gelc(k,j) &
15185                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15186                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15187                      *sss_ele_cut
15188             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15189             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15190           enddo
15191           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15192               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15193               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15194 !
15195 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15196 !   energy of a peptide unit is assumed in the form of a second-order
15197 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15198 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15199 !   are computed for EVERY pair of non-contiguous peptide groups.
15200 !
15201           if (j.lt.nres-1) then
15202             j1=j+1
15203             j2=j-1
15204           else
15205             j1=j-1
15206             j2=j-2
15207           endif
15208           kkk=0
15209           do k=1,2
15210             do l=1,2
15211               kkk=kkk+1
15212               muij(kkk)=mu(k,i)*mu(l,j)
15213             enddo
15214           enddo
15215 !d         write (iout,*) 'EELEC: i',i,' j',j
15216 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15217 !d          write(iout,*) 'muij',muij
15218           ury=scalar(uy(1,i),erij)
15219           urz=scalar(uz(1,i),erij)
15220           vry=scalar(uy(1,j),erij)
15221           vrz=scalar(uz(1,j),erij)
15222           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15223           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15224           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15225           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15226           fac=dsqrt(-ael6i)*r3ij
15227           a22=a22*fac
15228           a23=a23*fac
15229           a32=a32*fac
15230           a33=a33*fac
15231 !d          write (iout,'(4i5,4f10.5)')
15232 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15233 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15234 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15235 !d     &      uy(:,j),uz(:,j)
15236 !d          write (iout,'(4f10.5)')
15237 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15238 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15239 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15240 !d           write (iout,'(9f10.5/)')
15241 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15242 ! Derivatives of the elements of A in virtual-bond vectors
15243           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15244           do k=1,3
15245             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15246             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15247             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15248             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15249             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15250             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15251             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15252             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15253             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15254             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15255             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15256             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15257           enddo
15258 ! Compute radial contributions to the gradient
15259           facr=-3.0d0*rrmij
15260           a22der=a22*facr
15261           a23der=a23*facr
15262           a32der=a32*facr
15263           a33der=a33*facr
15264           agg(1,1)=a22der*xj
15265           agg(2,1)=a22der*yj
15266           agg(3,1)=a22der*zj
15267           agg(1,2)=a23der*xj
15268           agg(2,2)=a23der*yj
15269           agg(3,2)=a23der*zj
15270           agg(1,3)=a32der*xj
15271           agg(2,3)=a32der*yj
15272           agg(3,3)=a32der*zj
15273           agg(1,4)=a33der*xj
15274           agg(2,4)=a33der*yj
15275           agg(3,4)=a33der*zj
15276 ! Add the contributions coming from er
15277           fac3=-3.0d0*fac
15278           do k=1,3
15279             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15280             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15281             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15282             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15283           enddo
15284           do k=1,3
15285 ! Derivatives in DC(i)
15286 !grad            ghalf1=0.5d0*agg(k,1)
15287 !grad            ghalf2=0.5d0*agg(k,2)
15288 !grad            ghalf3=0.5d0*agg(k,3)
15289 !grad            ghalf4=0.5d0*agg(k,4)
15290             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15291             -3.0d0*uryg(k,2)*vry)!+ghalf1
15292             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15293             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15294             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15295             -3.0d0*urzg(k,2)*vry)!+ghalf3
15296             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15297             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15298 ! Derivatives in DC(i+1)
15299             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15300             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15301             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15302             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15303             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15304             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15305             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15306             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15307 ! Derivatives in DC(j)
15308             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15309             -3.0d0*vryg(k,2)*ury)!+ghalf1
15310             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15311             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15312             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15313             -3.0d0*vryg(k,2)*urz)!+ghalf3
15314             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15315             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15316 ! Derivatives in DC(j+1) or DC(nres-1)
15317             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15318             -3.0d0*vryg(k,3)*ury)
15319             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15320             -3.0d0*vrzg(k,3)*ury)
15321             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15322             -3.0d0*vryg(k,3)*urz)
15323             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15324             -3.0d0*vrzg(k,3)*urz)
15325 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15326 !grad              do l=1,4
15327 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15328 !grad              enddo
15329 !grad            endif
15330           enddo
15331           acipa(1,1)=a22
15332           acipa(1,2)=a23
15333           acipa(2,1)=a32
15334           acipa(2,2)=a33
15335           a22=-a22
15336           a23=-a23
15337           do l=1,2
15338             do k=1,3
15339               agg(k,l)=-agg(k,l)
15340               aggi(k,l)=-aggi(k,l)
15341               aggi1(k,l)=-aggi1(k,l)
15342               aggj(k,l)=-aggj(k,l)
15343               aggj1(k,l)=-aggj1(k,l)
15344             enddo
15345           enddo
15346           if (j.lt.nres-1) then
15347             a22=-a22
15348             a32=-a32
15349             do l=1,3,2
15350               do k=1,3
15351                 agg(k,l)=-agg(k,l)
15352                 aggi(k,l)=-aggi(k,l)
15353                 aggi1(k,l)=-aggi1(k,l)
15354                 aggj(k,l)=-aggj(k,l)
15355                 aggj1(k,l)=-aggj1(k,l)
15356               enddo
15357             enddo
15358           else
15359             a22=-a22
15360             a23=-a23
15361             a32=-a32
15362             a33=-a33
15363             do l=1,4
15364               do k=1,3
15365                 agg(k,l)=-agg(k,l)
15366                 aggi(k,l)=-aggi(k,l)
15367                 aggi1(k,l)=-aggi1(k,l)
15368                 aggj(k,l)=-aggj(k,l)
15369                 aggj1(k,l)=-aggj1(k,l)
15370               enddo
15371             enddo
15372           endif
15373           ENDIF ! WCORR
15374           IF (wel_loc.gt.0.0d0) THEN
15375 ! Contribution to the local-electrostatic energy coming from the i-j pair
15376           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15377            +a33*muij(4)
15378 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15379 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15380           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15381                   'eelloc',i,j,eel_loc_ij
15382 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15383
15384           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15385 ! Partial derivatives in virtual-bond dihedral angles gamma
15386           if (i.gt.1) &
15387           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15388                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15389                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15390                  *sss_ele_cut
15391           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15392                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15393                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15394                  *sss_ele_cut
15395            xtemp(1)=xj
15396            xtemp(2)=yj
15397            xtemp(3)=zj
15398
15399 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15400           do l=1,3
15401             ggg(l)=(agg(l,1)*muij(1)+ &
15402                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15403             *sss_ele_cut &
15404              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15405
15406             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15407             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15408 !grad            ghalf=0.5d0*ggg(l)
15409 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15410 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15411           enddo
15412 !grad          do k=i+1,j2
15413 !grad            do l=1,3
15414 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15415 !grad            enddo
15416 !grad          enddo
15417 ! Remaining derivatives of eello
15418           do l=1,3
15419             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15420                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15421             *sss_ele_cut
15422
15423             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15424                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15425             *sss_ele_cut
15426
15427             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15428                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15429             *sss_ele_cut
15430
15431             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15432                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15433             *sss_ele_cut
15434
15435           enddo
15436           ENDIF
15437 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15438 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15439           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15440              .and. num_conti.le.maxconts) then
15441 !            write (iout,*) i,j," entered corr"
15442 !
15443 ! Calculate the contact function. The ith column of the array JCONT will
15444 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15445 ! greater than I). The arrays FACONT and GACONT will contain the values of
15446 ! the contact function and its derivative.
15447 !           r0ij=1.02D0*rpp(iteli,itelj)
15448 !           r0ij=1.11D0*rpp(iteli,itelj)
15449             r0ij=2.20D0*rpp(iteli,itelj)
15450 !           r0ij=1.55D0*rpp(iteli,itelj)
15451             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15452 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15453             if (fcont.gt.0.0D0) then
15454               num_conti=num_conti+1
15455               if (num_conti.gt.maxconts) then
15456 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15457                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15458                                ' will skip next contacts for this conf.',num_conti
15459               else
15460                 jcont_hb(num_conti,i)=j
15461 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15462 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15463                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15464                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15465 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15466 !  terms.
15467                 d_cont(num_conti,i)=rij
15468 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15469 !     --- Electrostatic-interaction matrix ---
15470                 a_chuj(1,1,num_conti,i)=a22
15471                 a_chuj(1,2,num_conti,i)=a23
15472                 a_chuj(2,1,num_conti,i)=a32
15473                 a_chuj(2,2,num_conti,i)=a33
15474 !     --- Gradient of rij
15475                 do kkk=1,3
15476                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15477                 enddo
15478                 kkll=0
15479                 do k=1,2
15480                   do l=1,2
15481                     kkll=kkll+1
15482                     do m=1,3
15483                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15484                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15485                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15486                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15487                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15488                     enddo
15489                   enddo
15490                 enddo
15491                 ENDIF
15492                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15493 ! Calculate contact energies
15494                 cosa4=4.0D0*cosa
15495                 wij=cosa-3.0D0*cosb*cosg
15496                 cosbg1=cosb+cosg
15497                 cosbg2=cosb-cosg
15498 !               fac3=dsqrt(-ael6i)/r0ij**3
15499                 fac3=dsqrt(-ael6i)*r3ij
15500 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15501                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15502                 if (ees0tmp.gt.0) then
15503                   ees0pij=dsqrt(ees0tmp)
15504                 else
15505                   ees0pij=0
15506                 endif
15507 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15508                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15509                 if (ees0tmp.gt.0) then
15510                   ees0mij=dsqrt(ees0tmp)
15511                 else
15512                   ees0mij=0
15513                 endif
15514 !               ees0mij=0.0D0
15515                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15516                      *sss_ele_cut
15517
15518                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15519                      *sss_ele_cut
15520
15521 ! Diagnostics. Comment out or remove after debugging!
15522 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15523 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15524 !               ees0m(num_conti,i)=0.0D0
15525 ! End diagnostics.
15526 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15527 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15528 ! Angular derivatives of the contact function
15529                 ees0pij1=fac3/ees0pij
15530                 ees0mij1=fac3/ees0mij
15531                 fac3p=-3.0D0*fac3*rrmij
15532                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15533                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15534 !               ees0mij1=0.0D0
15535                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15536                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15537                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15538                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15539                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15540                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15541                 ecosap=ecosa1+ecosa2
15542                 ecosbp=ecosb1+ecosb2
15543                 ecosgp=ecosg1+ecosg2
15544                 ecosam=ecosa1-ecosa2
15545                 ecosbm=ecosb1-ecosb2
15546                 ecosgm=ecosg1-ecosg2
15547 ! Diagnostics
15548 !               ecosap=ecosa1
15549 !               ecosbp=ecosb1
15550 !               ecosgp=ecosg1
15551 !               ecosam=0.0D0
15552 !               ecosbm=0.0D0
15553 !               ecosgm=0.0D0
15554 ! End diagnostics
15555                 facont_hb(num_conti,i)=fcont
15556                 fprimcont=fprimcont/rij
15557 !d              facont_hb(num_conti,i)=1.0D0
15558 ! Following line is for diagnostics.
15559 !d              fprimcont=0.0D0
15560                 do k=1,3
15561                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15562                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15563                 enddo
15564                 do k=1,3
15565                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15566                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15567                 enddo
15568 !                gggp(1)=gggp(1)+ees0pijp*xj
15569 !                gggp(2)=gggp(2)+ees0pijp*yj
15570 !                gggp(3)=gggp(3)+ees0pijp*zj
15571 !                gggm(1)=gggm(1)+ees0mijp*xj
15572 !                gggm(2)=gggm(2)+ees0mijp*yj
15573 !                gggm(3)=gggm(3)+ees0mijp*zj
15574                 gggp(1)=gggp(1)+ees0pijp*xj &
15575                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15576                 gggp(2)=gggp(2)+ees0pijp*yj &
15577                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15578                 gggp(3)=gggp(3)+ees0pijp*zj &
15579                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15580
15581                 gggm(1)=gggm(1)+ees0mijp*xj &
15582                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15583
15584                 gggm(2)=gggm(2)+ees0mijp*yj &
15585                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15586
15587                 gggm(3)=gggm(3)+ees0mijp*zj &
15588                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15589
15590 ! Derivatives due to the contact function
15591                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15592                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15593                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15594                 do k=1,3
15595 !
15596 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15597 !          following the change of gradient-summation algorithm.
15598 !
15599 !grad                  ghalfp=0.5D0*gggp(k)
15600 !grad                  ghalfm=0.5D0*gggm(k)
15601 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15602 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15603 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15604 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15605 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15606 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15607 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15608 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15609 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15610 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15611 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15612 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15613 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15614 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15615                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15616                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15617                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15618                      *sss_ele_cut
15619
15620                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15621                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15622                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15623                      *sss_ele_cut
15624
15625                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15626                      *sss_ele_cut
15627
15628                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15629                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15630                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15631                      *sss_ele_cut
15632
15633                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15634                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15635                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15636                      *sss_ele_cut
15637
15638                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15639                      *sss_ele_cut
15640
15641                 enddo
15642               ENDIF ! wcorr
15643               endif  ! num_conti.le.maxconts
15644             endif  ! fcont.gt.0
15645           endif    ! j.gt.i+1
15646           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15647             do k=1,4
15648               do l=1,3
15649                 ghalf=0.5d0*agg(l,k)
15650                 aggi(l,k)=aggi(l,k)+ghalf
15651                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15652                 aggj(l,k)=aggj(l,k)+ghalf
15653               enddo
15654             enddo
15655             if (j.eq.nres-1 .and. i.lt.j-2) then
15656               do k=1,4
15657                 do l=1,3
15658                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15659                 enddo
15660               enddo
15661             endif
15662           endif
15663  128      continue
15664 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15665       return
15666       end subroutine eelecij_scale
15667 !-----------------------------------------------------------------------------
15668       subroutine evdwpp_short(evdw1)
15669 !
15670 ! Compute Evdwpp
15671 !
15672 !      implicit real*8 (a-h,o-z)
15673 !      include 'DIMENSIONS'
15674 !      include 'COMMON.CONTROL'
15675 !      include 'COMMON.IOUNITS'
15676 !      include 'COMMON.GEO'
15677 !      include 'COMMON.VAR'
15678 !      include 'COMMON.LOCAL'
15679 !      include 'COMMON.CHAIN'
15680 !      include 'COMMON.DERIV'
15681 !      include 'COMMON.INTERACT'
15682 !      include 'COMMON.CONTACTS'
15683 !      include 'COMMON.TORSION'
15684 !      include 'COMMON.VECTORS'
15685 !      include 'COMMON.FFIELD'
15686       real(kind=8),dimension(3) :: ggg
15687 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15688 #ifdef MOMENT
15689       real(kind=8) :: scal_el=1.0d0
15690 #else
15691       real(kind=8) :: scal_el=0.5d0
15692 #endif
15693 !el local variables
15694       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15695       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15696       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15697                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15698                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15699       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15700                     dist_temp, dist_init,sss_grad
15701       integer xshift,yshift,zshift
15702
15703
15704       evdw1=0.0D0
15705 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15706 !     & " iatel_e_vdw",iatel_e_vdw
15707       call flush(iout)
15708       do i=iatel_s_vdw,iatel_e_vdw
15709         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15710         dxi=dc(1,i)
15711         dyi=dc(2,i)
15712         dzi=dc(3,i)
15713         dx_normi=dc_norm(1,i)
15714         dy_normi=dc_norm(2,i)
15715         dz_normi=dc_norm(3,i)
15716         xmedi=c(1,i)+0.5d0*dxi
15717         ymedi=c(2,i)+0.5d0*dyi
15718         zmedi=c(3,i)+0.5d0*dzi
15719           xmedi=dmod(xmedi,boxxsize)
15720           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15721           ymedi=dmod(ymedi,boxysize)
15722           if (ymedi.lt.0) ymedi=ymedi+boxysize
15723           zmedi=dmod(zmedi,boxzsize)
15724           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15725         num_conti=0
15726 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15727 !     &   ' ielend',ielend_vdw(i)
15728         call flush(iout)
15729         do j=ielstart_vdw(i),ielend_vdw(i)
15730           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15731 !el          ind=ind+1
15732           iteli=itel(i)
15733           itelj=itel(j)
15734           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15735           aaa=app(iteli,itelj)
15736           bbb=bpp(iteli,itelj)
15737           dxj=dc(1,j)
15738           dyj=dc(2,j)
15739           dzj=dc(3,j)
15740           dx_normj=dc_norm(1,j)
15741           dy_normj=dc_norm(2,j)
15742           dz_normj=dc_norm(3,j)
15743 !          xj=c(1,j)+0.5D0*dxj-xmedi
15744 !          yj=c(2,j)+0.5D0*dyj-ymedi
15745 !          zj=c(3,j)+0.5D0*dzj-zmedi
15746           xj=c(1,j)+0.5D0*dxj
15747           yj=c(2,j)+0.5D0*dyj
15748           zj=c(3,j)+0.5D0*dzj
15749           xj=mod(xj,boxxsize)
15750           if (xj.lt.0) xj=xj+boxxsize
15751           yj=mod(yj,boxysize)
15752           if (yj.lt.0) yj=yj+boxysize
15753           zj=mod(zj,boxzsize)
15754           if (zj.lt.0) zj=zj+boxzsize
15755       isubchap=0
15756       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15757       xj_safe=xj
15758       yj_safe=yj
15759       zj_safe=zj
15760       do xshift=-1,1
15761       do yshift=-1,1
15762       do zshift=-1,1
15763           xj=xj_safe+xshift*boxxsize
15764           yj=yj_safe+yshift*boxysize
15765           zj=zj_safe+zshift*boxzsize
15766           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15767           if(dist_temp.lt.dist_init) then
15768             dist_init=dist_temp
15769             xj_temp=xj
15770             yj_temp=yj
15771             zj_temp=zj
15772             isubchap=1
15773           endif
15774        enddo
15775        enddo
15776        enddo
15777        if (isubchap.eq.1) then
15778 !C          print *,i,j
15779           xj=xj_temp-xmedi
15780           yj=yj_temp-ymedi
15781           zj=zj_temp-zmedi
15782        else
15783           xj=xj_safe-xmedi
15784           yj=yj_safe-ymedi
15785           zj=zj_safe-zmedi
15786        endif
15787
15788           rij=xj*xj+yj*yj+zj*zj
15789           rrmij=1.0D0/rij
15790           rij=dsqrt(rij)
15791           sss=sscale(rij/rpp(iteli,itelj))
15792             sss_ele_cut=sscale_ele(rij)
15793             sss_ele_grad=sscagrad_ele(rij)
15794             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15795             if (sss_ele_cut.le.0.0) cycle
15796           if (sss.gt.0.0d0) then
15797             rmij=1.0D0/rij
15798             r3ij=rrmij*rmij
15799             r6ij=r3ij*r3ij
15800             ev1=aaa*r6ij*r6ij
15801 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15802             if (j.eq.i+2) ev1=scal_el*ev1
15803             ev2=bbb*r6ij
15804             evdwij=ev1+ev2
15805             if (energy_dec) then
15806               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15807             endif
15808             evdw1=evdw1+evdwij*sss*sss_ele_cut
15809 !
15810 ! Calculate contributions to the Cartesian gradient.
15811 !
15812             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15813 !            ggg(1)=facvdw*xj
15814 !            ggg(2)=facvdw*yj
15815 !            ggg(3)=facvdw*zj
15816           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15817           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15818           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15819           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15820           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15821           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15822
15823             do k=1,3
15824               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15825               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15826             enddo
15827           endif
15828         enddo ! j
15829       enddo   ! i
15830       return
15831       end subroutine evdwpp_short
15832 !-----------------------------------------------------------------------------
15833       subroutine escp_long(evdw2,evdw2_14)
15834 !
15835 ! This subroutine calculates the excluded-volume interaction energy between
15836 ! peptide-group centers and side chains and its gradient in virtual-bond and
15837 ! side-chain vectors.
15838 !
15839 !      implicit real*8 (a-h,o-z)
15840 !      include 'DIMENSIONS'
15841 !      include 'COMMON.GEO'
15842 !      include 'COMMON.VAR'
15843 !      include 'COMMON.LOCAL'
15844 !      include 'COMMON.CHAIN'
15845 !      include 'COMMON.DERIV'
15846 !      include 'COMMON.INTERACT'
15847 !      include 'COMMON.FFIELD'
15848 !      include 'COMMON.IOUNITS'
15849 !      include 'COMMON.CONTROL'
15850       real(kind=8),dimension(3) :: ggg
15851 !el local variables
15852       integer :: i,iint,j,k,iteli,itypj,subchap
15853       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15854       real(kind=8) :: evdw2,evdw2_14,evdwij
15855       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15856                     dist_temp, dist_init
15857
15858       evdw2=0.0D0
15859       evdw2_14=0.0d0
15860 !d    print '(a)','Enter ESCP'
15861 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15862       do i=iatscp_s,iatscp_e
15863         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15864         iteli=itel(i)
15865         xi=0.5D0*(c(1,i)+c(1,i+1))
15866         yi=0.5D0*(c(2,i)+c(2,i+1))
15867         zi=0.5D0*(c(3,i)+c(3,i+1))
15868           xi=mod(xi,boxxsize)
15869           if (xi.lt.0) xi=xi+boxxsize
15870           yi=mod(yi,boxysize)
15871           if (yi.lt.0) yi=yi+boxysize
15872           zi=mod(zi,boxzsize)
15873           if (zi.lt.0) zi=zi+boxzsize
15874
15875         do iint=1,nscp_gr(i)
15876
15877         do j=iscpstart(i,iint),iscpend(i,iint)
15878           itypj=itype(j,1)
15879           if (itypj.eq.ntyp1) cycle
15880 ! Uncomment following three lines for SC-p interactions
15881 !         xj=c(1,nres+j)-xi
15882 !         yj=c(2,nres+j)-yi
15883 !         zj=c(3,nres+j)-zi
15884 ! Uncomment following three lines for Ca-p interactions
15885           xj=c(1,j)
15886           yj=c(2,j)
15887           zj=c(3,j)
15888           xj=mod(xj,boxxsize)
15889           if (xj.lt.0) xj=xj+boxxsize
15890           yj=mod(yj,boxysize)
15891           if (yj.lt.0) yj=yj+boxysize
15892           zj=mod(zj,boxzsize)
15893           if (zj.lt.0) zj=zj+boxzsize
15894       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15895       xj_safe=xj
15896       yj_safe=yj
15897       zj_safe=zj
15898       subchap=0
15899       do xshift=-1,1
15900       do yshift=-1,1
15901       do zshift=-1,1
15902           xj=xj_safe+xshift*boxxsize
15903           yj=yj_safe+yshift*boxysize
15904           zj=zj_safe+zshift*boxzsize
15905           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15906           if(dist_temp.lt.dist_init) then
15907             dist_init=dist_temp
15908             xj_temp=xj
15909             yj_temp=yj
15910             zj_temp=zj
15911             subchap=1
15912           endif
15913        enddo
15914        enddo
15915        enddo
15916        if (subchap.eq.1) then
15917           xj=xj_temp-xi
15918           yj=yj_temp-yi
15919           zj=zj_temp-zi
15920        else
15921           xj=xj_safe-xi
15922           yj=yj_safe-yi
15923           zj=zj_safe-zi
15924        endif
15925           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15926
15927           rij=dsqrt(1.0d0/rrij)
15928             sss_ele_cut=sscale_ele(rij)
15929             sss_ele_grad=sscagrad_ele(rij)
15930 !            print *,sss_ele_cut,sss_ele_grad,&
15931 !            (rij),r_cut_ele,rlamb_ele
15932             if (sss_ele_cut.le.0.0) cycle
15933           sss=sscale((rij/rscp(itypj,iteli)))
15934           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15935           if (sss.lt.1.0d0) then
15936
15937             fac=rrij**expon2
15938             e1=fac*fac*aad(itypj,iteli)
15939             e2=fac*bad(itypj,iteli)
15940             if (iabs(j-i) .le. 2) then
15941               e1=scal14*e1
15942               e2=scal14*e2
15943               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15944             endif
15945             evdwij=e1+e2
15946             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15947             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15948                 'evdw2',i,j,sss,evdwij
15949 !
15950 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15951 !
15952             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15953             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15954             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15955             ggg(1)=xj*fac
15956             ggg(2)=yj*fac
15957             ggg(3)=zj*fac
15958 ! Uncomment following three lines for SC-p interactions
15959 !           do k=1,3
15960 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15961 !           enddo
15962 ! Uncomment following line for SC-p interactions
15963 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15964             do k=1,3
15965               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15966               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15967             enddo
15968           endif
15969         enddo
15970
15971         enddo ! iint
15972       enddo ! i
15973       do i=1,nct
15974         do j=1,3
15975           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15976           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15977           gradx_scp(j,i)=expon*gradx_scp(j,i)
15978         enddo
15979       enddo
15980 !******************************************************************************
15981 !
15982 !                              N O T E !!!
15983 !
15984 ! To save time the factor EXPON has been extracted from ALL components
15985 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15986 ! use!
15987 !
15988 !******************************************************************************
15989       return
15990       end subroutine escp_long
15991 !-----------------------------------------------------------------------------
15992       subroutine escp_short(evdw2,evdw2_14)
15993 !
15994 ! This subroutine calculates the excluded-volume interaction energy between
15995 ! peptide-group centers and side chains and its gradient in virtual-bond and
15996 ! side-chain vectors.
15997 !
15998 !      implicit real*8 (a-h,o-z)
15999 !      include 'DIMENSIONS'
16000 !      include 'COMMON.GEO'
16001 !      include 'COMMON.VAR'
16002 !      include 'COMMON.LOCAL'
16003 !      include 'COMMON.CHAIN'
16004 !      include 'COMMON.DERIV'
16005 !      include 'COMMON.INTERACT'
16006 !      include 'COMMON.FFIELD'
16007 !      include 'COMMON.IOUNITS'
16008 !      include 'COMMON.CONTROL'
16009       real(kind=8),dimension(3) :: ggg
16010 !el local variables
16011       integer :: i,iint,j,k,iteli,itypj,subchap
16012       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16013       real(kind=8) :: evdw2,evdw2_14,evdwij
16014       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16015                     dist_temp, dist_init
16016
16017       evdw2=0.0D0
16018       evdw2_14=0.0d0
16019 !d    print '(a)','Enter ESCP'
16020 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16021       do i=iatscp_s,iatscp_e
16022         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16023         iteli=itel(i)
16024         xi=0.5D0*(c(1,i)+c(1,i+1))
16025         yi=0.5D0*(c(2,i)+c(2,i+1))
16026         zi=0.5D0*(c(3,i)+c(3,i+1))
16027           xi=mod(xi,boxxsize)
16028           if (xi.lt.0) xi=xi+boxxsize
16029           yi=mod(yi,boxysize)
16030           if (yi.lt.0) yi=yi+boxysize
16031           zi=mod(zi,boxzsize)
16032           if (zi.lt.0) zi=zi+boxzsize
16033
16034         do iint=1,nscp_gr(i)
16035
16036         do j=iscpstart(i,iint),iscpend(i,iint)
16037           itypj=itype(j,1)
16038           if (itypj.eq.ntyp1) cycle
16039 ! Uncomment following three lines for SC-p interactions
16040 !         xj=c(1,nres+j)-xi
16041 !         yj=c(2,nres+j)-yi
16042 !         zj=c(3,nres+j)-zi
16043 ! Uncomment following three lines for Ca-p interactions
16044 !          xj=c(1,j)-xi
16045 !          yj=c(2,j)-yi
16046 !          zj=c(3,j)-zi
16047           xj=c(1,j)
16048           yj=c(2,j)
16049           zj=c(3,j)
16050           xj=mod(xj,boxxsize)
16051           if (xj.lt.0) xj=xj+boxxsize
16052           yj=mod(yj,boxysize)
16053           if (yj.lt.0) yj=yj+boxysize
16054           zj=mod(zj,boxzsize)
16055           if (zj.lt.0) zj=zj+boxzsize
16056       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16057       xj_safe=xj
16058       yj_safe=yj
16059       zj_safe=zj
16060       subchap=0
16061       do xshift=-1,1
16062       do yshift=-1,1
16063       do zshift=-1,1
16064           xj=xj_safe+xshift*boxxsize
16065           yj=yj_safe+yshift*boxysize
16066           zj=zj_safe+zshift*boxzsize
16067           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16068           if(dist_temp.lt.dist_init) then
16069             dist_init=dist_temp
16070             xj_temp=xj
16071             yj_temp=yj
16072             zj_temp=zj
16073             subchap=1
16074           endif
16075        enddo
16076        enddo
16077        enddo
16078        if (subchap.eq.1) then
16079           xj=xj_temp-xi
16080           yj=yj_temp-yi
16081           zj=zj_temp-zi
16082        else
16083           xj=xj_safe-xi
16084           yj=yj_safe-yi
16085           zj=zj_safe-zi
16086        endif
16087
16088           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16089           rij=dsqrt(1.0d0/rrij)
16090             sss_ele_cut=sscale_ele(rij)
16091             sss_ele_grad=sscagrad_ele(rij)
16092 !            print *,sss_ele_cut,sss_ele_grad,&
16093 !            (rij),r_cut_ele,rlamb_ele
16094             if (sss_ele_cut.le.0.0) cycle
16095           sss=sscale(rij/rscp(itypj,iteli))
16096           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16097           if (sss.gt.0.0d0) then
16098
16099             fac=rrij**expon2
16100             e1=fac*fac*aad(itypj,iteli)
16101             e2=fac*bad(itypj,iteli)
16102             if (iabs(j-i) .le. 2) then
16103               e1=scal14*e1
16104               e2=scal14*e2
16105               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16106             endif
16107             evdwij=e1+e2
16108             evdw2=evdw2+evdwij*sss*sss_ele_cut
16109             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16110                 'evdw2',i,j,sss,evdwij
16111 !
16112 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16113 !
16114             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16115             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16116             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16117
16118             ggg(1)=xj*fac
16119             ggg(2)=yj*fac
16120             ggg(3)=zj*fac
16121 ! Uncomment following three lines for SC-p interactions
16122 !           do k=1,3
16123 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16124 !           enddo
16125 ! Uncomment following line for SC-p interactions
16126 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16127             do k=1,3
16128               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16129               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16130             enddo
16131           endif
16132         enddo
16133
16134         enddo ! iint
16135       enddo ! i
16136       do i=1,nct
16137         do j=1,3
16138           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16139           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16140           gradx_scp(j,i)=expon*gradx_scp(j,i)
16141         enddo
16142       enddo
16143 !******************************************************************************
16144 !
16145 !                              N O T E !!!
16146 !
16147 ! To save time the factor EXPON has been extracted from ALL components
16148 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16149 ! use!
16150 !
16151 !******************************************************************************
16152       return
16153       end subroutine escp_short
16154 !-----------------------------------------------------------------------------
16155 ! energy_p_new-sep_barrier.F
16156 !-----------------------------------------------------------------------------
16157       subroutine sc_grad_scale(scalfac)
16158 !      implicit real*8 (a-h,o-z)
16159       use calc_data
16160 !      include 'DIMENSIONS'
16161 !      include 'COMMON.CHAIN'
16162 !      include 'COMMON.DERIV'
16163 !      include 'COMMON.CALC'
16164 !      include 'COMMON.IOUNITS'
16165       real(kind=8),dimension(3) :: dcosom1,dcosom2
16166       real(kind=8) :: scalfac
16167 !el local variables
16168 !      integer :: i,j,k,l
16169
16170       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16171       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16172       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16173            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16174 ! diagnostics only
16175 !      eom1=0.0d0
16176 !      eom2=0.0d0
16177 !      eom12=evdwij*eps1_om12
16178 ! end diagnostics
16179 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16180 !     &  " sigder",sigder
16181 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16182 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16183       do k=1,3
16184         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16185         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16186       enddo
16187       do k=1,3
16188         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16189          *sss_ele_cut
16190       enddo
16191 !      write (iout,*) "gg",(gg(k),k=1,3)
16192       do k=1,3
16193         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16194                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16195                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16196                  *sss_ele_cut
16197         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16198                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16199                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16200          *sss_ele_cut
16201 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16202 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16203 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16204 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16205       enddo
16206 !
16207 ! Calculate the components of the gradient in DC and X
16208 !
16209       do l=1,3
16210         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16211         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16212       enddo
16213       return
16214       end subroutine sc_grad_scale
16215 !-----------------------------------------------------------------------------
16216 ! energy_split-sep.F
16217 !-----------------------------------------------------------------------------
16218       subroutine etotal_long(energia)
16219 !
16220 ! Compute the long-range slow-varying contributions to the energy
16221 !
16222 !      implicit real*8 (a-h,o-z)
16223 !      include 'DIMENSIONS'
16224       use MD_data, only: totT,usampl,eq_time
16225 #ifndef ISNAN
16226       external proc_proc
16227 #ifdef WINPGI
16228 !MS$ATTRIBUTES C ::  proc_proc
16229 #endif
16230 #endif
16231 #ifdef MPI
16232       include "mpif.h"
16233       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16234 #endif
16235 !      include 'COMMON.SETUP'
16236 !      include 'COMMON.IOUNITS'
16237 !      include 'COMMON.FFIELD'
16238 !      include 'COMMON.DERIV'
16239 !      include 'COMMON.INTERACT'
16240 !      include 'COMMON.SBRIDGE'
16241 !      include 'COMMON.CHAIN'
16242 !      include 'COMMON.VAR'
16243 !      include 'COMMON.LOCAL'
16244 !      include 'COMMON.MD'
16245       real(kind=8),dimension(0:n_ene) :: energia
16246 !el local variables
16247       integer :: i,n_corr,n_corr1,ierror,ierr
16248       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16249                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16250                   ecorr,ecorr5,ecorr6,eturn6,time00
16251 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16252 !elwrite(iout,*)"in etotal long"
16253
16254       if (modecalc.eq.12.or.modecalc.eq.14) then
16255 #ifdef MPI
16256 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16257 #else
16258         call int_from_cart1(.false.)
16259 #endif
16260       endif
16261 !elwrite(iout,*)"in etotal long"
16262
16263 #ifdef MPI
16264 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16265 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16266       call flush(iout)
16267       if (nfgtasks.gt.1) then
16268         time00=MPI_Wtime()
16269 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16270         if (fg_rank.eq.0) then
16271           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16272 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16273 !          call flush(iout)
16274 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16275 ! FG slaves as WEIGHTS array.
16276           weights_(1)=wsc
16277           weights_(2)=wscp
16278           weights_(3)=welec
16279           weights_(4)=wcorr
16280           weights_(5)=wcorr5
16281           weights_(6)=wcorr6
16282           weights_(7)=wel_loc
16283           weights_(8)=wturn3
16284           weights_(9)=wturn4
16285           weights_(10)=wturn6
16286           weights_(11)=wang
16287           weights_(12)=wscloc
16288           weights_(13)=wtor
16289           weights_(14)=wtor_d
16290           weights_(15)=wstrain
16291           weights_(16)=wvdwpp
16292           weights_(17)=wbond
16293           weights_(18)=scal14
16294           weights_(21)=wsccor
16295 ! FG Master broadcasts the WEIGHTS_ array
16296           call MPI_Bcast(weights_(1),n_ene,&
16297               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16298         else
16299 ! FG slaves receive the WEIGHTS array
16300           call MPI_Bcast(weights(1),n_ene,&
16301               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16302           wsc=weights(1)
16303           wscp=weights(2)
16304           welec=weights(3)
16305           wcorr=weights(4)
16306           wcorr5=weights(5)
16307           wcorr6=weights(6)
16308           wel_loc=weights(7)
16309           wturn3=weights(8)
16310           wturn4=weights(9)
16311           wturn6=weights(10)
16312           wang=weights(11)
16313           wscloc=weights(12)
16314           wtor=weights(13)
16315           wtor_d=weights(14)
16316           wstrain=weights(15)
16317           wvdwpp=weights(16)
16318           wbond=weights(17)
16319           scal14=weights(18)
16320           wsccor=weights(21)
16321         endif
16322         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16323           king,FG_COMM,IERR)
16324          time_Bcast=time_Bcast+MPI_Wtime()-time00
16325          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16326 !        call chainbuild_cart
16327 !        call int_from_cart1(.false.)
16328       endif
16329 !      write (iout,*) 'Processor',myrank,
16330 !     &  ' calling etotal_short ipot=',ipot
16331 !      call flush(iout)
16332 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16333 #endif
16334 !d    print *,'nnt=',nnt,' nct=',nct
16335 !
16336 !elwrite(iout,*)"in etotal long"
16337 ! Compute the side-chain and electrostatic interaction energy
16338 !
16339       goto (101,102,103,104,105,106) ipot
16340 ! Lennard-Jones potential.
16341   101 call elj_long(evdw)
16342 !d    print '(a)','Exit ELJ'
16343       goto 107
16344 ! Lennard-Jones-Kihara potential (shifted).
16345   102 call eljk_long(evdw)
16346       goto 107
16347 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16348   103 call ebp_long(evdw)
16349       goto 107
16350 ! Gay-Berne potential (shifted LJ, angular dependence).
16351   104 call egb_long(evdw)
16352       goto 107
16353 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16354   105 call egbv_long(evdw)
16355       goto 107
16356 ! Soft-sphere potential
16357   106 call e_softsphere(evdw)
16358 !
16359 ! Calculate electrostatic (H-bonding) energy of the main chain.
16360 !
16361   107 continue
16362       call vec_and_deriv
16363       if (ipot.lt.6) then
16364 #ifdef SPLITELE
16365          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16366              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16367              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16368              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16369 #else
16370          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16371              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16372              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16373              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16374 #endif
16375            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16376          else
16377             ees=0
16378             evdw1=0
16379             eel_loc=0
16380             eello_turn3=0
16381             eello_turn4=0
16382          endif
16383       else
16384 !        write (iout,*) "Soft-spheer ELEC potential"
16385         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16386          eello_turn4)
16387       endif
16388 !
16389 ! Calculate excluded-volume interaction energy between peptide groups
16390 ! and side chains.
16391 !
16392       if (ipot.lt.6) then
16393        if(wscp.gt.0d0) then
16394         call escp_long(evdw2,evdw2_14)
16395        else
16396         evdw2=0
16397         evdw2_14=0
16398        endif
16399       else
16400         call escp_soft_sphere(evdw2,evdw2_14)
16401       endif
16402 !
16403 ! 12/1/95 Multi-body terms
16404 !
16405       n_corr=0
16406       n_corr1=0
16407       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16408           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16409          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16410 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16411 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16412       else
16413          ecorr=0.0d0
16414          ecorr5=0.0d0
16415          ecorr6=0.0d0
16416          eturn6=0.0d0
16417       endif
16418       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16419          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16420       endif
16421 !
16422 ! If performing constraint dynamics, call the constraint energy
16423 !  after the equilibration time
16424       if(usampl.and.totT.gt.eq_time) then
16425          call EconstrQ
16426          call Econstr_back
16427       else
16428          Uconst=0.0d0
16429          Uconst_back=0.0d0
16430       endif
16431 !
16432 ! Sum the energies
16433 !
16434       do i=1,n_ene
16435         energia(i)=0.0d0
16436       enddo
16437       energia(1)=evdw
16438 #ifdef SCP14
16439       energia(2)=evdw2-evdw2_14
16440       energia(18)=evdw2_14
16441 #else
16442       energia(2)=evdw2
16443       energia(18)=0.0d0
16444 #endif
16445 #ifdef SPLITELE
16446       energia(3)=ees
16447       energia(16)=evdw1
16448 #else
16449       energia(3)=ees+evdw1
16450       energia(16)=0.0d0
16451 #endif
16452       energia(4)=ecorr
16453       energia(5)=ecorr5
16454       energia(6)=ecorr6
16455       energia(7)=eel_loc
16456       energia(8)=eello_turn3
16457       energia(9)=eello_turn4
16458       energia(10)=eturn6
16459       energia(20)=Uconst+Uconst_back
16460       call sum_energy(energia,.true.)
16461 !      write (iout,*) "Exit ETOTAL_LONG"
16462       call flush(iout)
16463       return
16464       end subroutine etotal_long
16465 !-----------------------------------------------------------------------------
16466       subroutine etotal_short(energia)
16467 !
16468 ! Compute the short-range fast-varying contributions to the energy
16469 !
16470 !      implicit real*8 (a-h,o-z)
16471 !      include 'DIMENSIONS'
16472 #ifndef ISNAN
16473       external proc_proc
16474 #ifdef WINPGI
16475 !MS$ATTRIBUTES C ::  proc_proc
16476 #endif
16477 #endif
16478 #ifdef MPI
16479       include "mpif.h"
16480       integer :: ierror,ierr
16481       real(kind=8),dimension(n_ene) :: weights_
16482       real(kind=8) :: time00
16483 #endif
16484 !      include 'COMMON.SETUP'
16485 !      include 'COMMON.IOUNITS'
16486 !      include 'COMMON.FFIELD'
16487 !      include 'COMMON.DERIV'
16488 !      include 'COMMON.INTERACT'
16489 !      include 'COMMON.SBRIDGE'
16490 !      include 'COMMON.CHAIN'
16491 !      include 'COMMON.VAR'
16492 !      include 'COMMON.LOCAL'
16493       real(kind=8),dimension(0:n_ene) :: energia
16494 !el local variables
16495       integer :: i,nres6
16496       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16497       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16498       nres6=6*nres
16499
16500 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16501 !      call flush(iout)
16502       if (modecalc.eq.12.or.modecalc.eq.14) then
16503 #ifdef MPI
16504         if (fg_rank.eq.0) call int_from_cart1(.false.)
16505 #else
16506         call int_from_cart1(.false.)
16507 #endif
16508       endif
16509 #ifdef MPI
16510 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16511 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16512 !      call flush(iout)
16513       if (nfgtasks.gt.1) then
16514         time00=MPI_Wtime()
16515 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16516         if (fg_rank.eq.0) then
16517           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16518 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16519 !          call flush(iout)
16520 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16521 ! FG slaves as WEIGHTS array.
16522           weights_(1)=wsc
16523           weights_(2)=wscp
16524           weights_(3)=welec
16525           weights_(4)=wcorr
16526           weights_(5)=wcorr5
16527           weights_(6)=wcorr6
16528           weights_(7)=wel_loc
16529           weights_(8)=wturn3
16530           weights_(9)=wturn4
16531           weights_(10)=wturn6
16532           weights_(11)=wang
16533           weights_(12)=wscloc
16534           weights_(13)=wtor
16535           weights_(14)=wtor_d
16536           weights_(15)=wstrain
16537           weights_(16)=wvdwpp
16538           weights_(17)=wbond
16539           weights_(18)=scal14
16540           weights_(21)=wsccor
16541 ! FG Master broadcasts the WEIGHTS_ array
16542           call MPI_Bcast(weights_(1),n_ene,&
16543               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16544         else
16545 ! FG slaves receive the WEIGHTS array
16546           call MPI_Bcast(weights(1),n_ene,&
16547               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16548           wsc=weights(1)
16549           wscp=weights(2)
16550           welec=weights(3)
16551           wcorr=weights(4)
16552           wcorr5=weights(5)
16553           wcorr6=weights(6)
16554           wel_loc=weights(7)
16555           wturn3=weights(8)
16556           wturn4=weights(9)
16557           wturn6=weights(10)
16558           wang=weights(11)
16559           wscloc=weights(12)
16560           wtor=weights(13)
16561           wtor_d=weights(14)
16562           wstrain=weights(15)
16563           wvdwpp=weights(16)
16564           wbond=weights(17)
16565           scal14=weights(18)
16566           wsccor=weights(21)
16567         endif
16568 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16569         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16570           king,FG_COMM,IERR)
16571 !        write (iout,*) "Processor",myrank," BROADCAST c"
16572         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16573           king,FG_COMM,IERR)
16574 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16575         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16576           king,FG_COMM,IERR)
16577 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16578         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16579           king,FG_COMM,IERR)
16580 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16581         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16582           king,FG_COMM,IERR)
16583 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16584         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16585           king,FG_COMM,IERR)
16586 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16587         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16588           king,FG_COMM,IERR)
16589 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16590         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16591           king,FG_COMM,IERR)
16592 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16593         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16594           king,FG_COMM,IERR)
16595          time_Bcast=time_Bcast+MPI_Wtime()-time00
16596 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16597       endif
16598 !      write (iout,*) 'Processor',myrank,
16599 !     &  ' calling etotal_short ipot=',ipot
16600 !      call flush(iout)
16601 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16602 #endif
16603 !      call int_from_cart1(.false.)
16604 !
16605 ! Compute the side-chain and electrostatic interaction energy
16606 !
16607       goto (101,102,103,104,105,106) ipot
16608 ! Lennard-Jones potential.
16609   101 call elj_short(evdw)
16610 !d    print '(a)','Exit ELJ'
16611       goto 107
16612 ! Lennard-Jones-Kihara potential (shifted).
16613   102 call eljk_short(evdw)
16614       goto 107
16615 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16616   103 call ebp_short(evdw)
16617       goto 107
16618 ! Gay-Berne potential (shifted LJ, angular dependence).
16619   104 call egb_short(evdw)
16620       goto 107
16621 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16622   105 call egbv_short(evdw)
16623       goto 107
16624 ! Soft-sphere potential - already dealt with in the long-range part
16625   106 evdw=0.0d0
16626 !  106 call e_softsphere_short(evdw)
16627 !
16628 ! Calculate electrostatic (H-bonding) energy of the main chain.
16629 !
16630   107 continue
16631 !
16632 ! Calculate the short-range part of Evdwpp
16633 !
16634       call evdwpp_short(evdw1)
16635 !
16636 ! Calculate the short-range part of ESCp
16637 !
16638       if (ipot.lt.6) then
16639         call escp_short(evdw2,evdw2_14)
16640       endif
16641 !
16642 ! Calculate the bond-stretching energy
16643 !
16644       call ebond(estr)
16645 !
16646 ! Calculate the disulfide-bridge and other energy and the contributions
16647 ! from other distance constraints.
16648       call edis(ehpb)
16649 !
16650 ! Calculate the virtual-bond-angle energy.
16651 !
16652 ! Calculate the SC local energy.
16653 !
16654       call vec_and_deriv
16655       call esc(escloc)
16656 !
16657       if (wang.gt.0d0) then
16658        if (tor_mode.eq.0) then
16659          call ebend(ebe)
16660        else
16661 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16662 !C energy function
16663          call ebend_kcc(ebe)
16664        endif
16665       else
16666         ebe=0.0d0
16667       endif
16668       ethetacnstr=0.0d0
16669       if (with_theta_constr) call etheta_constr(ethetacnstr)
16670
16671 !       write(iout,*) "in etotal afer ebe",ipot
16672
16673 !      print *,"Processor",myrank," computed UB"
16674 !
16675 ! Calculate the SC local energy.
16676 !
16677       call esc(escloc)
16678 !elwrite(iout,*) "in etotal afer esc",ipot
16679 !      print *,"Processor",myrank," computed USC"
16680 !
16681 ! Calculate the virtual-bond torsional energy.
16682 !
16683 !d    print *,'nterm=',nterm
16684 !      if (wtor.gt.0) then
16685 !       call etor(etors,edihcnstr)
16686 !      else
16687 !       etors=0
16688 !       edihcnstr=0
16689 !      endif
16690       if (wtor.gt.0.0d0) then
16691          if (tor_mode.eq.0) then
16692            call etor(etors)
16693          else
16694 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16695 !C energy function
16696            call etor_kcc(etors)
16697          endif
16698       else
16699         etors=0.0d0
16700       endif
16701       edihcnstr=0.0d0
16702       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16703
16704 ! Calculate the virtual-bond torsional energy.
16705 !
16706 !
16707 ! 6/23/01 Calculate double-torsional energy
16708 !
16709       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16710       call etor_d(etors_d)
16711       endif
16712 !
16713 ! 21/5/07 Calculate local sicdechain correlation energy
16714 !
16715       if (wsccor.gt.0.0d0) then
16716         call eback_sc_corr(esccor)
16717       else
16718         esccor=0.0d0
16719       endif
16720 !
16721 ! Put energy components into an array
16722 !
16723       do i=1,n_ene
16724         energia(i)=0.0d0
16725       enddo
16726       energia(1)=evdw
16727 #ifdef SCP14
16728       energia(2)=evdw2-evdw2_14
16729       energia(18)=evdw2_14
16730 #else
16731       energia(2)=evdw2
16732       energia(18)=0.0d0
16733 #endif
16734 #ifdef SPLITELE
16735       energia(16)=evdw1
16736 #else
16737       energia(3)=evdw1
16738 #endif
16739       energia(11)=ebe
16740       energia(12)=escloc
16741       energia(13)=etors
16742       energia(14)=etors_d
16743       energia(15)=ehpb
16744       energia(17)=estr
16745       energia(19)=edihcnstr
16746       energia(21)=esccor
16747 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16748       call flush(iout)
16749       call sum_energy(energia,.true.)
16750 !      write (iout,*) "Exit ETOTAL_SHORT"
16751       call flush(iout)
16752       return
16753       end subroutine etotal_short
16754 !-----------------------------------------------------------------------------
16755 ! gnmr1.f
16756 !-----------------------------------------------------------------------------
16757       real(kind=8) function gnmr1(y,ymin,ymax)
16758 !      implicit none
16759       real(kind=8) :: y,ymin,ymax
16760       real(kind=8) :: wykl=4.0d0
16761       if (y.lt.ymin) then
16762         gnmr1=(ymin-y)**wykl/wykl
16763       else if (y.gt.ymax) then
16764         gnmr1=(y-ymax)**wykl/wykl
16765       else
16766         gnmr1=0.0d0
16767       endif
16768       return
16769       end function gnmr1
16770 !-----------------------------------------------------------------------------
16771       real(kind=8) function gnmr1prim(y,ymin,ymax)
16772 !      implicit none
16773       real(kind=8) :: y,ymin,ymax
16774       real(kind=8) :: wykl=4.0d0
16775       if (y.lt.ymin) then
16776         gnmr1prim=-(ymin-y)**(wykl-1)
16777       else if (y.gt.ymax) then
16778         gnmr1prim=(y-ymax)**(wykl-1)
16779       else
16780         gnmr1prim=0.0d0
16781       endif
16782       return
16783       end function gnmr1prim
16784 !----------------------------------------------------------------------------
16785       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16786       real(kind=8) y,ymin,ymax,sigma
16787       real(kind=8) wykl /4.0d0/
16788       if (y.lt.ymin) then
16789         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16790       else if (y.gt.ymax) then
16791         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16792       else
16793         rlornmr1=0.0d0
16794       endif
16795       return
16796       end function rlornmr1
16797 !------------------------------------------------------------------------------
16798       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16799       real(kind=8) y,ymin,ymax,sigma
16800       real(kind=8) wykl /4.0d0/
16801       if (y.lt.ymin) then
16802         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16803         ((ymin-y)**wykl+sigma**wykl)**2
16804       else if (y.gt.ymax) then
16805         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16806         ((y-ymax)**wykl+sigma**wykl)**2
16807       else
16808         rlornmr1prim=0.0d0
16809       endif
16810       return
16811       end function rlornmr1prim
16812
16813       real(kind=8) function harmonic(y,ymax)
16814 !      implicit none
16815       real(kind=8) :: y,ymax
16816       real(kind=8) :: wykl=2.0d0
16817       harmonic=(y-ymax)**wykl
16818       return
16819       end function harmonic
16820 !-----------------------------------------------------------------------------
16821       real(kind=8) function harmonicprim(y,ymax)
16822       real(kind=8) :: y,ymin,ymax
16823       real(kind=8) :: wykl=2.0d0
16824       harmonicprim=(y-ymax)*wykl
16825       return
16826       end function harmonicprim
16827 !-----------------------------------------------------------------------------
16828 ! gradient_p.F
16829 !-----------------------------------------------------------------------------
16830       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16831
16832       use io_base, only:intout,briefout
16833 !      implicit real*8 (a-h,o-z)
16834 !      include 'DIMENSIONS'
16835 !      include 'COMMON.CHAIN'
16836 !      include 'COMMON.DERIV'
16837 !      include 'COMMON.VAR'
16838 !      include 'COMMON.INTERACT'
16839 !      include 'COMMON.FFIELD'
16840 !      include 'COMMON.MD'
16841 !      include 'COMMON.IOUNITS'
16842       real(kind=8),external :: ufparm
16843       integer :: uiparm(1)
16844       real(kind=8) :: urparm(1)
16845       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16846       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16847       integer :: n,nf,ind,ind1,i,k,j
16848 !
16849 ! This subroutine calculates total internal coordinate gradient.
16850 ! Depending on the number of function evaluations, either whole energy
16851 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16852 ! internal coordinates are reevaluated or only the cartesian-in-internal
16853 ! coordinate derivatives are evaluated. The subroutine was designed to work
16854 ! with SUMSL.
16855 !
16856 !
16857       icg=mod(nf,2)+1
16858
16859 !d      print *,'grad',nf,icg
16860       if (nf-nfl+1) 20,30,40
16861    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16862 !    write (iout,*) 'grad 20'
16863       if (nf.eq.0) return
16864       goto 40
16865    30 call var_to_geom(n,x)
16866       call chainbuild
16867 !    write (iout,*) 'grad 30'
16868 !
16869 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16870 !
16871    40 call cartder
16872 !     write (iout,*) 'grad 40'
16873 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16874 !
16875 ! Convert the Cartesian gradient into internal-coordinate gradient.
16876 !
16877       ind=0
16878       ind1=0
16879       do i=1,nres-2
16880       gthetai=0.0D0
16881       gphii=0.0D0
16882       do j=i+1,nres-1
16883           ind=ind+1
16884 !         ind=indmat(i,j)
16885 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16886         do k=1,3
16887             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16888           enddo
16889         do k=1,3
16890           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16891           enddo
16892         enddo
16893       do j=i+1,nres-1
16894           ind1=ind1+1
16895 !         ind1=indmat(i,j)
16896 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16897         do k=1,3
16898           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16899           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16900           enddo
16901         enddo
16902       if (i.gt.1) g(i-1)=gphii
16903       if (n.gt.nphi) g(nphi+i)=gthetai
16904       enddo
16905       if (n.le.nphi+ntheta) goto 10
16906       do i=2,nres-1
16907       if (itype(i,1).ne.10) then
16908           galphai=0.0D0
16909         gomegai=0.0D0
16910         do k=1,3
16911           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16912           enddo
16913         do k=1,3
16914           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16915           enddo
16916           g(ialph(i,1))=galphai
16917         g(ialph(i,1)+nside)=gomegai
16918         endif
16919       enddo
16920 !
16921 ! Add the components corresponding to local energy terms.
16922 !
16923    10 continue
16924       do i=1,nvar
16925 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16926         g(i)=g(i)+gloc(i,icg)
16927       enddo
16928 ! Uncomment following three lines for diagnostics.
16929 !d    call intout
16930 !elwrite(iout,*) "in gradient after calling intout"
16931 !d    call briefout(0,0.0d0)
16932 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16933       return
16934       end subroutine gradient
16935 !-----------------------------------------------------------------------------
16936       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16937
16938       use comm_chu
16939 !      implicit real*8 (a-h,o-z)
16940 !      include 'DIMENSIONS'
16941 !      include 'COMMON.DERIV'
16942 !      include 'COMMON.IOUNITS'
16943 !      include 'COMMON.GEO'
16944       integer :: n,nf
16945 !el      integer :: jjj
16946 !el      common /chuju/ jjj
16947       real(kind=8) :: energia(0:n_ene)
16948       integer :: uiparm(1)
16949       real(kind=8) :: urparm(1)
16950       real(kind=8) :: f
16951       real(kind=8),external :: ufparm
16952       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16953 !     if (jjj.gt.0) then
16954 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16955 !     endif
16956       nfl=nf
16957       icg=mod(nf,2)+1
16958 !d      print *,'func',nf,nfl,icg
16959       call var_to_geom(n,x)
16960       call zerograd
16961       call chainbuild
16962 !d    write (iout,*) 'ETOTAL called from FUNC'
16963       call etotal(energia)
16964       call sum_gradient
16965       f=energia(0)
16966 !     if (jjj.gt.0) then
16967 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16968 !       write (iout,*) 'f=',etot
16969 !       jjj=0
16970 !     endif
16971       return
16972       end subroutine func
16973 !-----------------------------------------------------------------------------
16974       subroutine cartgrad
16975 !      implicit real*8 (a-h,o-z)
16976 !      include 'DIMENSIONS'
16977       use energy_data
16978       use MD_data, only: totT,usampl,eq_time
16979 #ifdef MPI
16980       include 'mpif.h'
16981 #endif
16982 !      include 'COMMON.CHAIN'
16983 !      include 'COMMON.DERIV'
16984 !      include 'COMMON.VAR'
16985 !      include 'COMMON.INTERACT'
16986 !      include 'COMMON.FFIELD'
16987 !      include 'COMMON.MD'
16988 !      include 'COMMON.IOUNITS'
16989 !      include 'COMMON.TIME1'
16990 !
16991       integer :: i,j
16992
16993 ! This subrouting calculates total Cartesian coordinate gradient.
16994 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16995 !
16996 !#define DEBUG
16997 #ifdef TIMING
16998       time00=MPI_Wtime()
16999 #endif
17000       icg=1
17001       call sum_gradient
17002 #ifdef TIMING
17003 #endif
17004 !#define DEBUG
17005 !el      write (iout,*) "After sum_gradient"
17006 #ifdef DEBUG
17007 !el      write (iout,*) "After sum_gradient"
17008       do i=1,nres-1
17009         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17010         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17011       enddo
17012 #endif
17013 !#undef DEBUG
17014 ! If performing constraint dynamics, add the gradients of the constraint energy
17015       if(usampl.and.totT.gt.eq_time) then
17016          do i=1,nct
17017            do j=1,3
17018              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17019              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17020            enddo
17021          enddo
17022          do i=1,nres-3
17023            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17024          enddo
17025          do i=1,nres-2
17026            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17027          enddo
17028       endif
17029 !elwrite (iout,*) "After sum_gradient"
17030 #ifdef TIMING
17031       time01=MPI_Wtime()
17032 #endif
17033       call intcartderiv
17034 !elwrite (iout,*) "After sum_gradient"
17035 #ifdef TIMING
17036       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17037 #endif
17038 !     call checkintcartgrad
17039 !     write(iout,*) 'calling int_to_cart'
17040 !#define DEBUG
17041 #ifdef DEBUG
17042       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17043 #endif
17044       do i=0,nct
17045         do j=1,3
17046           gcart(j,i)=gradc(j,i,icg)
17047           gxcart(j,i)=gradx(j,i,icg)
17048 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17049         enddo
17050 #ifdef DEBUG
17051         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17052           (gxcart(j,i),j=1,3),gloc(i,icg)
17053 #endif
17054       enddo
17055 #ifdef TIMING
17056       time01=MPI_Wtime()
17057 #endif
17058 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17059       call int_to_cart
17060 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17061
17062 #ifdef TIMING
17063             time_inttocart=time_inttocart+MPI_Wtime()-time01
17064 #endif
17065 #ifdef DEBUG
17066             write (iout,*) "gcart and gxcart after int_to_cart"
17067             do i=0,nres-1
17068             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17069                 (gxcart(j,i),j=1,3)
17070             enddo
17071 #endif
17072 !#undef DEBUG
17073 #ifdef CARGRAD
17074 #ifdef DEBUG
17075             write (iout,*) "CARGRAD"
17076 #endif
17077             do i=nres,0,-1
17078             do j=1,3
17079               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17080       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17081             enddo
17082       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17083       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17084             enddo
17085       ! Correction: dummy residues
17086             if (nnt.gt.1) then
17087               do j=1,3
17088       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17089                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17090               enddo
17091             endif
17092             if (nct.lt.nres) then
17093               do j=1,3
17094       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17095                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17096               enddo
17097             endif
17098 #endif
17099 #ifdef TIMING
17100             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17101 #endif
17102 !#undef DEBUG
17103             return
17104             end subroutine cartgrad
17105       !-----------------------------------------------------------------------------
17106             subroutine zerograd
17107       !      implicit real*8 (a-h,o-z)
17108       !      include 'DIMENSIONS'
17109       !      include 'COMMON.DERIV'
17110       !      include 'COMMON.CHAIN'
17111       !      include 'COMMON.VAR'
17112       !      include 'COMMON.MD'
17113       !      include 'COMMON.SCCOR'
17114       !
17115       !el local variables
17116             integer :: i,j,intertyp,k
17117       ! Initialize Cartesian-coordinate gradient
17118       !
17119       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17120       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17121
17122       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17123       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17124       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17125       !      allocate(gradcorr_long(3,nres))
17126       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17127       !      allocate(gcorr6_turn_long(3,nres))
17128       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17129
17130       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17131
17132       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17133       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17134
17135       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17136       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17137
17138       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17139       !      allocate(gscloc(3,nres)) !(3,maxres)
17140       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17141
17142
17143
17144       !      common /deriv_scloc/
17145       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17146       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17147       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17148       !      common /mpgrad/
17149       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17150
17151
17152
17153       !          gradc(j,i,icg)=0.0d0
17154       !          gradx(j,i,icg)=0.0d0
17155
17156       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17157       !elwrite(iout,*) "icg",icg
17158             do i=-1,nres
17159             do j=1,3
17160               gvdwx(j,i)=0.0D0
17161               gradx_scp(j,i)=0.0D0
17162               gvdwc(j,i)=0.0D0
17163               gvdwc_scp(j,i)=0.0D0
17164               gvdwc_scpp(j,i)=0.0d0
17165               gelc(j,i)=0.0D0
17166               gelc_long(j,i)=0.0D0
17167               gradb(j,i)=0.0d0
17168               gradbx(j,i)=0.0d0
17169               gvdwpp(j,i)=0.0d0
17170               gel_loc(j,i)=0.0d0
17171               gel_loc_long(j,i)=0.0d0
17172               ghpbc(j,i)=0.0D0
17173               ghpbx(j,i)=0.0D0
17174               gcorr3_turn(j,i)=0.0d0
17175               gcorr4_turn(j,i)=0.0d0
17176               gradcorr(j,i)=0.0d0
17177               gradcorr_long(j,i)=0.0d0
17178               gradcorr5_long(j,i)=0.0d0
17179               gradcorr6_long(j,i)=0.0d0
17180               gcorr6_turn_long(j,i)=0.0d0
17181               gradcorr5(j,i)=0.0d0
17182               gradcorr6(j,i)=0.0d0
17183               gcorr6_turn(j,i)=0.0d0
17184               gsccorc(j,i)=0.0d0
17185               gsccorx(j,i)=0.0d0
17186               gradc(j,i,icg)=0.0d0
17187               gradx(j,i,icg)=0.0d0
17188               gscloc(j,i)=0.0d0
17189               gsclocx(j,i)=0.0d0
17190               gliptran(j,i)=0.0d0
17191               gliptranx(j,i)=0.0d0
17192               gliptranc(j,i)=0.0d0
17193               gshieldx(j,i)=0.0d0
17194               gshieldc(j,i)=0.0d0
17195               gshieldc_loc(j,i)=0.0d0
17196               gshieldx_ec(j,i)=0.0d0
17197               gshieldc_ec(j,i)=0.0d0
17198               gshieldc_loc_ec(j,i)=0.0d0
17199               gshieldx_t3(j,i)=0.0d0
17200               gshieldc_t3(j,i)=0.0d0
17201               gshieldc_loc_t3(j,i)=0.0d0
17202               gshieldx_t4(j,i)=0.0d0
17203               gshieldc_t4(j,i)=0.0d0
17204               gshieldc_loc_t4(j,i)=0.0d0
17205               gshieldx_ll(j,i)=0.0d0
17206               gshieldc_ll(j,i)=0.0d0
17207               gshieldc_loc_ll(j,i)=0.0d0
17208               gg_tube(j,i)=0.0d0
17209               gg_tube_sc(j,i)=0.0d0
17210               gradafm(j,i)=0.0d0
17211               gradb_nucl(j,i)=0.0d0
17212               gradbx_nucl(j,i)=0.0d0
17213               gvdwpp_nucl(j,i)=0.0d0
17214               gvdwpp(j,i)=0.0d0
17215               gelpp(j,i)=0.0d0
17216               gvdwpsb(j,i)=0.0d0
17217               gvdwpsb1(j,i)=0.0d0
17218               gvdwsbc(j,i)=0.0d0
17219               gvdwsbx(j,i)=0.0d0
17220               gelsbc(j,i)=0.0d0
17221               gradcorr_nucl(j,i)=0.0d0
17222               gradcorr3_nucl(j,i)=0.0d0
17223               gradxorr_nucl(j,i)=0.0d0
17224               gradxorr3_nucl(j,i)=0.0d0
17225               gelsbx(j,i)=0.0d0
17226               gsbloc(j,i)=0.0d0
17227               gsblocx(j,i)=0.0d0
17228               gradpepcat(j,i)=0.0d0
17229               gradpepcatx(j,i)=0.0d0
17230               gradcatcat(j,i)=0.0d0
17231               gvdwx_scbase(j,i)=0.0d0
17232               gvdwc_scbase(j,i)=0.0d0
17233               gvdwx_pepbase(j,i)=0.0d0
17234               gvdwc_pepbase(j,i)=0.0d0
17235               gvdwx_scpho(j,i)=0.0d0
17236               gvdwc_scpho(j,i)=0.0d0
17237               gvdwc_peppho(j,i)=0.0d0
17238             enddo
17239              enddo
17240             do i=0,nres
17241             do j=1,3
17242               do intertyp=1,3
17243                gloc_sc(intertyp,i,icg)=0.0d0
17244               enddo
17245             enddo
17246             enddo
17247             do i=1,nres
17248              do j=1,maxcontsshi
17249              shield_list(j,i)=0
17250             do k=1,3
17251       !C           print *,i,j,k
17252                grad_shield_side(k,j,i)=0.0d0
17253                grad_shield_loc(k,j,i)=0.0d0
17254              enddo
17255              enddo
17256              ishield_list(i)=0
17257             enddo
17258
17259       !
17260       ! Initialize the gradient of local energy terms.
17261       !
17262       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17263       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17264       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17265       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17266       !      allocate(gel_loc_turn3(nres))
17267       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17268       !      allocate(gsccor_loc(nres))      !(maxres)
17269
17270             do i=1,4*nres
17271             gloc(i,icg)=0.0D0
17272             enddo
17273             do i=1,nres
17274             gel_loc_loc(i)=0.0d0
17275             gcorr_loc(i)=0.0d0
17276             g_corr5_loc(i)=0.0d0
17277             g_corr6_loc(i)=0.0d0
17278             gel_loc_turn3(i)=0.0d0
17279             gel_loc_turn4(i)=0.0d0
17280             gel_loc_turn6(i)=0.0d0
17281             gsccor_loc(i)=0.0d0
17282             enddo
17283       ! initialize gcart and gxcart
17284       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17285             do i=0,nres
17286             do j=1,3
17287               gcart(j,i)=0.0d0
17288               gxcart(j,i)=0.0d0
17289             enddo
17290             enddo
17291             return
17292             end subroutine zerograd
17293       !-----------------------------------------------------------------------------
17294             real(kind=8) function fdum()
17295             fdum=0.0D0
17296             return
17297             end function fdum
17298       !-----------------------------------------------------------------------------
17299       ! intcartderiv.F
17300       !-----------------------------------------------------------------------------
17301             subroutine intcartderiv
17302       !      implicit real*8 (a-h,o-z)
17303       !      include 'DIMENSIONS'
17304 #ifdef MPI
17305             include 'mpif.h'
17306 #endif
17307       !      include 'COMMON.SETUP'
17308       !      include 'COMMON.CHAIN'
17309       !      include 'COMMON.VAR'
17310       !      include 'COMMON.GEO'
17311       !      include 'COMMON.INTERACT'
17312       !      include 'COMMON.DERIV'
17313       !      include 'COMMON.IOUNITS'
17314       !      include 'COMMON.LOCAL'
17315       !      include 'COMMON.SCCOR'
17316             real(kind=8) :: pi4,pi34
17317             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17318             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17319                       dcosomega,dsinomega !(3,3,maxres)
17320             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17321
17322             integer :: i,j,k
17323             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17324                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17325                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17326                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17327             integer :: nres2
17328             nres2=2*nres
17329
17330       !el from module energy-------------
17331       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17332       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17333       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17334
17335       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17336       !el      allocate(dsintau(3,3,3,0:nres2))
17337       !el      allocate(dtauangle(3,3,3,0:nres2))
17338       !el      allocate(domicron(3,2,2,0:nres2))
17339       !el      allocate(dcosomicron(3,2,2,0:nres2))
17340
17341
17342
17343 #if defined(MPI) && defined(PARINTDER)
17344             if (nfgtasks.gt.1 .and. me.eq.king) &
17345             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17346 #endif
17347             pi4 = 0.5d0*pipol
17348             pi34 = 3*pi4
17349
17350       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17351       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17352
17353       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17354             do i=1,nres
17355             do j=1,3
17356               dtheta(j,1,i)=0.0d0
17357               dtheta(j,2,i)=0.0d0
17358               dphi(j,1,i)=0.0d0
17359               dphi(j,2,i)=0.0d0
17360               dphi(j,3,i)=0.0d0
17361             enddo
17362             enddo
17363       ! Derivatives of theta's
17364 #if defined(MPI) && defined(PARINTDER)
17365       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17366             do i=max0(ithet_start-1,3),ithet_end
17367 #else
17368             do i=3,nres
17369 #endif
17370             cost=dcos(theta(i))
17371             sint=sqrt(1-cost*cost)
17372             do j=1,3
17373               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17374               vbld(i-1)
17375               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17376               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17377               vbld(i)
17378               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17379             enddo
17380             enddo
17381 #if defined(MPI) && defined(PARINTDER)
17382       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17383             do i=max0(ithet_start-1,3),ithet_end
17384 #else
17385             do i=3,nres
17386 #endif
17387             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17388             cost1=dcos(omicron(1,i))
17389             sint1=sqrt(1-cost1*cost1)
17390             cost2=dcos(omicron(2,i))
17391             sint2=sqrt(1-cost2*cost2)
17392              do j=1,3
17393       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17394               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17395               cost1*dc_norm(j,i-2))/ &
17396               vbld(i-1)
17397               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17398               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17399               +cost1*(dc_norm(j,i-1+nres)))/ &
17400               vbld(i-1+nres)
17401               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17402       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17403       !C Looks messy but better than if in loop
17404               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17405               +cost2*dc_norm(j,i-1))/ &
17406               vbld(i)
17407               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17408               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17409                +cost2*(-dc_norm(j,i-1+nres)))/ &
17410               vbld(i-1+nres)
17411       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17412               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17413             enddo
17414              endif
17415             enddo
17416       !elwrite(iout,*) "after vbld write"
17417       ! Derivatives of phi:
17418       ! If phi is 0 or 180 degrees, then the formulas
17419       ! have to be derived by power series expansion of the
17420       ! conventional formulas around 0 and 180.
17421 #ifdef PARINTDER
17422             do i=iphi1_start,iphi1_end
17423 #else
17424             do i=4,nres
17425 #endif
17426       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17427       ! the conventional case
17428             sint=dsin(theta(i))
17429             sint1=dsin(theta(i-1))
17430             sing=dsin(phi(i))
17431             cost=dcos(theta(i))
17432             cost1=dcos(theta(i-1))
17433             cosg=dcos(phi(i))
17434             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17435             fac0=1.0d0/(sint1*sint)
17436             fac1=cost*fac0
17437             fac2=cost1*fac0
17438             fac3=cosg*cost1/(sint1*sint1)
17439             fac4=cosg*cost/(sint*sint)
17440       !    Obtaining the gamma derivatives from sine derivative
17441              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17442                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17443                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17444              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17445              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17446              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17447              do j=1,3
17448                 ctgt=cost/sint
17449                 ctgt1=cost1/sint1
17450                 cosg_inv=1.0d0/cosg
17451                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17452                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17453                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17454                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17455                 dsinphi(j,2,i)= &
17456                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17457                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17458                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17459                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17460                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17461       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17462                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17463                 endif
17464       ! Bug fixed 3/24/05 (AL)
17465              enddo
17466       !   Obtaining the gamma derivatives from cosine derivative
17467             else
17468                do j=1,3
17469                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17470                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17471                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17472                dc_norm(j,i-3))/vbld(i-2)
17473                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17474                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17475                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17476                dcostheta(j,1,i)
17477                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17478                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17479                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17480                dc_norm(j,i-1))/vbld(i)
17481                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17482 !#define DEBUG
17483 #ifdef DEBUG
17484                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17485 #endif
17486 !#undef DEBUG
17487                endif
17488              enddo
17489             endif
17490             enddo
17491       !alculate derivative of Tauangle
17492 #ifdef PARINTDER
17493             do i=itau_start,itau_end
17494 #else
17495             do i=3,nres
17496       !elwrite(iout,*) " vecpr",i,nres
17497 #endif
17498              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17499       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17500       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17501       !c dtauangle(j,intertyp,dervityp,residue number)
17502       !c INTERTYP=1 SC...Ca...Ca..Ca
17503       ! the conventional case
17504             sint=dsin(theta(i))
17505             sint1=dsin(omicron(2,i-1))
17506             sing=dsin(tauangle(1,i))
17507             cost=dcos(theta(i))
17508             cost1=dcos(omicron(2,i-1))
17509             cosg=dcos(tauangle(1,i))
17510       !elwrite(iout,*) " vecpr5",i,nres
17511             do j=1,3
17512       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17513       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17514             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17515       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17516             enddo
17517             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17518             fac0=1.0d0/(sint1*sint)
17519             fac1=cost*fac0
17520             fac2=cost1*fac0
17521             fac3=cosg*cost1/(sint1*sint1)
17522             fac4=cosg*cost/(sint*sint)
17523       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17524       !    Obtaining the gamma derivatives from sine derivative
17525              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17526                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17527                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17528              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17529              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17530              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17531             do j=1,3
17532                 ctgt=cost/sint
17533                 ctgt1=cost1/sint1
17534                 cosg_inv=1.0d0/cosg
17535                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17536              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17537              *vbld_inv(i-2+nres)
17538                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17539                 dsintau(j,1,2,i)= &
17540                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17541                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17542       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17543                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17544       ! Bug fixed 3/24/05 (AL)
17545                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17546                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17547       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17548                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17549              enddo
17550       !   Obtaining the gamma derivatives from cosine derivative
17551             else
17552                do j=1,3
17553                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17554                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17555                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17556                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17557                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17558                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17559                dcostheta(j,1,i)
17560                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17561                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17562                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17563                dc_norm(j,i-1))/vbld(i)
17564                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17565       !         write (iout,*) "else",i
17566              enddo
17567             endif
17568       !        do k=1,3
17569       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17570       !        enddo
17571             enddo
17572       !C Second case Ca...Ca...Ca...SC
17573 #ifdef PARINTDER
17574             do i=itau_start,itau_end
17575 #else
17576             do i=4,nres
17577 #endif
17578              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17579               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17580       ! the conventional case
17581             sint=dsin(omicron(1,i))
17582             sint1=dsin(theta(i-1))
17583             sing=dsin(tauangle(2,i))
17584             cost=dcos(omicron(1,i))
17585             cost1=dcos(theta(i-1))
17586             cosg=dcos(tauangle(2,i))
17587       !        do j=1,3
17588       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17589       !        enddo
17590             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17591             fac0=1.0d0/(sint1*sint)
17592             fac1=cost*fac0
17593             fac2=cost1*fac0
17594             fac3=cosg*cost1/(sint1*sint1)
17595             fac4=cosg*cost/(sint*sint)
17596       !    Obtaining the gamma derivatives from sine derivative
17597              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17598                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17599                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17600              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17601              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17602              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17603             do j=1,3
17604                 ctgt=cost/sint
17605                 ctgt1=cost1/sint1
17606                 cosg_inv=1.0d0/cosg
17607                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17608                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17609       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17610       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17611                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17612                 dsintau(j,2,2,i)= &
17613                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17614                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17615       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17616       !     & sing*ctgt*domicron(j,1,2,i),
17617       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17618                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17619       ! Bug fixed 3/24/05 (AL)
17620                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17621                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17622       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17623                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17624              enddo
17625       !   Obtaining the gamma derivatives from cosine derivative
17626             else
17627                do j=1,3
17628                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17629                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17630                dc_norm(j,i-3))/vbld(i-2)
17631                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17632                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17633                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17634                dcosomicron(j,1,1,i)
17635                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17636                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17637                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17638                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17639                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17640       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17641              enddo
17642             endif
17643             enddo
17644
17645       !CC third case SC...Ca...Ca...SC
17646 #ifdef PARINTDER
17647
17648             do i=itau_start,itau_end
17649 #else
17650             do i=3,nres
17651 #endif
17652       ! the conventional case
17653             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17654             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17655             sint=dsin(omicron(1,i))
17656             sint1=dsin(omicron(2,i-1))
17657             sing=dsin(tauangle(3,i))
17658             cost=dcos(omicron(1,i))
17659             cost1=dcos(omicron(2,i-1))
17660             cosg=dcos(tauangle(3,i))
17661             do j=1,3
17662             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17663       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17664             enddo
17665             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17666             fac0=1.0d0/(sint1*sint)
17667             fac1=cost*fac0
17668             fac2=cost1*fac0
17669             fac3=cosg*cost1/(sint1*sint1)
17670             fac4=cosg*cost/(sint*sint)
17671       !    Obtaining the gamma derivatives from sine derivative
17672              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17673                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17674                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17675              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17676              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17677              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17678             do j=1,3
17679                 ctgt=cost/sint
17680                 ctgt1=cost1/sint1
17681                 cosg_inv=1.0d0/cosg
17682                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17683                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17684                   *vbld_inv(i-2+nres)
17685                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17686                 dsintau(j,3,2,i)= &
17687                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17688                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17689                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17690       ! Bug fixed 3/24/05 (AL)
17691                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17692                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17693                   *vbld_inv(i-1+nres)
17694       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17695                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17696              enddo
17697       !   Obtaining the gamma derivatives from cosine derivative
17698             else
17699                do j=1,3
17700                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17701                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17702                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17703                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17704                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17705                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17706                dcosomicron(j,1,1,i)
17707                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17708                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17709                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17710                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17711                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17712       !          write(iout,*) "else",i
17713              enddo
17714             endif
17715             enddo
17716
17717 #ifdef CRYST_SC
17718       !   Derivatives of side-chain angles alpha and omega
17719 #if defined(MPI) && defined(PARINTDER)
17720             do i=ibond_start,ibond_end
17721 #else
17722             do i=2,nres-1
17723 #endif
17724               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17725                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17726                  fac6=fac5/vbld(i)
17727                  fac7=fac5*fac5
17728                  fac8=fac5/vbld(i+1)
17729                  fac9=fac5/vbld(i+nres)
17730                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17731                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17732                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17733                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17734                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17735                  sina=sqrt(1-cosa*cosa)
17736                  sino=dsin(omeg(i))
17737       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17738                  do j=1,3
17739                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17740                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17741                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17742                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17743                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17744                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17745                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17746                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17747                   vbld(i+nres))
17748                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17749                 enddo
17750       ! obtaining the derivatives of omega from sines
17751                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17752                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17753                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17754                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17755                    dsin(theta(i+1)))
17756                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17757                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17758                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17759                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17760                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17761                    coso_inv=1.0d0/dcos(omeg(i))
17762                    do j=1,3
17763                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17764                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17765                    (sino*dc_norm(j,i-1))/vbld(i)
17766                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17767                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17768                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17769                    -sino*dc_norm(j,i)/vbld(i+1)
17770                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17771                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17772                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17773                    vbld(i+nres)
17774                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17775                   enddo
17776                else
17777       !   obtaining the derivatives of omega from cosines
17778                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17779                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17780                  fac12=fac10*sina
17781                  fac13=fac12*fac12
17782                  fac14=sina*sina
17783                  do j=1,3
17784                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17785                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17786                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17787                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17788                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17789                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17790                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17791                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17792                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17793                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17794                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17795                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17796                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17797                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17798                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17799                 enddo
17800               endif
17801              else
17802                do j=1,3
17803                  do k=1,3
17804                    dalpha(k,j,i)=0.0d0
17805                    domega(k,j,i)=0.0d0
17806                  enddo
17807                enddo
17808              endif
17809              enddo
17810 #endif
17811 #if defined(MPI) && defined(PARINTDER)
17812             if (nfgtasks.gt.1) then
17813 #ifdef DEBUG
17814       !d      write (iout,*) "Gather dtheta"
17815       !d      call flush(iout)
17816             write (iout,*) "dtheta before gather"
17817             do i=1,nres
17818             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17819             enddo
17820 #endif
17821             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17822             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17823             king,FG_COMM,IERROR)
17824 !#define DEBUG
17825 #ifdef DEBUG
17826       !d      write (iout,*) "Gather dphi"
17827       !d      call flush(iout)
17828             write (iout,*) "dphi before gather"
17829             do i=1,nres
17830             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17831             enddo
17832 #endif
17833 !#undef DEBUG
17834             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17835             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17836             king,FG_COMM,IERROR)
17837       !d      write (iout,*) "Gather dalpha"
17838       !d      call flush(iout)
17839 #ifdef CRYST_SC
17840             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17841             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17842             king,FG_COMM,IERROR)
17843       !d      write (iout,*) "Gather domega"
17844       !d      call flush(iout)
17845             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17846             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17847             king,FG_COMM,IERROR)
17848 #endif
17849             endif
17850 #endif
17851 !#define DEBUG
17852 #ifdef DEBUG
17853             write (iout,*) "dtheta after gather"
17854             do i=1,nres
17855             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17856             enddo
17857             write (iout,*) "dphi after gather"
17858             do i=1,nres
17859             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17860             enddo
17861             write (iout,*) "dalpha after gather"
17862             do i=1,nres
17863             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17864             enddo
17865             write (iout,*) "domega after gather"
17866             do i=1,nres
17867             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17868             enddo
17869 #endif
17870 !#undef DEBUG
17871             return
17872             end subroutine intcartderiv
17873       !-----------------------------------------------------------------------------
17874             subroutine checkintcartgrad
17875       !      implicit real*8 (a-h,o-z)
17876       !      include 'DIMENSIONS'
17877 #ifdef MPI
17878             include 'mpif.h'
17879 #endif
17880       !      include 'COMMON.CHAIN'
17881       !      include 'COMMON.VAR'
17882       !      include 'COMMON.GEO'
17883       !      include 'COMMON.INTERACT'
17884       !      include 'COMMON.DERIV'
17885       !      include 'COMMON.IOUNITS'
17886       !      include 'COMMON.SETUP'
17887             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17888             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17889             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17890             real(kind=8),dimension(3) :: dc_norm_s
17891             real(kind=8) :: aincr=1.0d-5
17892             integer :: i,j
17893             real(kind=8) :: dcji
17894             do i=1,nres
17895             phi_s(i)=phi(i)
17896             theta_s(i)=theta(i)
17897             alph_s(i)=alph(i)
17898             omeg_s(i)=omeg(i)
17899             enddo
17900       ! Check theta gradient
17901             write (iout,*) &
17902              "Analytical (upper) and numerical (lower) gradient of theta"
17903             write (iout,*)
17904             do i=3,nres
17905             do j=1,3
17906               dcji=dc(j,i-2)
17907               dc(j,i-2)=dcji+aincr
17908               call chainbuild_cart
17909               call int_from_cart1(.false.)
17910           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17911           dc(j,i-2)=dcji
17912           dcji=dc(j,i-1)
17913           dc(j,i-1)=dc(j,i-1)+aincr
17914           call chainbuild_cart
17915           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17916           dc(j,i-1)=dcji
17917         enddo
17918 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17919 !el          (dtheta(j,2,i),j=1,3)
17920 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17921 !el          (dthetanum(j,2,i),j=1,3)
17922 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17923 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17924 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17925 !el        write (iout,*)
17926       enddo
17927 ! Check gamma gradient
17928       write (iout,*) &
17929        "Analytical (upper) and numerical (lower) gradient of gamma"
17930       do i=4,nres
17931         do j=1,3
17932           dcji=dc(j,i-3)
17933           dc(j,i-3)=dcji+aincr
17934           call chainbuild_cart
17935           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17936               dc(j,i-3)=dcji
17937           dcji=dc(j,i-2)
17938           dc(j,i-2)=dcji+aincr
17939           call chainbuild_cart
17940           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17941           dc(j,i-2)=dcji
17942           dcji=dc(j,i-1)
17943           dc(j,i-1)=dc(j,i-1)+aincr
17944           call chainbuild_cart
17945           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17946           dc(j,i-1)=dcji
17947         enddo
17948 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17949 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17950 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17951 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17952 !el        write (iout,'(5x,3(3f10.5,5x))') &
17953 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17954 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17955 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17956 !el        write (iout,*)
17957       enddo
17958 ! Check alpha gradient
17959       write (iout,*) &
17960        "Analytical (upper) and numerical (lower) gradient of alpha"
17961       do i=2,nres-1
17962        if(itype(i,1).ne.10) then
17963                  do j=1,3
17964                   dcji=dc(j,i-1)
17965                    dc(j,i-1)=dcji+aincr
17966               call chainbuild_cart
17967               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17968                  /aincr
17969                   dc(j,i-1)=dcji
17970               dcji=dc(j,i)
17971               dc(j,i)=dcji+aincr
17972               call chainbuild_cart
17973               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17974                  /aincr
17975               dc(j,i)=dcji
17976               dcji=dc(j,i+nres)
17977               dc(j,i+nres)=dc(j,i+nres)+aincr
17978               call chainbuild_cart
17979               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17980                  /aincr
17981              dc(j,i+nres)=dcji
17982             enddo
17983           endif
17984 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17985 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17986 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17987 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17988 !el        write (iout,'(5x,3(3f10.5,5x))') &
17989 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17990 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17991 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17992 !el        write (iout,*)
17993       enddo
17994 !     Check omega gradient
17995       write (iout,*) &
17996        "Analytical (upper) and numerical (lower) gradient of omega"
17997       do i=2,nres-1
17998        if(itype(i,1).ne.10) then
17999                  do j=1,3
18000                   dcji=dc(j,i-1)
18001                    dc(j,i-1)=dcji+aincr
18002               call chainbuild_cart
18003               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18004                  /aincr
18005                   dc(j,i-1)=dcji
18006               dcji=dc(j,i)
18007               dc(j,i)=dcji+aincr
18008               call chainbuild_cart
18009               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18010                  /aincr
18011               dc(j,i)=dcji
18012               dcji=dc(j,i+nres)
18013               dc(j,i+nres)=dc(j,i+nres)+aincr
18014               call chainbuild_cart
18015               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18016                  /aincr
18017              dc(j,i+nres)=dcji
18018             enddo
18019           endif
18020 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18021 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18022 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18023 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18024 !el        write (iout,'(5x,3(3f10.5,5x))') &
18025 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18026 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18027 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18028 !el        write (iout,*)
18029       enddo
18030       return
18031       end subroutine checkintcartgrad
18032 !-----------------------------------------------------------------------------
18033 ! q_measure.F
18034 !-----------------------------------------------------------------------------
18035       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18036 !      implicit real*8 (a-h,o-z)
18037 !      include 'DIMENSIONS'
18038 !      include 'COMMON.IOUNITS'
18039 !      include 'COMMON.CHAIN'
18040 !      include 'COMMON.INTERACT'
18041 !      include 'COMMON.VAR'
18042       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18043       integer :: kkk,nsep=3
18044       real(kind=8) :: qm      !dist,
18045       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18046       logical :: lprn=.false.
18047       logical :: flag
18048 !      real(kind=8) :: sigm,x
18049
18050 !el      sigm(x)=0.25d0*x     ! local function
18051       qqmax=1.0d10
18052       do kkk=1,nperm
18053       qq = 0.0d0
18054       nl=0
18055        if(flag) then
18056         do il=seg1+nsep,seg2
18057           do jl=seg1,il-nsep
18058             nl=nl+1
18059             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18060                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18061                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18062             dij=dist(il,jl)
18063             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18064             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18065               nl=nl+1
18066               d0ijCM=dsqrt( &
18067                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18068                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18069                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18070               dijCM=dist(il+nres,jl+nres)
18071               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18072             endif
18073             qq = qq+qqij+qqijCM
18074           enddo
18075         enddo
18076         qq = qq/nl
18077       else
18078       do il=seg1,seg2
18079         if((seg3-il).lt.3) then
18080              secseg=il+3
18081         else
18082              secseg=seg3
18083         endif
18084           do jl=secseg,seg4
18085             nl=nl+1
18086             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18087                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18088                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18089             dij=dist(il,jl)
18090             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18091             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18092               nl=nl+1
18093               d0ijCM=dsqrt( &
18094                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18095                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18096                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18097               dijCM=dist(il+nres,jl+nres)
18098               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18099             endif
18100             qq = qq+qqij+qqijCM
18101           enddo
18102         enddo
18103       qq = qq/nl
18104       endif
18105       if (qqmax.le.qq) qqmax=qq
18106       enddo
18107       qwolynes=1.0d0-qqmax
18108       return
18109       end function qwolynes
18110 !-----------------------------------------------------------------------------
18111       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18112 !      implicit real*8 (a-h,o-z)
18113 !      include 'DIMENSIONS'
18114 !      include 'COMMON.IOUNITS'
18115 !      include 'COMMON.CHAIN'
18116 !      include 'COMMON.INTERACT'
18117 !      include 'COMMON.VAR'
18118 !      include 'COMMON.MD'
18119       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18120       integer :: nsep=3, kkk
18121 !el      real(kind=8) :: dist
18122       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18123       logical :: lprn=.false.
18124       logical :: flag
18125       real(kind=8) :: sim,dd0,fac,ddqij
18126 !el      sigm(x)=0.25d0*x           ! local function
18127       do kkk=1,nperm
18128       do i=0,nres
18129         do j=1,3
18130           dqwol(j,i)=0.0d0
18131           dxqwol(j,i)=0.0d0
18132         enddo
18133       enddo
18134       nl=0
18135        if(flag) then
18136         do il=seg1+nsep,seg2
18137           do jl=seg1,il-nsep
18138             nl=nl+1
18139             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18140                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18141                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18142             dij=dist(il,jl)
18143             sim = 1.0d0/sigm(d0ij)
18144             sim = sim*sim
18145             dd0 = dij-d0ij
18146             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18147           do k=1,3
18148               ddqij = (c(k,il)-c(k,jl))*fac
18149               dqwol(k,il)=dqwol(k,il)+ddqij
18150               dqwol(k,jl)=dqwol(k,jl)-ddqij
18151             enddo
18152
18153             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18154               nl=nl+1
18155               d0ijCM=dsqrt( &
18156                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18157                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18158                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18159               dijCM=dist(il+nres,jl+nres)
18160               sim = 1.0d0/sigm(d0ijCM)
18161               sim = sim*sim
18162               dd0=dijCM-d0ijCM
18163               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18164               do k=1,3
18165                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18166                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18167                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18168               enddo
18169             endif
18170           enddo
18171         enddo
18172        else
18173         do il=seg1,seg2
18174         if((seg3-il).lt.3) then
18175              secseg=il+3
18176         else
18177              secseg=seg3
18178         endif
18179           do jl=secseg,seg4
18180             nl=nl+1
18181             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18182                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18183                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18184             dij=dist(il,jl)
18185             sim = 1.0d0/sigm(d0ij)
18186             sim = sim*sim
18187             dd0 = dij-d0ij
18188             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18189             do k=1,3
18190               ddqij = (c(k,il)-c(k,jl))*fac
18191               dqwol(k,il)=dqwol(k,il)+ddqij
18192               dqwol(k,jl)=dqwol(k,jl)-ddqij
18193             enddo
18194             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18195               nl=nl+1
18196               d0ijCM=dsqrt( &
18197                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18198                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18199                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18200               dijCM=dist(il+nres,jl+nres)
18201               sim = 1.0d0/sigm(d0ijCM)
18202               sim=sim*sim
18203               dd0 = dijCM-d0ijCM
18204               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18205               do k=1,3
18206                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18207                dxqwol(k,il)=dxqwol(k,il)+ddqij
18208                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18209               enddo
18210             endif
18211           enddo
18212         enddo
18213       endif
18214       enddo
18215        do i=0,nres
18216          do j=1,3
18217            dqwol(j,i)=dqwol(j,i)/nl
18218            dxqwol(j,i)=dxqwol(j,i)/nl
18219          enddo
18220        enddo
18221       return
18222       end subroutine qwolynes_prim
18223 !-----------------------------------------------------------------------------
18224       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18225 !      implicit real*8 (a-h,o-z)
18226 !      include 'DIMENSIONS'
18227 !      include 'COMMON.IOUNITS'
18228 !      include 'COMMON.CHAIN'
18229 !      include 'COMMON.INTERACT'
18230 !      include 'COMMON.VAR'
18231       integer :: seg1,seg2,seg3,seg4
18232       logical :: flag
18233       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18234       real(kind=8),dimension(3,0:2*nres) :: cdummy
18235       real(kind=8) :: q1,q2
18236       real(kind=8) :: delta=1.0d-10
18237       integer :: i,j
18238
18239       do i=0,nres
18240         do j=1,3
18241           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18242           cdummy(j,i)=c(j,i)
18243           c(j,i)=c(j,i)+delta
18244           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18245           qwolan(j,i)=(q2-q1)/delta
18246           c(j,i)=cdummy(j,i)
18247         enddo
18248       enddo
18249       do i=0,nres
18250         do j=1,3
18251           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18252           cdummy(j,i+nres)=c(j,i+nres)
18253           c(j,i+nres)=c(j,i+nres)+delta
18254           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18255           qwolxan(j,i)=(q2-q1)/delta
18256           c(j,i+nres)=cdummy(j,i+nres)
18257         enddo
18258       enddo
18259 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18260 !      do i=0,nct
18261 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18262 !      enddo
18263 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18264 !      do i=0,nct
18265 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18266 !      enddo
18267       return
18268       end subroutine qwol_num
18269 !-----------------------------------------------------------------------------
18270       subroutine EconstrQ
18271 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18272 !      implicit real*8 (a-h,o-z)
18273 !      include 'DIMENSIONS'
18274 !      include 'COMMON.CONTROL'
18275 !      include 'COMMON.VAR'
18276 !      include 'COMMON.MD'
18277       use MD_data
18278 !#ifndef LANG0
18279 !      include 'COMMON.LANGEVIN'
18280 !#else
18281 !      include 'COMMON.LANGEVIN.lang0'
18282 !#endif
18283 !      include 'COMMON.CHAIN'
18284 !      include 'COMMON.DERIV'
18285 !      include 'COMMON.GEO'
18286 !      include 'COMMON.LOCAL'
18287 !      include 'COMMON.INTERACT'
18288 !      include 'COMMON.IOUNITS'
18289 !      include 'COMMON.NAMES'
18290 !      include 'COMMON.TIME1'
18291       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18292       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18293                    duconst,duxconst
18294       integer :: kstart,kend,lstart,lend,idummy
18295       real(kind=8) :: delta=1.0d-7
18296       integer :: i,j,k,ii
18297       do i=0,nres
18298          do j=1,3
18299             duconst(j,i)=0.0d0
18300             dudconst(j,i)=0.0d0
18301             duxconst(j,i)=0.0d0
18302             dudxconst(j,i)=0.0d0
18303          enddo
18304       enddo
18305       Uconst=0.0d0
18306       do i=1,nfrag
18307          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18308            idummy,idummy)
18309          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18310 ! Calculating the derivatives of Constraint energy with respect to Q
18311          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18312            qinfrag(i,iset))
18313 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18314 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18315 !         hmnum=(hm2-hm1)/delta
18316 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18317 !     &   qinfrag(i,iset))
18318 !         write(iout,*) "harmonicnum frag", hmnum
18319 ! Calculating the derivatives of Q with respect to cartesian coordinates
18320          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18321           idummy,idummy)
18322 !         write(iout,*) "dqwol "
18323 !         do ii=1,nres
18324 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18325 !         enddo
18326 !         write(iout,*) "dxqwol "
18327 !         do ii=1,nres
18328 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18329 !         enddo
18330 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18331 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18332 !     &  ,idummy,idummy)
18333 !  The gradients of Uconst in Cs
18334          do ii=0,nres
18335             do j=1,3
18336                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18337                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18338             enddo
18339          enddo
18340       enddo
18341       do i=1,npair
18342          kstart=ifrag(1,ipair(1,i,iset),iset)
18343          kend=ifrag(2,ipair(1,i,iset),iset)
18344          lstart=ifrag(1,ipair(2,i,iset),iset)
18345          lend=ifrag(2,ipair(2,i,iset),iset)
18346          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18347          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18348 !  Calculating dU/dQ
18349          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18350 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18351 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18352 !         hmnum=(hm2-hm1)/delta
18353 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18354 !     &   qinpair(i,iset))
18355 !         write(iout,*) "harmonicnum pair ", hmnum
18356 ! Calculating dQ/dXi
18357          call qwolynes_prim(kstart,kend,.false.,&
18358           lstart,lend)
18359 !         write(iout,*) "dqwol "
18360 !         do ii=1,nres
18361 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18362 !         enddo
18363 !         write(iout,*) "dxqwol "
18364 !         do ii=1,nres
18365 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18366 !        enddo
18367 ! Calculating numerical gradients
18368 !        call qwol_num(kstart,kend,.false.
18369 !     &  ,lstart,lend)
18370 ! The gradients of Uconst in Cs
18371          do ii=0,nres
18372             do j=1,3
18373                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18374                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18375             enddo
18376          enddo
18377       enddo
18378 !      write(iout,*) "Uconst inside subroutine ", Uconst
18379 ! Transforming the gradients from Cs to dCs for the backbone
18380       do i=0,nres
18381          do j=i+1,nres
18382            do k=1,3
18383              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18384            enddo
18385          enddo
18386       enddo
18387 !  Transforming the gradients from Cs to dCs for the side chains
18388       do i=1,nres
18389          do j=1,3
18390            dudxconst(j,i)=duxconst(j,i)
18391          enddo
18392       enddo
18393 !      write(iout,*) "dU/ddc backbone "
18394 !       do ii=0,nres
18395 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18396 !      enddo
18397 !      write(iout,*) "dU/ddX side chain "
18398 !      do ii=1,nres
18399 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18400 !      enddo
18401 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18402 !      call dEconstrQ_num
18403       return
18404       end subroutine EconstrQ
18405 !-----------------------------------------------------------------------------
18406       subroutine dEconstrQ_num
18407 ! Calculating numerical dUconst/ddc and dUconst/ddx
18408 !      implicit real*8 (a-h,o-z)
18409 !      include 'DIMENSIONS'
18410 !      include 'COMMON.CONTROL'
18411 !      include 'COMMON.VAR'
18412 !      include 'COMMON.MD'
18413       use MD_data
18414 !#ifndef LANG0
18415 !      include 'COMMON.LANGEVIN'
18416 !#else
18417 !      include 'COMMON.LANGEVIN.lang0'
18418 !#endif
18419 !      include 'COMMON.CHAIN'
18420 !      include 'COMMON.DERIV'
18421 !      include 'COMMON.GEO'
18422 !      include 'COMMON.LOCAL'
18423 !      include 'COMMON.INTERACT'
18424 !      include 'COMMON.IOUNITS'
18425 !      include 'COMMON.NAMES'
18426 !      include 'COMMON.TIME1'
18427       real(kind=8) :: uzap1,uzap2
18428       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18429       integer :: kstart,kend,lstart,lend,idummy
18430       real(kind=8) :: delta=1.0d-7
18431 !el local variables
18432       integer :: i,ii,j
18433 !     real(kind=8) ::
18434 !     For the backbone
18435       do i=0,nres-1
18436          do j=1,3
18437             dUcartan(j,i)=0.0d0
18438             cdummy(j,i)=dc(j,i)
18439             dc(j,i)=dc(j,i)+delta
18440             call chainbuild_cart
18441           uzap2=0.0d0
18442             do ii=1,nfrag
18443              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18444                 idummy,idummy)
18445                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18446                 qinfrag(ii,iset))
18447             enddo
18448             do ii=1,npair
18449                kstart=ifrag(1,ipair(1,ii,iset),iset)
18450                kend=ifrag(2,ipair(1,ii,iset),iset)
18451                lstart=ifrag(1,ipair(2,ii,iset),iset)
18452                lend=ifrag(2,ipair(2,ii,iset),iset)
18453                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18454                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18455                  qinpair(ii,iset))
18456             enddo
18457             dc(j,i)=cdummy(j,i)
18458             call chainbuild_cart
18459             uzap1=0.0d0
18460              do ii=1,nfrag
18461              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18462                 idummy,idummy)
18463                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18464                 qinfrag(ii,iset))
18465             enddo
18466             do ii=1,npair
18467                kstart=ifrag(1,ipair(1,ii,iset),iset)
18468                kend=ifrag(2,ipair(1,ii,iset),iset)
18469                lstart=ifrag(1,ipair(2,ii,iset),iset)
18470                lend=ifrag(2,ipair(2,ii,iset),iset)
18471                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18472                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18473                 qinpair(ii,iset))
18474             enddo
18475             ducartan(j,i)=(uzap2-uzap1)/(delta)
18476          enddo
18477       enddo
18478 ! Calculating numerical gradients for dU/ddx
18479       do i=0,nres-1
18480          duxcartan(j,i)=0.0d0
18481          do j=1,3
18482             cdummy(j,i)=dc(j,i+nres)
18483             dc(j,i+nres)=dc(j,i+nres)+delta
18484             call chainbuild_cart
18485           uzap2=0.0d0
18486             do ii=1,nfrag
18487              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18488                 idummy,idummy)
18489                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18490                 qinfrag(ii,iset))
18491             enddo
18492             do ii=1,npair
18493                kstart=ifrag(1,ipair(1,ii,iset),iset)
18494                kend=ifrag(2,ipair(1,ii,iset),iset)
18495                lstart=ifrag(1,ipair(2,ii,iset),iset)
18496                lend=ifrag(2,ipair(2,ii,iset),iset)
18497                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18498                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18499                 qinpair(ii,iset))
18500             enddo
18501             dc(j,i+nres)=cdummy(j,i)
18502             call chainbuild_cart
18503             uzap1=0.0d0
18504              do ii=1,nfrag
18505                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18506                 ifrag(2,ii,iset),.true.,idummy,idummy)
18507                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18508                 qinfrag(ii,iset))
18509             enddo
18510             do ii=1,npair
18511                kstart=ifrag(1,ipair(1,ii,iset),iset)
18512                kend=ifrag(2,ipair(1,ii,iset),iset)
18513                lstart=ifrag(1,ipair(2,ii,iset),iset)
18514                lend=ifrag(2,ipair(2,ii,iset),iset)
18515                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18516                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18517                 qinpair(ii,iset))
18518             enddo
18519             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18520          enddo
18521       enddo
18522       write(iout,*) "Numerical dUconst/ddc backbone "
18523       do ii=0,nres
18524         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18525       enddo
18526 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18527 !      do ii=1,nres
18528 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18529 !      enddo
18530       return
18531       end subroutine dEconstrQ_num
18532 !-----------------------------------------------------------------------------
18533 ! ssMD.F
18534 !-----------------------------------------------------------------------------
18535       subroutine check_energies
18536
18537 !      use random, only: ran_number
18538
18539 !      implicit none
18540 !     Includes
18541 !      include 'DIMENSIONS'
18542 !      include 'COMMON.CHAIN'
18543 !      include 'COMMON.VAR'
18544 !      include 'COMMON.IOUNITS'
18545 !      include 'COMMON.SBRIDGE'
18546 !      include 'COMMON.LOCAL'
18547 !      include 'COMMON.GEO'
18548
18549 !     External functions
18550 !EL      double precision ran_number
18551 !EL      external ran_number
18552
18553 !     Local variables
18554       integer :: i,j,k,l,lmax,p,pmax
18555       real(kind=8) :: rmin,rmax
18556       real(kind=8) :: eij
18557
18558       real(kind=8) :: d
18559       real(kind=8) :: wi,rij,tj,pj
18560 !      return
18561
18562       i=5
18563       j=14
18564
18565       d=dsc(1)
18566       rmin=2.0D0
18567       rmax=12.0D0
18568
18569       lmax=10000
18570       pmax=1
18571
18572       do k=1,3
18573         c(k,i)=0.0D0
18574         c(k,j)=0.0D0
18575         c(k,nres+i)=0.0D0
18576         c(k,nres+j)=0.0D0
18577       enddo
18578
18579       do l=1,lmax
18580
18581 !t        wi=ran_number(0.0D0,pi)
18582 !        wi=ran_number(0.0D0,pi/6.0D0)
18583 !        wi=0.0D0
18584 !t        tj=ran_number(0.0D0,pi)
18585 !t        pj=ran_number(0.0D0,pi)
18586 !        pj=ran_number(0.0D0,pi/6.0D0)
18587 !        pj=0.0D0
18588
18589         do p=1,pmax
18590 !t           rij=ran_number(rmin,rmax)
18591
18592            c(1,j)=d*sin(pj)*cos(tj)
18593            c(2,j)=d*sin(pj)*sin(tj)
18594            c(3,j)=d*cos(pj)
18595
18596            c(3,nres+i)=-rij
18597
18598            c(1,i)=d*sin(wi)
18599            c(3,i)=-rij-d*cos(wi)
18600
18601            do k=1,3
18602               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18603               dc_norm(k,nres+i)=dc(k,nres+i)/d
18604               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18605               dc_norm(k,nres+j)=dc(k,nres+j)/d
18606            enddo
18607
18608            call dyn_ssbond_ene(i,j,eij)
18609         enddo
18610       enddo
18611       call exit(1)
18612       return
18613       end subroutine check_energies
18614 !-----------------------------------------------------------------------------
18615       subroutine dyn_ssbond_ene(resi,resj,eij)
18616 !      implicit none
18617 !      Includes
18618       use calc_data
18619       use comm_sschecks
18620 !      include 'DIMENSIONS'
18621 !      include 'COMMON.SBRIDGE'
18622 !      include 'COMMON.CHAIN'
18623 !      include 'COMMON.DERIV'
18624 !      include 'COMMON.LOCAL'
18625 !      include 'COMMON.INTERACT'
18626 !      include 'COMMON.VAR'
18627 !      include 'COMMON.IOUNITS'
18628 !      include 'COMMON.CALC'
18629 #ifndef CLUST
18630 #ifndef WHAM
18631        use MD_data
18632 !      include 'COMMON.MD'
18633 !      use MD, only: totT,t_bath
18634 #endif
18635 #endif
18636 !     External functions
18637 !EL      double precision h_base
18638 !EL      external h_base
18639
18640 !     Input arguments
18641       integer :: resi,resj
18642
18643 !     Output arguments
18644       real(kind=8) :: eij
18645
18646 !     Local variables
18647       logical :: havebond
18648       integer itypi,itypj
18649       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18650       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18651       real(kind=8),dimension(3) :: dcosom1,dcosom2
18652       real(kind=8) :: ed
18653       real(kind=8) :: pom1,pom2
18654       real(kind=8) :: ljA,ljB,ljXs
18655       real(kind=8),dimension(1:3) :: d_ljB
18656       real(kind=8) :: ssA,ssB,ssC,ssXs
18657       real(kind=8) :: ssxm,ljxm,ssm,ljm
18658       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18659       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18660       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18661 !-------FIRST METHOD
18662       real(kind=8) :: xm
18663       real(kind=8),dimension(1:3) :: d_xm
18664 !-------END FIRST METHOD
18665 !-------SECOND METHOD
18666 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18667 !-------END SECOND METHOD
18668
18669 !-------TESTING CODE
18670 !el      logical :: checkstop,transgrad
18671 !el      common /sschecks/ checkstop,transgrad
18672
18673       integer :: icheck,nicheck,jcheck,njcheck
18674       real(kind=8),dimension(-1:1) :: echeck
18675       real(kind=8) :: deps,ssx0,ljx0
18676 !-------END TESTING CODE
18677
18678       eij=0.0d0
18679       i=resi
18680       j=resj
18681
18682 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18683 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18684
18685       itypi=itype(i,1)
18686       dxi=dc_norm(1,nres+i)
18687       dyi=dc_norm(2,nres+i)
18688       dzi=dc_norm(3,nres+i)
18689       dsci_inv=vbld_inv(i+nres)
18690
18691       itypj=itype(j,1)
18692       xj=c(1,nres+j)-c(1,nres+i)
18693       yj=c(2,nres+j)-c(2,nres+i)
18694       zj=c(3,nres+j)-c(3,nres+i)
18695       dxj=dc_norm(1,nres+j)
18696       dyj=dc_norm(2,nres+j)
18697       dzj=dc_norm(3,nres+j)
18698       dscj_inv=vbld_inv(j+nres)
18699
18700       chi1=chi(itypi,itypj)
18701       chi2=chi(itypj,itypi)
18702       chi12=chi1*chi2
18703       chip1=chip(itypi)
18704       chip2=chip(itypj)
18705       chip12=chip1*chip2
18706       alf1=alp(itypi)
18707       alf2=alp(itypj)
18708       alf12=0.5D0*(alf1+alf2)
18709
18710       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18711       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18712 !     The following are set in sc_angular
18713 !      erij(1)=xj*rij
18714 !      erij(2)=yj*rij
18715 !      erij(3)=zj*rij
18716 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18717 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18718 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18719       call sc_angular
18720       rij=1.0D0/rij  ! Reset this so it makes sense
18721
18722       sig0ij=sigma(itypi,itypj)
18723       sig=sig0ij*dsqrt(1.0D0/sigsq)
18724
18725       ljXs=sig-sig0ij
18726       ljA=eps1*eps2rt**2*eps3rt**2
18727       ljB=ljA*bb_aq(itypi,itypj)
18728       ljA=ljA*aa_aq(itypi,itypj)
18729       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18730
18731       ssXs=d0cm
18732       deltat1=1.0d0-om1
18733       deltat2=1.0d0+om2
18734       deltat12=om2-om1+2.0d0
18735       cosphi=om12-om1*om2
18736       ssA=akcm
18737       ssB=akct*deltat12
18738       ssC=ss_depth &
18739            +akth*(deltat1*deltat1+deltat2*deltat2) &
18740            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18741       ssxm=ssXs-0.5D0*ssB/ssA
18742
18743 !-------TESTING CODE
18744 !$$$c     Some extra output
18745 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18746 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18747 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18748 !$$$      if (ssx0.gt.0.0d0) then
18749 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18750 !$$$      else
18751 !$$$        ssx0=ssxm
18752 !$$$      endif
18753 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18754 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18755 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18756 !$$$      return
18757 !-------END TESTING CODE
18758
18759 !-------TESTING CODE
18760 !     Stop and plot energy and derivative as a function of distance
18761       if (checkstop) then
18762         ssm=ssC-0.25D0*ssB*ssB/ssA
18763         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18764         if (ssm.lt.ljm .and. &
18765              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18766           nicheck=1000
18767           njcheck=1
18768           deps=0.5d-7
18769         else
18770           checkstop=.false.
18771         endif
18772       endif
18773       if (.not.checkstop) then
18774         nicheck=0
18775         njcheck=-1
18776       endif
18777
18778       do icheck=0,nicheck
18779       do jcheck=-1,njcheck
18780       if (checkstop) rij=(ssxm-1.0d0)+ &
18781              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18782 !-------END TESTING CODE
18783
18784       if (rij.gt.ljxm) then
18785         havebond=.false.
18786         ljd=rij-ljXs
18787         fac=(1.0D0/ljd)**expon
18788         e1=fac*fac*aa_aq(itypi,itypj)
18789         e2=fac*bb_aq(itypi,itypj)
18790         eij=eps1*eps2rt*eps3rt*(e1+e2)
18791         eps2der=eij*eps3rt
18792         eps3der=eij*eps2rt
18793         eij=eij*eps2rt*eps3rt
18794
18795         sigder=-sig/sigsq
18796         e1=e1*eps1*eps2rt**2*eps3rt**2
18797         ed=-expon*(e1+eij)/ljd
18798         sigder=ed*sigder
18799         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18800         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18801         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18802              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18803       else if (rij.lt.ssxm) then
18804         havebond=.true.
18805         ssd=rij-ssXs
18806         eij=ssA*ssd*ssd+ssB*ssd+ssC
18807
18808         ed=2*akcm*ssd+akct*deltat12
18809         pom1=akct*ssd
18810         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18811         eom1=-2*akth*deltat1-pom1-om2*pom2
18812         eom2= 2*akth*deltat2+pom1-om1*pom2
18813         eom12=pom2
18814       else
18815         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18816
18817         d_ssxm(1)=0.5D0*akct/ssA
18818         d_ssxm(2)=-d_ssxm(1)
18819         d_ssxm(3)=0.0D0
18820
18821         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18822         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18823         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18824         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18825
18826 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18827         xm=0.5d0*(ssxm+ljxm)
18828         do k=1,3
18829           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18830         enddo
18831         if (rij.lt.xm) then
18832           havebond=.true.
18833           ssm=ssC-0.25D0*ssB*ssB/ssA
18834           d_ssm(1)=0.5D0*akct*ssB/ssA
18835           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18836           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18837           d_ssm(3)=omega
18838           f1=(rij-xm)/(ssxm-xm)
18839           f2=(rij-ssxm)/(xm-ssxm)
18840           h1=h_base(f1,hd1)
18841           h2=h_base(f2,hd2)
18842           eij=ssm*h1+Ht*h2
18843           delta_inv=1.0d0/(xm-ssxm)
18844           deltasq_inv=delta_inv*delta_inv
18845           fac=ssm*hd1-Ht*hd2
18846           fac1=deltasq_inv*fac*(xm-rij)
18847           fac2=deltasq_inv*fac*(rij-ssxm)
18848           ed=delta_inv*(Ht*hd2-ssm*hd1)
18849           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18850           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18851           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18852         else
18853           havebond=.false.
18854           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18855           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18856           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18857           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18858                alf12/eps3rt)
18859           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18860           f1=(rij-ljxm)/(xm-ljxm)
18861           f2=(rij-xm)/(ljxm-xm)
18862           h1=h_base(f1,hd1)
18863           h2=h_base(f2,hd2)
18864           eij=Ht*h1+ljm*h2
18865           delta_inv=1.0d0/(ljxm-xm)
18866           deltasq_inv=delta_inv*delta_inv
18867           fac=Ht*hd1-ljm*hd2
18868           fac1=deltasq_inv*fac*(ljxm-rij)
18869           fac2=deltasq_inv*fac*(rij-xm)
18870           ed=delta_inv*(ljm*hd2-Ht*hd1)
18871           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18872           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18873           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18874         endif
18875 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18876
18877 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18878 !$$$        ssd=rij-ssXs
18879 !$$$        ljd=rij-ljXs
18880 !$$$        fac1=rij-ljxm
18881 !$$$        fac2=rij-ssxm
18882 !$$$
18883 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18884 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18885 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18886 !$$$
18887 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18888 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18889 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18890 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18891 !$$$        d_ssm(3)=omega
18892 !$$$
18893 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18894 !$$$        do k=1,3
18895 !$$$          d_ljm(k)=ljm*d_ljB(k)
18896 !$$$        enddo
18897 !$$$        ljm=ljm*ljB
18898 !$$$
18899 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18900 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18901 !$$$        d_ss(2)=akct*ssd
18902 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18903 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18904 !$$$        d_ss(3)=omega
18905 !$$$
18906 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18907 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18908 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18909 !$$$        do k=1,3
18910 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18911 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18912 !$$$        enddo
18913 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18914 !$$$
18915 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18916 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18917 !$$$        h1=h_base(f1,hd1)
18918 !$$$        h2=h_base(f2,hd2)
18919 !$$$        eij=ss*h1+ljf*h2
18920 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18921 !$$$        deltasq_inv=delta_inv*delta_inv
18922 !$$$        fac=ljf*hd2-ss*hd1
18923 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18924 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18925 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18926 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18927 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18928 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18929 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18930 !$$$
18931 !$$$        havebond=.false.
18932 !$$$        if (ed.gt.0.0d0) havebond=.true.
18933 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18934
18935       endif
18936
18937       if (havebond) then
18938 !#ifndef CLUST
18939 !#ifndef WHAM
18940 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18941 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18942 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18943 !        endif
18944 !#endif
18945 !#endif
18946         dyn_ssbond_ij(i,j)=eij
18947       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18948         dyn_ssbond_ij(i,j)=1.0d300
18949 !#ifndef CLUST
18950 !#ifndef WHAM
18951 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18952 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18953 !#endif
18954 !#endif
18955       endif
18956
18957 !-------TESTING CODE
18958 !el      if (checkstop) then
18959         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18960              "CHECKSTOP",rij,eij,ed
18961         echeck(jcheck)=eij
18962 !el      endif
18963       enddo
18964       if (checkstop) then
18965         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18966       endif
18967       enddo
18968       if (checkstop) then
18969         transgrad=.true.
18970         checkstop=.false.
18971       endif
18972 !-------END TESTING CODE
18973
18974       do k=1,3
18975         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18976         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18977       enddo
18978       do k=1,3
18979         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18980       enddo
18981       do k=1,3
18982         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18983              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18984              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18985         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18986              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18987              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18988       enddo
18989 !grad      do k=i,j-1
18990 !grad        do l=1,3
18991 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18992 !grad        enddo
18993 !grad      enddo
18994
18995       do l=1,3
18996         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18997         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18998       enddo
18999
19000       return
19001       end subroutine dyn_ssbond_ene
19002 !--------------------------------------------------------------------------
19003          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19004 !      implicit none
19005 !      Includes
19006       use calc_data
19007       use comm_sschecks
19008 !      include 'DIMENSIONS'
19009 !      include 'COMMON.SBRIDGE'
19010 !      include 'COMMON.CHAIN'
19011 !      include 'COMMON.DERIV'
19012 !      include 'COMMON.LOCAL'
19013 !      include 'COMMON.INTERACT'
19014 !      include 'COMMON.VAR'
19015 !      include 'COMMON.IOUNITS'
19016 !      include 'COMMON.CALC'
19017 #ifndef CLUST
19018 #ifndef WHAM
19019        use MD_data
19020 !      include 'COMMON.MD'
19021 !      use MD, only: totT,t_bath
19022 #endif
19023 #endif
19024       double precision h_base
19025       external h_base
19026
19027 !c     Input arguments
19028       integer resi,resj,resk,m,itypi,itypj,itypk
19029
19030 !c     Output arguments
19031       double precision eij,eij1,eij2,eij3
19032
19033 !c     Local variables
19034       logical havebond
19035 !c      integer itypi,itypj,k,l
19036       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19037       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19038       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19039       double precision sig0ij,ljd,sig,fac,e1,e2
19040       double precision dcosom1(3),dcosom2(3),ed
19041       double precision pom1,pom2
19042       double precision ljA,ljB,ljXs
19043       double precision d_ljB(1:3)
19044       double precision ssA,ssB,ssC,ssXs
19045       double precision ssxm,ljxm,ssm,ljm
19046       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19047       eij=0.0
19048       if (dtriss.eq.0) return
19049       i=resi
19050       j=resj
19051       k=resk
19052 !C      write(iout,*) resi,resj,resk
19053       itypi=itype(i,1)
19054       dxi=dc_norm(1,nres+i)
19055       dyi=dc_norm(2,nres+i)
19056       dzi=dc_norm(3,nres+i)
19057       dsci_inv=vbld_inv(i+nres)
19058       xi=c(1,nres+i)
19059       yi=c(2,nres+i)
19060       zi=c(3,nres+i)
19061       itypj=itype(j,1)
19062       xj=c(1,nres+j)
19063       yj=c(2,nres+j)
19064       zj=c(3,nres+j)
19065
19066       dxj=dc_norm(1,nres+j)
19067       dyj=dc_norm(2,nres+j)
19068       dzj=dc_norm(3,nres+j)
19069       dscj_inv=vbld_inv(j+nres)
19070       itypk=itype(k,1)
19071       xk=c(1,nres+k)
19072       yk=c(2,nres+k)
19073       zk=c(3,nres+k)
19074
19075       dxk=dc_norm(1,nres+k)
19076       dyk=dc_norm(2,nres+k)
19077       dzk=dc_norm(3,nres+k)
19078       dscj_inv=vbld_inv(k+nres)
19079       xij=xj-xi
19080       xik=xk-xi
19081       xjk=xk-xj
19082       yij=yj-yi
19083       yik=yk-yi
19084       yjk=yk-yj
19085       zij=zj-zi
19086       zik=zk-zi
19087       zjk=zk-zj
19088       rrij=(xij*xij+yij*yij+zij*zij)
19089       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19090       rrik=(xik*xik+yik*yik+zik*zik)
19091       rik=dsqrt(rrik)
19092       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19093       rjk=dsqrt(rrjk)
19094 !C there are three combination of distances for each trisulfide bonds
19095 !C The first case the ith atom is the center
19096 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19097 !C distance y is second distance the a,b,c,d are parameters derived for
19098 !C this problem d parameter was set as a penalty currenlty set to 1.
19099       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19100       eij1=0.0d0
19101       else
19102       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19103       endif
19104 !C second case jth atom is center
19105       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19106       eij2=0.0d0
19107       else
19108       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19109       endif
19110 !C the third case kth atom is the center
19111       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19112       eij3=0.0d0
19113       else
19114       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19115       endif
19116 !C      eij2=0.0
19117 !C      eij3=0.0
19118 !C      eij1=0.0
19119       eij=eij1+eij2+eij3
19120 !C      write(iout,*)i,j,k,eij
19121 !C The energy penalty calculated now time for the gradient part
19122 !C derivative over rij
19123       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19124       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19125             gg(1)=xij*fac/rij
19126             gg(2)=yij*fac/rij
19127             gg(3)=zij*fac/rij
19128       do m=1,3
19129         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19130         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19131       enddo
19132
19133       do l=1,3
19134         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19135         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19136       enddo
19137 !C now derivative over rik
19138       fac=-eij1**2/dtriss* &
19139       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19140       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19141             gg(1)=xik*fac/rik
19142             gg(2)=yik*fac/rik
19143             gg(3)=zik*fac/rik
19144       do m=1,3
19145         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19146         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19147       enddo
19148       do l=1,3
19149         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19150         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19151       enddo
19152 !C now derivative over rjk
19153       fac=-eij2**2/dtriss* &
19154       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19155       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19156             gg(1)=xjk*fac/rjk
19157             gg(2)=yjk*fac/rjk
19158             gg(3)=zjk*fac/rjk
19159       do m=1,3
19160         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19161         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19162       enddo
19163       do l=1,3
19164         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19165         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19166       enddo
19167       return
19168       end subroutine triple_ssbond_ene
19169
19170
19171
19172 !-----------------------------------------------------------------------------
19173       real(kind=8) function h_base(x,deriv)
19174 !     A smooth function going 0->1 in range [0,1]
19175 !     It should NOT be called outside range [0,1], it will not work there.
19176       implicit none
19177
19178 !     Input arguments
19179       real(kind=8) :: x
19180
19181 !     Output arguments
19182       real(kind=8) :: deriv
19183
19184 !     Local variables
19185       real(kind=8) :: xsq
19186
19187
19188 !     Two parabolas put together.  First derivative zero at extrema
19189 !$$$      if (x.lt.0.5D0) then
19190 !$$$        h_base=2.0D0*x*x
19191 !$$$        deriv=4.0D0*x
19192 !$$$      else
19193 !$$$        deriv=1.0D0-x
19194 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19195 !$$$        deriv=4.0D0*deriv
19196 !$$$      endif
19197
19198 !     Third degree polynomial.  First derivative zero at extrema
19199       h_base=x*x*(3.0d0-2.0d0*x)
19200       deriv=6.0d0*x*(1.0d0-x)
19201
19202 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19203 !$$$      xsq=x*x
19204 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19205 !$$$      deriv=x-1.0d0
19206 !$$$      deriv=deriv*deriv
19207 !$$$      deriv=30.0d0*xsq*deriv
19208
19209       return
19210       end function h_base
19211 !-----------------------------------------------------------------------------
19212       subroutine dyn_set_nss
19213 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19214 !      implicit none
19215       use MD_data, only: totT,t_bath
19216 !     Includes
19217 !      include 'DIMENSIONS'
19218 #ifdef MPI
19219       include "mpif.h"
19220 #endif
19221 !      include 'COMMON.SBRIDGE'
19222 !      include 'COMMON.CHAIN'
19223 !      include 'COMMON.IOUNITS'
19224 !      include 'COMMON.SETUP'
19225 !      include 'COMMON.MD'
19226 !     Local variables
19227       real(kind=8) :: emin
19228       integer :: i,j,imin,ierr
19229       integer :: diff,allnss,newnss
19230       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19231                 newihpb,newjhpb
19232       logical :: found
19233       integer,dimension(0:nfgtasks) :: i_newnss
19234       integer,dimension(0:nfgtasks) :: displ
19235       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19236       integer :: g_newnss
19237
19238       allnss=0
19239       do i=1,nres-1
19240         do j=i+1,nres
19241           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19242             allnss=allnss+1
19243             allflag(allnss)=0
19244             allihpb(allnss)=i
19245             alljhpb(allnss)=j
19246           endif
19247         enddo
19248       enddo
19249
19250 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19251
19252  1    emin=1.0d300
19253       do i=1,allnss
19254         if (allflag(i).eq.0 .and. &
19255              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19256           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19257           imin=i
19258         endif
19259       enddo
19260       if (emin.lt.1.0d300) then
19261         allflag(imin)=1
19262         do i=1,allnss
19263           if (allflag(i).eq.0 .and. &
19264                (allihpb(i).eq.allihpb(imin) .or. &
19265                alljhpb(i).eq.allihpb(imin) .or. &
19266                allihpb(i).eq.alljhpb(imin) .or. &
19267                alljhpb(i).eq.alljhpb(imin))) then
19268             allflag(i)=-1
19269           endif
19270         enddo
19271         goto 1
19272       endif
19273
19274 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19275
19276       newnss=0
19277       do i=1,allnss
19278         if (allflag(i).eq.1) then
19279           newnss=newnss+1
19280           newihpb(newnss)=allihpb(i)
19281           newjhpb(newnss)=alljhpb(i)
19282         endif
19283       enddo
19284
19285 #ifdef MPI
19286       if (nfgtasks.gt.1)then
19287
19288         call MPI_Reduce(newnss,g_newnss,1,&
19289           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19290         call MPI_Gather(newnss,1,MPI_INTEGER,&
19291                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19292         displ(0)=0
19293         do i=1,nfgtasks-1,1
19294           displ(i)=i_newnss(i-1)+displ(i-1)
19295         enddo
19296         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19297                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19298                          king,FG_COMM,IERR)
19299         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19300                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19301                          king,FG_COMM,IERR)
19302         if(fg_rank.eq.0) then
19303 !         print *,'g_newnss',g_newnss
19304 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19305 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19306          newnss=g_newnss
19307          do i=1,newnss
19308           newihpb(i)=g_newihpb(i)
19309           newjhpb(i)=g_newjhpb(i)
19310          enddo
19311         endif
19312       endif
19313 #endif
19314
19315       diff=newnss-nss
19316
19317 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19318 !       print *,newnss,nss,maxdim
19319       do i=1,nss
19320         found=.false.
19321 !        print *,newnss
19322         do j=1,newnss
19323 !!          print *,j
19324           if (idssb(i).eq.newihpb(j) .and. &
19325                jdssb(i).eq.newjhpb(j)) found=.true.
19326         enddo
19327 #ifndef CLUST
19328 #ifndef WHAM
19329 !        write(iout,*) "found",found,i,j
19330         if (.not.found.and.fg_rank.eq.0) &
19331             write(iout,'(a15,f12.2,f8.1,2i5)') &
19332              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19333 #endif
19334 #endif
19335       enddo
19336
19337       do i=1,newnss
19338         found=.false.
19339         do j=1,nss
19340 !          print *,i,j
19341           if (newihpb(i).eq.idssb(j) .and. &
19342                newjhpb(i).eq.jdssb(j)) found=.true.
19343         enddo
19344 #ifndef CLUST
19345 #ifndef WHAM
19346 !        write(iout,*) "found",found,i,j
19347         if (.not.found.and.fg_rank.eq.0) &
19348             write(iout,'(a15,f12.2,f8.1,2i5)') &
19349              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19350 #endif
19351 #endif
19352       enddo
19353
19354       nss=newnss
19355       do i=1,nss
19356         idssb(i)=newihpb(i)
19357         jdssb(i)=newjhpb(i)
19358       enddo
19359
19360       return
19361       end subroutine dyn_set_nss
19362 ! Lipid transfer energy function
19363       subroutine Eliptransfer(eliptran)
19364 !C this is done by Adasko
19365 !C      print *,"wchodze"
19366 !C structure of box:
19367 !C      water
19368 !C--bordliptop-- buffore starts
19369 !C--bufliptop--- here true lipid starts
19370 !C      lipid
19371 !C--buflipbot--- lipid ends buffore starts
19372 !C--bordlipbot--buffore ends
19373       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19374       integer :: i
19375       eliptran=0.0
19376 !      print *, "I am in eliptran"
19377       do i=ilip_start,ilip_end
19378 !C       do i=1,1
19379         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19380          cycle
19381
19382         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19383         if (positi.le.0.0) positi=positi+boxzsize
19384 !C        print *,i
19385 !C first for peptide groups
19386 !c for each residue check if it is in lipid or lipid water border area
19387        if ((positi.gt.bordlipbot)  &
19388       .and.(positi.lt.bordliptop)) then
19389 !C the energy transfer exist
19390         if (positi.lt.buflipbot) then
19391 !C what fraction I am in
19392          fracinbuf=1.0d0-      &
19393              ((positi-bordlipbot)/lipbufthick)
19394 !C lipbufthick is thickenes of lipid buffore
19395          sslip=sscalelip(fracinbuf)
19396          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19397          eliptran=eliptran+sslip*pepliptran
19398          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19399          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19400 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19401
19402 !C        print *,"doing sccale for lower part"
19403 !C         print *,i,sslip,fracinbuf,ssgradlip
19404         elseif (positi.gt.bufliptop) then
19405          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19406          sslip=sscalelip(fracinbuf)
19407          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19408          eliptran=eliptran+sslip*pepliptran
19409          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19410          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19411 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19412 !C          print *, "doing sscalefor top part"
19413 !C         print *,i,sslip,fracinbuf,ssgradlip
19414         else
19415          eliptran=eliptran+pepliptran
19416 !C         print *,"I am in true lipid"
19417         endif
19418 !C       else
19419 !C       eliptran=elpitran+0.0 ! I am in water
19420        endif
19421        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19422        enddo
19423 ! here starts the side chain transfer
19424        do i=ilip_start,ilip_end
19425         if (itype(i,1).eq.ntyp1) cycle
19426         positi=(mod(c(3,i+nres),boxzsize))
19427         if (positi.le.0) positi=positi+boxzsize
19428 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19429 !c for each residue check if it is in lipid or lipid water border area
19430 !C       respos=mod(c(3,i+nres),boxzsize)
19431 !C       print *,positi,bordlipbot,buflipbot
19432        if ((positi.gt.bordlipbot) &
19433        .and.(positi.lt.bordliptop)) then
19434 !C the energy transfer exist
19435         if (positi.lt.buflipbot) then
19436          fracinbuf=1.0d0-   &
19437            ((positi-bordlipbot)/lipbufthick)
19438 !C lipbufthick is thickenes of lipid buffore
19439          sslip=sscalelip(fracinbuf)
19440          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19441          eliptran=eliptran+sslip*liptranene(itype(i,1))
19442          gliptranx(3,i)=gliptranx(3,i) &
19443       +ssgradlip*liptranene(itype(i,1))
19444          gliptranc(3,i-1)= gliptranc(3,i-1) &
19445       +ssgradlip*liptranene(itype(i,1))
19446 !C         print *,"doing sccale for lower part"
19447         elseif (positi.gt.bufliptop) then
19448          fracinbuf=1.0d0-  &
19449       ((bordliptop-positi)/lipbufthick)
19450          sslip=sscalelip(fracinbuf)
19451          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19452          eliptran=eliptran+sslip*liptranene(itype(i,1))
19453          gliptranx(3,i)=gliptranx(3,i)  &
19454        +ssgradlip*liptranene(itype(i,1))
19455          gliptranc(3,i-1)= gliptranc(3,i-1) &
19456       +ssgradlip*liptranene(itype(i,1))
19457 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19458         else
19459          eliptran=eliptran+liptranene(itype(i,1))
19460 !C         print *,"I am in true lipid"
19461         endif
19462         endif ! if in lipid or buffor
19463 !C       else
19464 !C       eliptran=elpitran+0.0 ! I am in water
19465         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19466        enddo
19467        return
19468        end  subroutine Eliptransfer
19469 !----------------------------------NANO FUNCTIONS
19470 !C-----------------------------------------------------------------------
19471 !C-----------------------------------------------------------
19472 !C This subroutine is to mimic the histone like structure but as well can be
19473 !C utilizet to nanostructures (infinit) small modification has to be used to
19474 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19475 !C gradient has to be modified at the ends
19476 !C The energy function is Kihara potential
19477 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19478 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19479 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19480 !C simple Kihara potential
19481       subroutine calctube(Etube)
19482       real(kind=8),dimension(3) :: vectube
19483       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19484        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19485        sc_aa_tube,sc_bb_tube
19486       integer :: i,j,iti
19487       Etube=0.0d0
19488       do i=itube_start,itube_end
19489         enetube(i)=0.0d0
19490         enetube(i+nres)=0.0d0
19491       enddo
19492 !C first we calculate the distance from tube center
19493 !C for UNRES
19494        do i=itube_start,itube_end
19495 !C lets ommit dummy atoms for now
19496        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19497 !C now calculate distance from center of tube and direction vectors
19498       xmin=boxxsize
19499       ymin=boxysize
19500 ! Find minimum distance in periodic box
19501         do j=-1,1
19502          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19503          vectube(1)=vectube(1)+boxxsize*j
19504          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19505          vectube(2)=vectube(2)+boxysize*j
19506          xminact=abs(vectube(1)-tubecenter(1))
19507          yminact=abs(vectube(2)-tubecenter(2))
19508            if (xmin.gt.xminact) then
19509             xmin=xminact
19510             xtemp=vectube(1)
19511            endif
19512            if (ymin.gt.yminact) then
19513              ymin=yminact
19514              ytemp=vectube(2)
19515             endif
19516          enddo
19517       vectube(1)=xtemp
19518       vectube(2)=ytemp
19519       vectube(1)=vectube(1)-tubecenter(1)
19520       vectube(2)=vectube(2)-tubecenter(2)
19521
19522 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19523 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19524
19525 !C as the tube is infinity we do not calculate the Z-vector use of Z
19526 !C as chosen axis
19527       vectube(3)=0.0d0
19528 !C now calculte the distance
19529        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19530 !C now normalize vector
19531       vectube(1)=vectube(1)/tub_r
19532       vectube(2)=vectube(2)/tub_r
19533 !C calculte rdiffrence between r and r0
19534       rdiff=tub_r-tubeR0
19535 !C and its 6 power
19536       rdiff6=rdiff**6.0d0
19537 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19538        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19539 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19540 !C       print *,rdiff,rdiff6,pep_aa_tube
19541 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19542 !C now we calculate gradient
19543        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19544             6.0d0*pep_bb_tube)/rdiff6/rdiff
19545 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19546 !C     &rdiff,fac
19547 !C now direction of gg_tube vector
19548         do j=1,3
19549         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19550         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19551         enddo
19552         enddo
19553 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19554 !C        print *,gg_tube(1,0),"TU"
19555
19556
19557        do i=itube_start,itube_end
19558 !C Lets not jump over memory as we use many times iti
19559          iti=itype(i,1)
19560 !C lets ommit dummy atoms for now
19561          if ((iti.eq.ntyp1)  &
19562 !C in UNRES uncomment the line below as GLY has no side-chain...
19563 !C      .or.(iti.eq.10)
19564         ) cycle
19565       xmin=boxxsize
19566       ymin=boxysize
19567         do j=-1,1
19568          vectube(1)=mod((c(1,i+nres)),boxxsize)
19569          vectube(1)=vectube(1)+boxxsize*j
19570          vectube(2)=mod((c(2,i+nres)),boxysize)
19571          vectube(2)=vectube(2)+boxysize*j
19572
19573          xminact=abs(vectube(1)-tubecenter(1))
19574          yminact=abs(vectube(2)-tubecenter(2))
19575            if (xmin.gt.xminact) then
19576             xmin=xminact
19577             xtemp=vectube(1)
19578            endif
19579            if (ymin.gt.yminact) then
19580              ymin=yminact
19581              ytemp=vectube(2)
19582             endif
19583          enddo
19584       vectube(1)=xtemp
19585       vectube(2)=ytemp
19586 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19587 !C     &     tubecenter(2)
19588       vectube(1)=vectube(1)-tubecenter(1)
19589       vectube(2)=vectube(2)-tubecenter(2)
19590
19591 !C as the tube is infinity we do not calculate the Z-vector use of Z
19592 !C as chosen axis
19593       vectube(3)=0.0d0
19594 !C now calculte the distance
19595        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19596 !C now normalize vector
19597       vectube(1)=vectube(1)/tub_r
19598       vectube(2)=vectube(2)/tub_r
19599
19600 !C calculte rdiffrence between r and r0
19601       rdiff=tub_r-tubeR0
19602 !C and its 6 power
19603       rdiff6=rdiff**6.0d0
19604 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19605        sc_aa_tube=sc_aa_tube_par(iti)
19606        sc_bb_tube=sc_bb_tube_par(iti)
19607        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19608        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19609              6.0d0*sc_bb_tube/rdiff6/rdiff
19610 !C now direction of gg_tube vector
19611          do j=1,3
19612           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19613           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19614          enddo
19615         enddo
19616         do i=itube_start,itube_end
19617           Etube=Etube+enetube(i)+enetube(i+nres)
19618         enddo
19619 !C        print *,"ETUBE", etube
19620         return
19621         end subroutine calctube
19622 !C TO DO 1) add to total energy
19623 !C       2) add to gradient summation
19624 !C       3) add reading parameters (AND of course oppening of PARAM file)
19625 !C       4) add reading the center of tube
19626 !C       5) add COMMONs
19627 !C       6) add to zerograd
19628 !C       7) allocate matrices
19629
19630
19631 !C-----------------------------------------------------------------------
19632 !C-----------------------------------------------------------
19633 !C This subroutine is to mimic the histone like structure but as well can be
19634 !C utilizet to nanostructures (infinit) small modification has to be used to
19635 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19636 !C gradient has to be modified at the ends
19637 !C The energy function is Kihara potential
19638 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19639 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19640 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19641 !C simple Kihara potential
19642       subroutine calctube2(Etube)
19643             real(kind=8),dimension(3) :: vectube
19644       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19645        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19646        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19647       integer:: i,j,iti
19648       Etube=0.0d0
19649       do i=itube_start,itube_end
19650         enetube(i)=0.0d0
19651         enetube(i+nres)=0.0d0
19652       enddo
19653 !C first we calculate the distance from tube center
19654 !C first sugare-phosphate group for NARES this would be peptide group
19655 !C for UNRES
19656        do i=itube_start,itube_end
19657 !C lets ommit dummy atoms for now
19658
19659        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19660 !C now calculate distance from center of tube and direction vectors
19661 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19662 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19663 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19664 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19665       xmin=boxxsize
19666       ymin=boxysize
19667         do j=-1,1
19668          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19669          vectube(1)=vectube(1)+boxxsize*j
19670          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19671          vectube(2)=vectube(2)+boxysize*j
19672
19673          xminact=abs(vectube(1)-tubecenter(1))
19674          yminact=abs(vectube(2)-tubecenter(2))
19675            if (xmin.gt.xminact) then
19676             xmin=xminact
19677             xtemp=vectube(1)
19678            endif
19679            if (ymin.gt.yminact) then
19680              ymin=yminact
19681              ytemp=vectube(2)
19682             endif
19683          enddo
19684       vectube(1)=xtemp
19685       vectube(2)=ytemp
19686       vectube(1)=vectube(1)-tubecenter(1)
19687       vectube(2)=vectube(2)-tubecenter(2)
19688
19689 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19690 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19691
19692 !C as the tube is infinity we do not calculate the Z-vector use of Z
19693 !C as chosen axis
19694       vectube(3)=0.0d0
19695 !C now calculte the distance
19696        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19697 !C now normalize vector
19698       vectube(1)=vectube(1)/tub_r
19699       vectube(2)=vectube(2)/tub_r
19700 !C calculte rdiffrence between r and r0
19701       rdiff=tub_r-tubeR0
19702 !C and its 6 power
19703       rdiff6=rdiff**6.0d0
19704 !C THIS FRAGMENT MAKES TUBE FINITE
19705         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19706         if (positi.le.0) positi=positi+boxzsize
19707 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19708 !c for each residue check if it is in lipid or lipid water border area
19709 !C       respos=mod(c(3,i+nres),boxzsize)
19710 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19711        if ((positi.gt.bordtubebot)  &
19712         .and.(positi.lt.bordtubetop)) then
19713 !C the energy transfer exist
19714         if (positi.lt.buftubebot) then
19715          fracinbuf=1.0d0-  &
19716            ((positi-bordtubebot)/tubebufthick)
19717 !C lipbufthick is thickenes of lipid buffore
19718          sstube=sscalelip(fracinbuf)
19719          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19720 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19721          enetube(i)=enetube(i)+sstube*tubetranenepep
19722 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19723 !C     &+ssgradtube*tubetranene(itype(i,1))
19724 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19725 !C     &+ssgradtube*tubetranene(itype(i,1))
19726 !C         print *,"doing sccale for lower part"
19727         elseif (positi.gt.buftubetop) then
19728          fracinbuf=1.0d0-  &
19729         ((bordtubetop-positi)/tubebufthick)
19730          sstube=sscalelip(fracinbuf)
19731          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19732          enetube(i)=enetube(i)+sstube*tubetranenepep
19733 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19734 !C     &+ssgradtube*tubetranene(itype(i,1))
19735 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19736 !C     &+ssgradtube*tubetranene(itype(i,1))
19737 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19738         else
19739          sstube=1.0d0
19740          ssgradtube=0.0d0
19741          enetube(i)=enetube(i)+sstube*tubetranenepep
19742 !C         print *,"I am in true lipid"
19743         endif
19744         else
19745 !C          sstube=0.0d0
19746 !C          ssgradtube=0.0d0
19747         cycle
19748         endif ! if in lipid or buffor
19749
19750 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19751        enetube(i)=enetube(i)+sstube* &
19752         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19753 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19754 !C       print *,rdiff,rdiff6,pep_aa_tube
19755 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19756 !C now we calculate gradient
19757        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19758              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19759 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19760 !C     &rdiff,fac
19761
19762 !C now direction of gg_tube vector
19763        do j=1,3
19764         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19765         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19766         enddo
19767          gg_tube(3,i)=gg_tube(3,i)  &
19768        +ssgradtube*enetube(i)/sstube/2.0d0
19769          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19770        +ssgradtube*enetube(i)/sstube/2.0d0
19771
19772         enddo
19773 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19774 !C        print *,gg_tube(1,0),"TU"
19775         do i=itube_start,itube_end
19776 !C Lets not jump over memory as we use many times iti
19777          iti=itype(i,1)
19778 !C lets ommit dummy atoms for now
19779          if ((iti.eq.ntyp1) &
19780 !!C in UNRES uncomment the line below as GLY has no side-chain...
19781            .or.(iti.eq.10) &
19782           ) cycle
19783           vectube(1)=c(1,i+nres)
19784           vectube(1)=mod(vectube(1),boxxsize)
19785           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19786           vectube(2)=c(2,i+nres)
19787           vectube(2)=mod(vectube(2),boxysize)
19788           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19789
19790       vectube(1)=vectube(1)-tubecenter(1)
19791       vectube(2)=vectube(2)-tubecenter(2)
19792 !C THIS FRAGMENT MAKES TUBE FINITE
19793         positi=(mod(c(3,i+nres),boxzsize))
19794         if (positi.le.0) positi=positi+boxzsize
19795 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19796 !c for each residue check if it is in lipid or lipid water border area
19797 !C       respos=mod(c(3,i+nres),boxzsize)
19798 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19799
19800        if ((positi.gt.bordtubebot)  &
19801         .and.(positi.lt.bordtubetop)) then
19802 !C the energy transfer exist
19803         if (positi.lt.buftubebot) then
19804          fracinbuf=1.0d0- &
19805             ((positi-bordtubebot)/tubebufthick)
19806 !C lipbufthick is thickenes of lipid buffore
19807          sstube=sscalelip(fracinbuf)
19808          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19809 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19810          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19811 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19812 !C     &+ssgradtube*tubetranene(itype(i,1))
19813 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19814 !C     &+ssgradtube*tubetranene(itype(i,1))
19815 !C         print *,"doing sccale for lower part"
19816         elseif (positi.gt.buftubetop) then
19817          fracinbuf=1.0d0- &
19818         ((bordtubetop-positi)/tubebufthick)
19819
19820          sstube=sscalelip(fracinbuf)
19821          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19822          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19823 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19824 !C     &+ssgradtube*tubetranene(itype(i,1))
19825 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19826 !C     &+ssgradtube*tubetranene(itype(i,1))
19827 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19828         else
19829          sstube=1.0d0
19830          ssgradtube=0.0d0
19831          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19832 !C         print *,"I am in true lipid"
19833         endif
19834         else
19835 !C          sstube=0.0d0
19836 !C          ssgradtube=0.0d0
19837         cycle
19838         endif ! if in lipid or buffor
19839 !CEND OF FINITE FRAGMENT
19840 !C as the tube is infinity we do not calculate the Z-vector use of Z
19841 !C as chosen axis
19842       vectube(3)=0.0d0
19843 !C now calculte the distance
19844        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19845 !C now normalize vector
19846       vectube(1)=vectube(1)/tub_r
19847       vectube(2)=vectube(2)/tub_r
19848 !C calculte rdiffrence between r and r0
19849       rdiff=tub_r-tubeR0
19850 !C and its 6 power
19851       rdiff6=rdiff**6.0d0
19852 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19853        sc_aa_tube=sc_aa_tube_par(iti)
19854        sc_bb_tube=sc_bb_tube_par(iti)
19855        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19856                        *sstube+enetube(i+nres)
19857 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19858 !C now we calculate gradient
19859        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19860             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19861 !C now direction of gg_tube vector
19862          do j=1,3
19863           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19864           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19865          enddo
19866          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19867        +ssgradtube*enetube(i+nres)/sstube
19868          gg_tube(3,i-1)= gg_tube(3,i-1) &
19869        +ssgradtube*enetube(i+nres)/sstube
19870
19871         enddo
19872         do i=itube_start,itube_end
19873           Etube=Etube+enetube(i)+enetube(i+nres)
19874         enddo
19875 !C        print *,"ETUBE", etube
19876         return
19877         end subroutine calctube2
19878 !=====================================================================================================================================
19879       subroutine calcnano(Etube)
19880       real(kind=8),dimension(3) :: vectube
19881
19882       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19883        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19884        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19885        integer:: i,j,iti,r
19886
19887       Etube=0.0d0
19888 !      print *,itube_start,itube_end,"poczatek"
19889       do i=itube_start,itube_end
19890         enetube(i)=0.0d0
19891         enetube(i+nres)=0.0d0
19892       enddo
19893 !C first we calculate the distance from tube center
19894 !C first sugare-phosphate group for NARES this would be peptide group
19895 !C for UNRES
19896        do i=itube_start,itube_end
19897 !C lets ommit dummy atoms for now
19898        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19899 !C now calculate distance from center of tube and direction vectors
19900       xmin=boxxsize
19901       ymin=boxysize
19902       zmin=boxzsize
19903
19904         do j=-1,1
19905          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19906          vectube(1)=vectube(1)+boxxsize*j
19907          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19908          vectube(2)=vectube(2)+boxysize*j
19909          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19910          vectube(3)=vectube(3)+boxzsize*j
19911
19912
19913          xminact=dabs(vectube(1)-tubecenter(1))
19914          yminact=dabs(vectube(2)-tubecenter(2))
19915          zminact=dabs(vectube(3)-tubecenter(3))
19916
19917            if (xmin.gt.xminact) then
19918             xmin=xminact
19919             xtemp=vectube(1)
19920            endif
19921            if (ymin.gt.yminact) then
19922              ymin=yminact
19923              ytemp=vectube(2)
19924             endif
19925            if (zmin.gt.zminact) then
19926              zmin=zminact
19927              ztemp=vectube(3)
19928             endif
19929          enddo
19930       vectube(1)=xtemp
19931       vectube(2)=ytemp
19932       vectube(3)=ztemp
19933
19934       vectube(1)=vectube(1)-tubecenter(1)
19935       vectube(2)=vectube(2)-tubecenter(2)
19936       vectube(3)=vectube(3)-tubecenter(3)
19937
19938 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19939 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19940 !C as the tube is infinity we do not calculate the Z-vector use of Z
19941 !C as chosen axis
19942 !C      vectube(3)=0.0d0
19943 !C now calculte the distance
19944        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19945 !C now normalize vector
19946       vectube(1)=vectube(1)/tub_r
19947       vectube(2)=vectube(2)/tub_r
19948       vectube(3)=vectube(3)/tub_r
19949 !C calculte rdiffrence between r and r0
19950       rdiff=tub_r-tubeR0
19951 !C and its 6 power
19952       rdiff6=rdiff**6.0d0
19953 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19954        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19955 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19956 !C       print *,rdiff,rdiff6,pep_aa_tube
19957 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19958 !C now we calculate gradient
19959        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19960             6.0d0*pep_bb_tube)/rdiff6/rdiff
19961 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19962 !C     &rdiff,fac
19963          if (acavtubpep.eq.0.0d0) then
19964 !C go to 667
19965          enecavtube(i)=0.0
19966          faccav=0.0
19967          else
19968          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19969          enecavtube(i)=  &
19970         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19971         /denominator
19972          enecavtube(i)=0.0
19973          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19974         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19975         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19976         /denominator**2.0d0
19977 !C         faccav=0.0
19978 !C         fac=fac+faccav
19979 !C 667     continue
19980          endif
19981           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19982         do j=1,3
19983         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19984         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19985         enddo
19986         enddo
19987
19988        do i=itube_start,itube_end
19989         enecavtube(i)=0.0d0
19990 !C Lets not jump over memory as we use many times iti
19991          iti=itype(i,1)
19992 !C lets ommit dummy atoms for now
19993          if ((iti.eq.ntyp1) &
19994 !C in UNRES uncomment the line below as GLY has no side-chain...
19995 !C      .or.(iti.eq.10)
19996          ) cycle
19997       xmin=boxxsize
19998       ymin=boxysize
19999       zmin=boxzsize
20000         do j=-1,1
20001          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20002          vectube(1)=vectube(1)+boxxsize*j
20003          vectube(2)=dmod((c(2,i+nres)),boxysize)
20004          vectube(2)=vectube(2)+boxysize*j
20005          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20006          vectube(3)=vectube(3)+boxzsize*j
20007
20008
20009          xminact=dabs(vectube(1)-tubecenter(1))
20010          yminact=dabs(vectube(2)-tubecenter(2))
20011          zminact=dabs(vectube(3)-tubecenter(3))
20012
20013            if (xmin.gt.xminact) then
20014             xmin=xminact
20015             xtemp=vectube(1)
20016            endif
20017            if (ymin.gt.yminact) then
20018              ymin=yminact
20019              ytemp=vectube(2)
20020             endif
20021            if (zmin.gt.zminact) then
20022              zmin=zminact
20023              ztemp=vectube(3)
20024             endif
20025          enddo
20026       vectube(1)=xtemp
20027       vectube(2)=ytemp
20028       vectube(3)=ztemp
20029
20030 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20031 !C     &     tubecenter(2)
20032       vectube(1)=vectube(1)-tubecenter(1)
20033       vectube(2)=vectube(2)-tubecenter(2)
20034       vectube(3)=vectube(3)-tubecenter(3)
20035 !C now calculte the distance
20036        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20037 !C now normalize vector
20038       vectube(1)=vectube(1)/tub_r
20039       vectube(2)=vectube(2)/tub_r
20040       vectube(3)=vectube(3)/tub_r
20041
20042 !C calculte rdiffrence between r and r0
20043       rdiff=tub_r-tubeR0
20044 !C and its 6 power
20045       rdiff6=rdiff**6.0d0
20046        sc_aa_tube=sc_aa_tube_par(iti)
20047        sc_bb_tube=sc_bb_tube_par(iti)
20048        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20049 !C       enetube(i+nres)=0.0d0
20050 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20051 !C now we calculate gradient
20052        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20053             6.0d0*sc_bb_tube/rdiff6/rdiff
20054 !C       fac=0.0
20055 !C now direction of gg_tube vector
20056 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20057          if (acavtub(iti).eq.0.0d0) then
20058 !C go to 667
20059          enecavtube(i+nres)=0.0d0
20060          faccav=0.0d0
20061          else
20062          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20063          enecavtube(i+nres)=   &
20064         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20065         /denominator
20066 !C         enecavtube(i)=0.0
20067          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20068         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20069         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20070         /denominator**2.0d0
20071 !C         faccav=0.0
20072          fac=fac+faccav
20073 !C 667     continue
20074          endif
20075 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20076 !C     &   enecavtube(i),faccav
20077 !C         print *,"licz=",
20078 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20079 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20080          do j=1,3
20081           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20082           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20083          enddo
20084           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20085         enddo
20086
20087
20088
20089         do i=itube_start,itube_end
20090           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20091          +enecavtube(i+nres)
20092         enddo
20093 !        do i=1,20
20094 !         print *,"begin", i,"a"
20095 !         do r=1,10000
20096 !          rdiff=r/100.0d0
20097 !          rdiff6=rdiff**6.0d0
20098 !          sc_aa_tube=sc_aa_tube_par(i)
20099 !          sc_bb_tube=sc_bb_tube_par(i)
20100 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20101 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20102 !          enecavtube(i)=   &
20103 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20104 !         /denominator
20105
20106 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20107 !         enddo
20108 !         print *,"end",i,"a"
20109 !        enddo
20110 !C        print *,"ETUBE", etube
20111         return
20112         end subroutine calcnano
20113
20114 !===============================================
20115 !--------------------------------------------------------------------------------
20116 !C first for shielding is setting of function of side-chains
20117
20118        subroutine set_shield_fac2
20119        real(kind=8) :: div77_81=0.974996043d0, &
20120         div4_81=0.2222222222d0
20121        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20122          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20123          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20124          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20125 !C the vector between center of side_chain and peptide group
20126        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20127          pept_group,costhet_grad,cosphi_grad_long, &
20128          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20129          sh_frac_dist_grad,pep_side
20130         integer i,j,k
20131 !C      write(2,*) "ivec",ivec_start,ivec_end
20132       do i=1,nres
20133         fac_shield(i)=0.0d0
20134         ishield_list(i)=0
20135         do j=1,3
20136         grad_shield(j,i)=0.0d0
20137         enddo
20138       enddo
20139       do i=ivec_start,ivec_end
20140 !C      do i=1,nres-1
20141 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20142 !      ishield_list(i)=0
20143       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20144 !Cif there two consequtive dummy atoms there is no peptide group between them
20145 !C the line below has to be changed for FGPROC>1
20146       VolumeTotal=0.0
20147       do k=1,nres
20148        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20149        dist_pep_side=0.0
20150        dist_side_calf=0.0
20151        do j=1,3
20152 !C first lets set vector conecting the ithe side-chain with kth side-chain
20153       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20154 !C      pep_side(j)=2.0d0
20155 !C and vector conecting the side-chain with its proper calfa
20156       side_calf(j)=c(j,k+nres)-c(j,k)
20157 !C      side_calf(j)=2.0d0
20158       pept_group(j)=c(j,i)-c(j,i+1)
20159 !C lets have their lenght
20160       dist_pep_side=pep_side(j)**2+dist_pep_side
20161       dist_side_calf=dist_side_calf+side_calf(j)**2
20162       dist_pept_group=dist_pept_group+pept_group(j)**2
20163       enddo
20164        dist_pep_side=sqrt(dist_pep_side)
20165        dist_pept_group=sqrt(dist_pept_group)
20166        dist_side_calf=sqrt(dist_side_calf)
20167       do j=1,3
20168         pep_side_norm(j)=pep_side(j)/dist_pep_side
20169         side_calf_norm(j)=dist_side_calf
20170       enddo
20171 !C now sscale fraction
20172        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20173 !       print *,buff_shield,"buff",sh_frac_dist
20174 !C now sscale
20175         if (sh_frac_dist.le.0.0) cycle
20176 !C        print *,ishield_list(i),i
20177 !C If we reach here it means that this side chain reaches the shielding sphere
20178 !C Lets add him to the list for gradient
20179         ishield_list(i)=ishield_list(i)+1
20180 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20181 !C this list is essential otherwise problem would be O3
20182         shield_list(ishield_list(i),i)=k
20183 !C Lets have the sscale value
20184         if (sh_frac_dist.gt.1.0) then
20185          scale_fac_dist=1.0d0
20186          do j=1,3
20187          sh_frac_dist_grad(j)=0.0d0
20188          enddo
20189         else
20190          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20191                         *(2.0d0*sh_frac_dist-3.0d0)
20192          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20193                        /dist_pep_side/buff_shield*0.5d0
20194          do j=1,3
20195          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20196 !C         sh_frac_dist_grad(j)=0.0d0
20197 !C         scale_fac_dist=1.0d0
20198 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20199 !C     &                    sh_frac_dist_grad(j)
20200          enddo
20201         endif
20202 !C this is what is now we have the distance scaling now volume...
20203       short=short_r_sidechain(itype(k,1))
20204       long=long_r_sidechain(itype(k,1))
20205       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20206       sinthet=short/dist_pep_side*costhet
20207 !      print *,"SORT",short,long,sinthet,costhet
20208 !C now costhet_grad
20209 !C       costhet=0.6d0
20210 !C       sinthet=0.8
20211        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20212 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20213 !C     &             -short/dist_pep_side**2/costhet)
20214 !C       costhet_fac=0.0d0
20215        do j=1,3
20216          costhet_grad(j)=costhet_fac*pep_side(j)
20217        enddo
20218 !C remember for the final gradient multiply costhet_grad(j)
20219 !C for side_chain by factor -2 !
20220 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20221 !C pep_side0pept_group is vector multiplication
20222       pep_side0pept_group=0.0d0
20223       do j=1,3
20224       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20225       enddo
20226       cosalfa=(pep_side0pept_group/ &
20227       (dist_pep_side*dist_side_calf))
20228       fac_alfa_sin=1.0d0-cosalfa**2
20229       fac_alfa_sin=dsqrt(fac_alfa_sin)
20230       rkprim=fac_alfa_sin*(long-short)+short
20231 !C      rkprim=short
20232
20233 !C now costhet_grad
20234        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20235 !C       cosphi=0.6
20236        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20237        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20238            dist_pep_side**2)
20239 !C       sinphi=0.8
20240        do j=1,3
20241          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20242       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20243       *(long-short)/fac_alfa_sin*cosalfa/ &
20244       ((dist_pep_side*dist_side_calf))* &
20245       ((side_calf(j))-cosalfa* &
20246       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20247 !C       cosphi_grad_long(j)=0.0d0
20248         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20249       *(long-short)/fac_alfa_sin*cosalfa &
20250       /((dist_pep_side*dist_side_calf))* &
20251       (pep_side(j)- &
20252       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20253 !C       cosphi_grad_loc(j)=0.0d0
20254        enddo
20255 !C      print *,sinphi,sinthet
20256       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20257                          /VSolvSphere_div
20258 !C     &                    *wshield
20259 !C now the gradient...
20260       do j=1,3
20261       grad_shield(j,i)=grad_shield(j,i) &
20262 !C gradient po skalowaniu
20263                      +(sh_frac_dist_grad(j)*VofOverlap &
20264 !C  gradient po costhet
20265             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20266         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20267             sinphi/sinthet*costhet*costhet_grad(j) &
20268            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20269         )*wshield
20270 !C grad_shield_side is Cbeta sidechain gradient
20271       grad_shield_side(j,ishield_list(i),i)=&
20272              (sh_frac_dist_grad(j)*-2.0d0&
20273              *VofOverlap&
20274             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20275        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20276             sinphi/sinthet*costhet*costhet_grad(j)&
20277            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20278             )*wshield
20279 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20280 !            sinphi/sinthet,&
20281 !           +sinthet/sinphi,"HERE"
20282        grad_shield_loc(j,ishield_list(i),i)=   &
20283             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20284       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20285             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20286              ))&
20287              *wshield
20288 !         print *,grad_shield_loc(j,ishield_list(i),i)
20289       enddo
20290       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20291       enddo
20292       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20293
20294 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20295       enddo
20296       return
20297       end subroutine set_shield_fac2
20298 !----------------------------------------------------------------------------
20299 ! SOUBROUTINE FOR AFM
20300        subroutine AFMvel(Eafmforce)
20301        use MD_data, only:totTafm
20302       real(kind=8),dimension(3) :: diffafm
20303       real(kind=8) :: afmdist,Eafmforce
20304        integer :: i
20305 !C Only for check grad COMMENT if not used for checkgrad
20306 !C      totT=3.0d0
20307 !C--------------------------------------------------------
20308 !C      print *,"wchodze"
20309       afmdist=0.0d0
20310       Eafmforce=0.0d0
20311       do i=1,3
20312       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20313       afmdist=afmdist+diffafm(i)**2
20314       enddo
20315       afmdist=dsqrt(afmdist)
20316 !      totTafm=3.0
20317       Eafmforce=0.5d0*forceAFMconst &
20318       *(distafminit+totTafm*velAFMconst-afmdist)**2
20319 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20320       do i=1,3
20321       gradafm(i,afmend-1)=-forceAFMconst* &
20322        (distafminit+totTafm*velAFMconst-afmdist) &
20323        *diffafm(i)/afmdist
20324       gradafm(i,afmbeg-1)=forceAFMconst* &
20325       (distafminit+totTafm*velAFMconst-afmdist) &
20326       *diffafm(i)/afmdist
20327       enddo
20328 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20329       return
20330       end subroutine AFMvel
20331 !---------------------------------------------------------
20332        subroutine AFMforce(Eafmforce)
20333
20334       real(kind=8),dimension(3) :: diffafm
20335 !      real(kind=8) ::afmdist
20336       real(kind=8) :: afmdist,Eafmforce
20337       integer :: i
20338       afmdist=0.0d0
20339       Eafmforce=0.0d0
20340       do i=1,3
20341       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20342       afmdist=afmdist+diffafm(i)**2
20343       enddo
20344       afmdist=dsqrt(afmdist)
20345 !      print *,afmdist,distafminit
20346       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20347       do i=1,3
20348       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20349       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20350       enddo
20351 !C      print *,'AFM',Eafmforce
20352       return
20353       end subroutine AFMforce
20354
20355 !-----------------------------------------------------------------------------
20356 #ifdef WHAM
20357       subroutine read_ssHist
20358 !      implicit none
20359 !      Includes
20360 !      include 'DIMENSIONS'
20361 !      include "DIMENSIONS.FREE"
20362 !      include 'COMMON.FREE'
20363 !     Local variables
20364       integer :: i,j
20365       character(len=80) :: controlcard
20366
20367       do i=1,dyn_nssHist
20368         call card_concat(controlcard,.true.)
20369         read(controlcard,*) &
20370              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20371       enddo
20372
20373       return
20374       end subroutine read_ssHist
20375 #endif
20376 !-----------------------------------------------------------------------------
20377       integer function indmat(i,j)
20378 !el
20379 ! get the position of the jth ijth fragment of the chain coordinate system
20380 ! in the fromto array.
20381         integer :: i,j
20382
20383         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20384       return
20385       end function indmat
20386 !-----------------------------------------------------------------------------
20387       real(kind=8) function sigm(x)
20388 !el
20389        real(kind=8) :: x
20390         sigm=0.25d0*x
20391       return
20392       end function sigm
20393 !-----------------------------------------------------------------------------
20394 !-----------------------------------------------------------------------------
20395       subroutine alloc_ener_arrays
20396 !EL Allocation of arrays used by module energy
20397       use MD_data, only: mset
20398 !el local variables
20399       integer :: i,j
20400
20401       if(nres.lt.100) then
20402         maxconts=nres
20403       elseif(nres.lt.200) then
20404         maxconts=0.8*nres      ! Max. number of contacts per residue
20405       else
20406         maxconts=0.6*nres ! (maxconts=maxres/4)
20407       endif
20408       maxcont=12*nres      ! Max. number of SC contacts
20409       maxvar=6*nres      ! Max. number of variables
20410 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20411       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20412 !----------------------
20413 ! arrays in subroutine init_int_table
20414 !el#ifdef MPI
20415 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20416 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20417 !el#endif
20418       allocate(nint_gr(nres))
20419       allocate(nscp_gr(nres))
20420       allocate(ielstart(nres))
20421       allocate(ielend(nres))
20422 !(maxres)
20423       allocate(istart(nres,maxint_gr))
20424       allocate(iend(nres,maxint_gr))
20425 !(maxres,maxint_gr)
20426       allocate(iscpstart(nres,maxint_gr))
20427       allocate(iscpend(nres,maxint_gr))
20428 !(maxres,maxint_gr)
20429       allocate(ielstart_vdw(nres))
20430       allocate(ielend_vdw(nres))
20431 !(maxres)
20432       allocate(nint_gr_nucl(nres))
20433       allocate(nscp_gr_nucl(nres))
20434       allocate(ielstart_nucl(nres))
20435       allocate(ielend_nucl(nres))
20436 !(maxres)
20437       allocate(istart_nucl(nres,maxint_gr))
20438       allocate(iend_nucl(nres,maxint_gr))
20439 !(maxres,maxint_gr)
20440       allocate(iscpstart_nucl(nres,maxint_gr))
20441       allocate(iscpend_nucl(nres,maxint_gr))
20442 !(maxres,maxint_gr)
20443       allocate(ielstart_vdw_nucl(nres))
20444       allocate(ielend_vdw_nucl(nres))
20445
20446       allocate(lentyp(0:nfgtasks-1))
20447 !(0:maxprocs-1)
20448 !----------------------
20449 ! commom.contacts
20450 !      common /contacts/
20451       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20452       allocate(icont(2,maxcont))
20453 !(2,maxcont)
20454 !      common /contacts1/
20455       allocate(num_cont(0:nres+4))
20456 !(maxres)
20457       allocate(jcont(maxconts,nres))
20458 !(maxconts,maxres)
20459       allocate(facont(maxconts,nres))
20460 !(maxconts,maxres)
20461       allocate(gacont(3,maxconts,nres))
20462 !(3,maxconts,maxres)
20463 !      common /contacts_hb/
20464       allocate(gacontp_hb1(3,maxconts,nres))
20465       allocate(gacontp_hb2(3,maxconts,nres))
20466       allocate(gacontp_hb3(3,maxconts,nres))
20467       allocate(gacontm_hb1(3,maxconts,nres))
20468       allocate(gacontm_hb2(3,maxconts,nres))
20469       allocate(gacontm_hb3(3,maxconts,nres))
20470       allocate(gacont_hbr(3,maxconts,nres))
20471       allocate(grij_hb_cont(3,maxconts,nres))
20472 !(3,maxconts,maxres)
20473       allocate(facont_hb(maxconts,nres))
20474
20475       allocate(ees0p(maxconts,nres))
20476       allocate(ees0m(maxconts,nres))
20477       allocate(d_cont(maxconts,nres))
20478       allocate(ees0plist(maxconts,nres))
20479
20480 !(maxconts,maxres)
20481       allocate(num_cont_hb(nres))
20482 !(maxres)
20483       allocate(jcont_hb(maxconts,nres))
20484 !(maxconts,maxres)
20485 !      common /rotat/
20486       allocate(Ug(2,2,nres))
20487       allocate(Ugder(2,2,nres))
20488       allocate(Ug2(2,2,nres))
20489       allocate(Ug2der(2,2,nres))
20490 !(2,2,maxres)
20491       allocate(obrot(2,nres))
20492       allocate(obrot2(2,nres))
20493       allocate(obrot_der(2,nres))
20494       allocate(obrot2_der(2,nres))
20495 !(2,maxres)
20496 !      common /precomp1/
20497       allocate(mu(2,nres))
20498       allocate(muder(2,nres))
20499       allocate(Ub2(2,nres))
20500       Ub2(1,:)=0.0d0
20501       Ub2(2,:)=0.0d0
20502       allocate(Ub2der(2,nres))
20503       allocate(Ctobr(2,nres))
20504       allocate(Ctobrder(2,nres))
20505       allocate(Dtobr2(2,nres))
20506       allocate(Dtobr2der(2,nres))
20507 !(2,maxres)
20508       allocate(EUg(2,2,nres))
20509       allocate(EUgder(2,2,nres))
20510       allocate(CUg(2,2,nres))
20511       allocate(CUgder(2,2,nres))
20512       allocate(DUg(2,2,nres))
20513       allocate(Dugder(2,2,nres))
20514       allocate(DtUg2(2,2,nres))
20515       allocate(DtUg2der(2,2,nres))
20516 !(2,2,maxres)
20517 !      common /precomp2/
20518       allocate(Ug2Db1t(2,nres))
20519       allocate(Ug2Db1tder(2,nres))
20520       allocate(CUgb2(2,nres))
20521       allocate(CUgb2der(2,nres))
20522 !(2,maxres)
20523       allocate(EUgC(2,2,nres))
20524       allocate(EUgCder(2,2,nres))
20525       allocate(EUgD(2,2,nres))
20526       allocate(EUgDder(2,2,nres))
20527       allocate(DtUg2EUg(2,2,nres))
20528       allocate(Ug2DtEUg(2,2,nres))
20529 !(2,2,maxres)
20530       allocate(Ug2DtEUgder(2,2,2,nres))
20531       allocate(DtUg2EUgder(2,2,2,nres))
20532 !(2,2,2,maxres)
20533       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20534       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20535       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20536       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20537
20538       allocate(ctilde(2,2,nres))
20539       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20540       allocate(gtb1(2,nres))
20541       allocate(gtb2(2,nres))
20542       allocate(cc(2,2,nres))
20543       allocate(dd(2,2,nres))
20544       allocate(ee(2,2,nres))
20545       allocate(gtcc(2,2,nres))
20546       allocate(gtdd(2,2,nres))
20547       allocate(gtee(2,2,nres))
20548       allocate(gUb2(2,nres))
20549       allocate(gteUg(2,2,nres))
20550
20551 !      common /rotat_old/
20552       allocate(costab(nres))
20553       allocate(sintab(nres))
20554       allocate(costab2(nres))
20555       allocate(sintab2(nres))
20556 !(maxres)
20557 !      common /dipmat/
20558       allocate(a_chuj(2,2,maxconts,nres))
20559 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20560       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20561 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20562 !      common /contdistrib/
20563       allocate(ncont_sent(nres))
20564       allocate(ncont_recv(nres))
20565
20566       allocate(iat_sent(nres))
20567 !(maxres)
20568       allocate(iint_sent(4,nres,nres))
20569       allocate(iint_sent_local(4,nres,nres))
20570 !(4,maxres,maxres)
20571       allocate(iturn3_sent(4,0:nres+4))
20572       allocate(iturn4_sent(4,0:nres+4))
20573       allocate(iturn3_sent_local(4,nres))
20574       allocate(iturn4_sent_local(4,nres))
20575 !(4,maxres)
20576       allocate(itask_cont_from(0:nfgtasks-1))
20577       allocate(itask_cont_to(0:nfgtasks-1))
20578 !(0:max_fg_procs-1)
20579
20580
20581
20582 !----------------------
20583 ! commom.deriv;
20584 !      common /derivat/
20585       allocate(dcdv(6,maxdim))
20586       allocate(dxdv(6,maxdim))
20587 !(6,maxdim)
20588       allocate(dxds(6,nres))
20589 !(6,maxres)
20590       allocate(gradx(3,-1:nres,0:2))
20591       allocate(gradc(3,-1:nres,0:2))
20592 !(3,maxres,2)
20593       allocate(gvdwx(3,-1:nres))
20594       allocate(gvdwc(3,-1:nres))
20595       allocate(gelc(3,-1:nres))
20596       allocate(gelc_long(3,-1:nres))
20597       allocate(gvdwpp(3,-1:nres))
20598       allocate(gvdwc_scpp(3,-1:nres))
20599       allocate(gradx_scp(3,-1:nres))
20600       allocate(gvdwc_scp(3,-1:nres))
20601       allocate(ghpbx(3,-1:nres))
20602       allocate(ghpbc(3,-1:nres))
20603       allocate(gradcorr(3,-1:nres))
20604       allocate(gradcorr_long(3,-1:nres))
20605       allocate(gradcorr5_long(3,-1:nres))
20606       allocate(gradcorr6_long(3,-1:nres))
20607       allocate(gcorr6_turn_long(3,-1:nres))
20608       allocate(gradxorr(3,-1:nres))
20609       allocate(gradcorr5(3,-1:nres))
20610       allocate(gradcorr6(3,-1:nres))
20611       allocate(gliptran(3,-1:nres))
20612       allocate(gliptranc(3,-1:nres))
20613       allocate(gliptranx(3,-1:nres))
20614       allocate(gshieldx(3,-1:nres))
20615       allocate(gshieldc(3,-1:nres))
20616       allocate(gshieldc_loc(3,-1:nres))
20617       allocate(gshieldx_ec(3,-1:nres))
20618       allocate(gshieldc_ec(3,-1:nres))
20619       allocate(gshieldc_loc_ec(3,-1:nres))
20620       allocate(gshieldx_t3(3,-1:nres))
20621       allocate(gshieldc_t3(3,-1:nres))
20622       allocate(gshieldc_loc_t3(3,-1:nres))
20623       allocate(gshieldx_t4(3,-1:nres))
20624       allocate(gshieldc_t4(3,-1:nres))
20625       allocate(gshieldc_loc_t4(3,-1:nres))
20626       allocate(gshieldx_ll(3,-1:nres))
20627       allocate(gshieldc_ll(3,-1:nres))
20628       allocate(gshieldc_loc_ll(3,-1:nres))
20629       allocate(grad_shield(3,-1:nres))
20630       allocate(gg_tube_sc(3,-1:nres))
20631       allocate(gg_tube(3,-1:nres))
20632       allocate(gradafm(3,-1:nres))
20633       allocate(gradb_nucl(3,-1:nres))
20634       allocate(gradbx_nucl(3,-1:nres))
20635       allocate(gvdwpsb1(3,-1:nres))
20636       allocate(gelpp(3,-1:nres))
20637       allocate(gvdwpsb(3,-1:nres))
20638       allocate(gelsbc(3,-1:nres))
20639       allocate(gelsbx(3,-1:nres))
20640       allocate(gvdwsbx(3,-1:nres))
20641       allocate(gvdwsbc(3,-1:nres))
20642       allocate(gsbloc(3,-1:nres))
20643       allocate(gsblocx(3,-1:nres))
20644       allocate(gradcorr_nucl(3,-1:nres))
20645       allocate(gradxorr_nucl(3,-1:nres))
20646       allocate(gradcorr3_nucl(3,-1:nres))
20647       allocate(gradxorr3_nucl(3,-1:nres))
20648       allocate(gvdwpp_nucl(3,-1:nres))
20649       allocate(gradpepcat(3,-1:nres))
20650       allocate(gradpepcatx(3,-1:nres))
20651       allocate(gradcatcat(3,-1:nres))
20652 !(3,maxres)
20653       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20654       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20655 ! grad for shielding surroing
20656       allocate(gloc(0:maxvar,0:2))
20657       allocate(gloc_x(0:maxvar,2))
20658 !(maxvar,2)
20659       allocate(gel_loc(3,-1:nres))
20660       allocate(gel_loc_long(3,-1:nres))
20661       allocate(gcorr3_turn(3,-1:nres))
20662       allocate(gcorr4_turn(3,-1:nres))
20663       allocate(gcorr6_turn(3,-1:nres))
20664       allocate(gradb(3,-1:nres))
20665       allocate(gradbx(3,-1:nres))
20666 !(3,maxres)
20667       allocate(gel_loc_loc(maxvar))
20668       allocate(gel_loc_turn3(maxvar))
20669       allocate(gel_loc_turn4(maxvar))
20670       allocate(gel_loc_turn6(maxvar))
20671       allocate(gcorr_loc(maxvar))
20672       allocate(g_corr5_loc(maxvar))
20673       allocate(g_corr6_loc(maxvar))
20674 !(maxvar)
20675       allocate(gsccorc(3,-1:nres))
20676       allocate(gsccorx(3,-1:nres))
20677 !(3,maxres)
20678       allocate(gsccor_loc(-1:nres))
20679 !(maxres)
20680       allocate(gvdwx_scbase(3,-1:nres))
20681       allocate(gvdwc_scbase(3,-1:nres))
20682       allocate(gvdwx_pepbase(3,-1:nres))
20683       allocate(gvdwc_pepbase(3,-1:nres))
20684       allocate(gvdwx_scpho(3,-1:nres))
20685       allocate(gvdwc_scpho(3,-1:nres))
20686       allocate(gvdwc_peppho(3,-1:nres))
20687
20688       allocate(dtheta(3,2,-1:nres))
20689 !(3,2,maxres)
20690       allocate(gscloc(3,-1:nres))
20691       allocate(gsclocx(3,-1:nres))
20692 !(3,maxres)
20693       allocate(dphi(3,3,-1:nres))
20694       allocate(dalpha(3,3,-1:nres))
20695       allocate(domega(3,3,-1:nres))
20696 !(3,3,maxres)
20697 !      common /deriv_scloc/
20698       allocate(dXX_C1tab(3,nres))
20699       allocate(dYY_C1tab(3,nres))
20700       allocate(dZZ_C1tab(3,nres))
20701       allocate(dXX_Ctab(3,nres))
20702       allocate(dYY_Ctab(3,nres))
20703       allocate(dZZ_Ctab(3,nres))
20704       allocate(dXX_XYZtab(3,nres))
20705       allocate(dYY_XYZtab(3,nres))
20706       allocate(dZZ_XYZtab(3,nres))
20707 !(3,maxres)
20708 !      common /mpgrad/
20709       allocate(jgrad_start(nres))
20710       allocate(jgrad_end(nres))
20711 !(maxres)
20712 !----------------------
20713
20714 !      common /indices/
20715       allocate(ibond_displ(0:nfgtasks-1))
20716       allocate(ibond_count(0:nfgtasks-1))
20717       allocate(ithet_displ(0:nfgtasks-1))
20718       allocate(ithet_count(0:nfgtasks-1))
20719       allocate(iphi_displ(0:nfgtasks-1))
20720       allocate(iphi_count(0:nfgtasks-1))
20721       allocate(iphi1_displ(0:nfgtasks-1))
20722       allocate(iphi1_count(0:nfgtasks-1))
20723       allocate(ivec_displ(0:nfgtasks-1))
20724       allocate(ivec_count(0:nfgtasks-1))
20725       allocate(iset_displ(0:nfgtasks-1))
20726       allocate(iset_count(0:nfgtasks-1))
20727       allocate(iint_count(0:nfgtasks-1))
20728       allocate(iint_displ(0:nfgtasks-1))
20729 !(0:max_fg_procs-1)
20730 !----------------------
20731 ! common.MD
20732 !      common /mdgrad/
20733       allocate(gcart(3,-1:nres))
20734       allocate(gxcart(3,-1:nres))
20735 !(3,0:MAXRES)
20736       allocate(gradcag(3,-1:nres))
20737       allocate(gradxag(3,-1:nres))
20738 !(3,MAXRES)
20739 !      common /back_constr/
20740 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20741       allocate(dutheta(nres))
20742       allocate(dugamma(nres))
20743 !(maxres)
20744       allocate(duscdiff(3,nres))
20745       allocate(duscdiffx(3,nres))
20746 !(3,maxres)
20747 !el i io:read_fragments
20748 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20749 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20750 !      common /qmeas/
20751 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20752 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20753       allocate(mset(0:nprocs))  !(maxprocs/20)
20754       mset(:)=0
20755 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20756 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20757       allocate(dUdconst(3,0:nres))
20758       allocate(dUdxconst(3,0:nres))
20759       allocate(dqwol(3,0:nres))
20760       allocate(dxqwol(3,0:nres))
20761 !(3,0:MAXRES)
20762 !----------------------
20763 ! common.sbridge
20764 !      common /sbridge/ in io_common: read_bridge
20765 !el    allocate((:),allocatable :: iss      !(maxss)
20766 !      common /links/  in io_common: read_bridge
20767 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20768 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20769 !      common /dyn_ssbond/
20770 ! and side-chain vectors in theta or phi.
20771       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20772 !(maxres,maxres)
20773 !      do i=1,nres
20774 !        do j=i+1,nres
20775       dyn_ssbond_ij(:,:)=1.0d300
20776 !        enddo
20777 !      enddo
20778
20779 !      if (nss.gt.0) then
20780         allocate(idssb(maxdim),jdssb(maxdim))
20781 !        allocate(newihpb(nss),newjhpb(nss))
20782 !(maxdim)
20783 !      endif
20784       allocate(ishield_list(-1:nres))
20785       allocate(shield_list(maxcontsshi,-1:nres))
20786       allocate(dyn_ss_mask(nres))
20787       allocate(fac_shield(-1:nres))
20788       allocate(enetube(nres*2))
20789       allocate(enecavtube(nres*2))
20790
20791 !(maxres)
20792       dyn_ss_mask(:)=.false.
20793 !----------------------
20794 ! common.sccor
20795 ! Parameters of the SCCOR term
20796 !      common/sccor/
20797 !el in io_conf: parmread
20798 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20799 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20800 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20801 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20802 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20803 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20804 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20805 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20806 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20807 !----------------
20808       allocate(gloc_sc(3,0:2*nres,0:10))
20809 !(3,0:maxres2,10)maxres2=2*maxres
20810       allocate(dcostau(3,3,3,2*nres))
20811       allocate(dsintau(3,3,3,2*nres))
20812       allocate(dtauangle(3,3,3,2*nres))
20813       allocate(dcosomicron(3,3,3,2*nres))
20814       allocate(domicron(3,3,3,2*nres))
20815 !(3,3,3,maxres2)maxres2=2*maxres
20816 !----------------------
20817 ! common.var
20818 !      common /restr/
20819       allocate(varall(maxvar))
20820 !(maxvar)(maxvar=6*maxres)
20821       allocate(mask_theta(nres))
20822       allocate(mask_phi(nres))
20823       allocate(mask_side(nres))
20824 !(maxres)
20825 !----------------------
20826 ! common.vectors
20827 !      common /vectors/
20828       allocate(uy(3,nres))
20829       allocate(uz(3,nres))
20830 !(3,maxres)
20831       allocate(uygrad(3,3,2,nres))
20832       allocate(uzgrad(3,3,2,nres))
20833 !(3,3,2,maxres)
20834
20835       return
20836       end subroutine alloc_ener_arrays
20837 !-----------------------------------------------------------------
20838       subroutine ebond_nucl(estr_nucl)
20839 !c
20840 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20841 !c
20842
20843       real(kind=8),dimension(3) :: u,ud
20844       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20845       real(kind=8) :: estr_nucl,diff
20846       integer :: iti,i,j,k,nbi
20847       estr_nucl=0.0d0
20848 !C      print *,"I enter ebond"
20849       if (energy_dec) &
20850       write (iout,*) "ibondp_start,ibondp_end",&
20851        ibondp_nucl_start,ibondp_nucl_end
20852       do i=ibondp_nucl_start,ibondp_nucl_end
20853         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20854          itype(i,2).eq.ntyp1_molec(2)) cycle
20855 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20856 !          do j=1,3
20857 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20858 !     &      *dc(j,i-1)/vbld(i)
20859 !          enddo
20860 !          if (energy_dec) write(iout,*)
20861 !     &       "estr1",i,vbld(i),distchainmax,
20862 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20863
20864           diff = vbld(i)-vbldp0_nucl
20865           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20866           vbldp0_nucl,diff,AKP_nucl*diff*diff
20867           estr_nucl=estr_nucl+diff*diff
20868 !          print *,estr_nucl
20869           do j=1,3
20870             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20871           enddo
20872 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20873       enddo
20874       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20875 !      print *,"partial sum", estr_nucl,AKP_nucl
20876
20877       if (energy_dec) &
20878       write (iout,*) "ibondp_start,ibondp_end",&
20879        ibond_nucl_start,ibond_nucl_end
20880
20881       do i=ibond_nucl_start,ibond_nucl_end
20882 !C        print *, "I am stuck",i
20883         iti=itype(i,2)
20884         if (iti.eq.ntyp1_molec(2)) cycle
20885           nbi=nbondterm_nucl(iti)
20886 !C        print *,iti,nbi
20887           if (nbi.eq.1) then
20888             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20889
20890             if (energy_dec) &
20891            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20892            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20893             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20894 !            print *,estr_nucl
20895             do j=1,3
20896               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20897             enddo
20898           else
20899             do j=1,nbi
20900               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20901               ud(j)=aksc_nucl(j,iti)*diff
20902               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20903             enddo
20904             uprod=u(1)
20905             do j=2,nbi
20906               uprod=uprod*u(j)
20907             enddo
20908             usum=0.0d0
20909             usumsqder=0.0d0
20910             do j=1,nbi
20911               uprod1=1.0d0
20912               uprod2=1.0d0
20913               do k=1,nbi
20914                 if (k.ne.j) then
20915                   uprod1=uprod1*u(k)
20916                   uprod2=uprod2*u(k)*u(k)
20917                 endif
20918               enddo
20919               usum=usum+uprod1
20920               usumsqder=usumsqder+ud(j)*uprod2
20921             enddo
20922             estr_nucl=estr_nucl+uprod/usum
20923             do j=1,3
20924              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20925             enddo
20926         endif
20927       enddo
20928 !C      print *,"I am about to leave ebond"
20929       return
20930       end subroutine ebond_nucl
20931
20932 !-----------------------------------------------------------------------------
20933       subroutine ebend_nucl(etheta_nucl)
20934       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20935       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20936       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20937       logical :: lprn=.false., lprn1=.false.
20938 !el local variables
20939       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20940       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20941       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20942 ! local variables for constrains
20943       real(kind=8) :: difi,thetiii
20944        integer itheta
20945       etheta_nucl=0.0D0
20946 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20947       do i=ithet_nucl_start,ithet_nucl_end
20948         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20949         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20950         (itype(i,2).eq.ntyp1_molec(2))) cycle
20951         dethetai=0.0d0
20952         dephii=0.0d0
20953         dephii1=0.0d0
20954         theti2=0.5d0*theta(i)
20955         ityp2=ithetyp_nucl(itype(i-1,2))
20956         do k=1,nntheterm_nucl
20957           coskt(k)=dcos(k*theti2)
20958           sinkt(k)=dsin(k*theti2)
20959         enddo
20960         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20961 #ifdef OSF
20962           phii=phi(i)
20963           if (phii.ne.phii) phii=150.0
20964 #else
20965           phii=phi(i)
20966 #endif
20967           ityp1=ithetyp_nucl(itype(i-2,2))
20968           do k=1,nsingle_nucl
20969             cosph1(k)=dcos(k*phii)
20970             sinph1(k)=dsin(k*phii)
20971           enddo
20972         else
20973           phii=0.0d0
20974           ityp1=nthetyp_nucl+1
20975           do k=1,nsingle_nucl
20976             cosph1(k)=0.0d0
20977             sinph1(k)=0.0d0
20978           enddo
20979         endif
20980
20981         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20982 #ifdef OSF
20983           phii1=phi(i+1)
20984           if (phii1.ne.phii1) phii1=150.0
20985           phii1=pinorm(phii1)
20986 #else
20987           phii1=phi(i+1)
20988 #endif
20989           ityp3=ithetyp_nucl(itype(i,2))
20990           do k=1,nsingle_nucl
20991             cosph2(k)=dcos(k*phii1)
20992             sinph2(k)=dsin(k*phii1)
20993           enddo
20994         else
20995           phii1=0.0d0
20996           ityp3=nthetyp_nucl+1
20997           do k=1,nsingle_nucl
20998             cosph2(k)=0.0d0
20999             sinph2(k)=0.0d0
21000           enddo
21001         endif
21002         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21003         do k=1,ndouble_nucl
21004           do l=1,k-1
21005             ccl=cosph1(l)*cosph2(k-l)
21006             ssl=sinph1(l)*sinph2(k-l)
21007             scl=sinph1(l)*cosph2(k-l)
21008             csl=cosph1(l)*sinph2(k-l)
21009             cosph1ph2(l,k)=ccl-ssl
21010             cosph1ph2(k,l)=ccl+ssl
21011             sinph1ph2(l,k)=scl+csl
21012             sinph1ph2(k,l)=scl-csl
21013           enddo
21014         enddo
21015         if (lprn) then
21016         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21017          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21018         write (iout,*) "coskt and sinkt",nntheterm_nucl
21019         do k=1,nntheterm_nucl
21020           write (iout,*) k,coskt(k),sinkt(k)
21021         enddo
21022         endif
21023         do k=1,ntheterm_nucl
21024           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21025           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21026            *coskt(k)
21027           if (lprn)&
21028          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21029           " ethetai",ethetai
21030         enddo
21031         if (lprn) then
21032         write (iout,*) "cosph and sinph"
21033         do k=1,nsingle_nucl
21034           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21035         enddo
21036         write (iout,*) "cosph1ph2 and sinph2ph2"
21037         do k=2,ndouble_nucl
21038           do l=1,k-1
21039             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21040               sinph1ph2(l,k),sinph1ph2(k,l)
21041           enddo
21042         enddo
21043         write(iout,*) "ethetai",ethetai
21044         endif
21045         do m=1,ntheterm2_nucl
21046           do k=1,nsingle_nucl
21047             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21048               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21049               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21050               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21051             ethetai=ethetai+sinkt(m)*aux
21052             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21053             dephii=dephii+k*sinkt(m)*(&
21054                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21055                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21056             dephii1=dephii1+k*sinkt(m)*(&
21057                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21058                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21059             if (lprn) &
21060            write (iout,*) "m",m," k",k," bbthet",&
21061               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21062               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21063               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21064               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21065           enddo
21066         enddo
21067         if (lprn) &
21068         write(iout,*) "ethetai",ethetai
21069         do m=1,ntheterm3_nucl
21070           do k=2,ndouble_nucl
21071             do l=1,k-1
21072               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21073                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21074                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21075                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21076               ethetai=ethetai+sinkt(m)*aux
21077               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21078               dephii=dephii+l*sinkt(m)*(&
21079                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21080                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21081                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21082                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21083               dephii1=dephii1+(k-l)*sinkt(m)*( &
21084                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21085                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21086                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21087                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21088               if (lprn) then
21089               write (iout,*) "m",m," k",k," l",l," ffthet", &
21090                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21091                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21092                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21093                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21094               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21095                  cosph1ph2(k,l)*sinkt(m),&
21096                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21097               endif
21098             enddo
21099           enddo
21100         enddo
21101 10      continue
21102         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21103         i,theta(i)*rad2deg,phii*rad2deg, &
21104         phii1*rad2deg,ethetai
21105         etheta_nucl=etheta_nucl+ethetai
21106 !        print *,i,"partial sum",etheta_nucl
21107         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21108         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21109         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21110       enddo
21111       return
21112       end subroutine ebend_nucl
21113 !----------------------------------------------------
21114       subroutine etor_nucl(etors_nucl)
21115 !      implicit real*8 (a-h,o-z)
21116 !      include 'DIMENSIONS'
21117 !      include 'COMMON.VAR'
21118 !      include 'COMMON.GEO'
21119 !      include 'COMMON.LOCAL'
21120 !      include 'COMMON.TORSION'
21121 !      include 'COMMON.INTERACT'
21122 !      include 'COMMON.DERIV'
21123 !      include 'COMMON.CHAIN'
21124 !      include 'COMMON.NAMES'
21125 !      include 'COMMON.IOUNITS'
21126 !      include 'COMMON.FFIELD'
21127 !      include 'COMMON.TORCNSTR'
21128 !      include 'COMMON.CONTROL'
21129       real(kind=8) :: etors_nucl,edihcnstr
21130       logical :: lprn
21131 !el local variables
21132       integer :: i,j,iblock,itori,itori1
21133       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21134                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21135 ! Set lprn=.true. for debugging
21136       lprn=.false.
21137 !     lprn=.true.
21138       etors_nucl=0.0D0
21139 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21140       do i=iphi_nucl_start,iphi_nucl_end
21141         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21142              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21143              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21144         etors_ii=0.0D0
21145         itori=itortyp_nucl(itype(i-2,2))
21146         itori1=itortyp_nucl(itype(i-1,2))
21147         phii=phi(i)
21148 !         print *,i,itori,itori1
21149         gloci=0.0D0
21150 !C Regular cosine and sine terms
21151         do j=1,nterm_nucl(itori,itori1)
21152           v1ij=v1_nucl(j,itori,itori1)
21153           v2ij=v2_nucl(j,itori,itori1)
21154           cosphi=dcos(j*phii)
21155           sinphi=dsin(j*phii)
21156           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21157           if (energy_dec) etors_ii=etors_ii+&
21158                      v1ij*cosphi+v2ij*sinphi
21159           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21160         enddo
21161 !C Lorentz terms
21162 !C                         v1
21163 !C  E = SUM ----------------------------------- - v1
21164 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21165 !C
21166         cosphi=dcos(0.5d0*phii)
21167         sinphi=dsin(0.5d0*phii)
21168         do j=1,nlor_nucl(itori,itori1)
21169           vl1ij=vlor1_nucl(j,itori,itori1)
21170           vl2ij=vlor2_nucl(j,itori,itori1)
21171           vl3ij=vlor3_nucl(j,itori,itori1)
21172           pom=vl2ij*cosphi+vl3ij*sinphi
21173           pom1=1.0d0/(pom*pom+1.0d0)
21174           etors_nucl=etors_nucl+vl1ij*pom1
21175           if (energy_dec) etors_ii=etors_ii+ &
21176                      vl1ij*pom1
21177           pom=-pom*pom1*pom1
21178           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21179         enddo
21180 !C Subtract the constant term
21181         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21182           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21183               'etor',i,etors_ii-v0_nucl(itori,itori1)
21184         if (lprn) &
21185        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21186        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21187        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21188         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21189 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21190       enddo
21191       return
21192       end subroutine etor_nucl
21193 !------------------------------------------------------------
21194       subroutine epp_nucl_sub(evdw1,ees)
21195 !C
21196 !C This subroutine calculates the average interaction energy and its gradient
21197 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21198 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21199 !C The potential depends both on the distance of peptide-group centers and on
21200 !C the orientation of the CA-CA virtual bonds.
21201 !C
21202       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21203       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21204       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21205                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21206                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21207       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21208                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21209       integer xshift,yshift,zshift
21210       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21211       real(kind=8) :: ees,eesij
21212 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21213       real(kind=8) scal_el /0.5d0/
21214       t_eelecij=0.0d0
21215       ees=0.0D0
21216       evdw1=0.0D0
21217       ind=0
21218 !c
21219 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21220 !c
21221 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21222       do i=iatel_s_nucl,iatel_e_nucl
21223         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21224         dxi=dc(1,i)
21225         dyi=dc(2,i)
21226         dzi=dc(3,i)
21227         dx_normi=dc_norm(1,i)
21228         dy_normi=dc_norm(2,i)
21229         dz_normi=dc_norm(3,i)
21230         xmedi=c(1,i)+0.5d0*dxi
21231         ymedi=c(2,i)+0.5d0*dyi
21232         zmedi=c(3,i)+0.5d0*dzi
21233           xmedi=dmod(xmedi,boxxsize)
21234           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21235           ymedi=dmod(ymedi,boxysize)
21236           if (ymedi.lt.0) ymedi=ymedi+boxysize
21237           zmedi=dmod(zmedi,boxzsize)
21238           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21239
21240         do j=ielstart_nucl(i),ielend_nucl(i)
21241           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21242           ind=ind+1
21243           dxj=dc(1,j)
21244           dyj=dc(2,j)
21245           dzj=dc(3,j)
21246 !          xj=c(1,j)+0.5D0*dxj-xmedi
21247 !          yj=c(2,j)+0.5D0*dyj-ymedi
21248 !          zj=c(3,j)+0.5D0*dzj-zmedi
21249           xj=c(1,j)+0.5D0*dxj
21250           yj=c(2,j)+0.5D0*dyj
21251           zj=c(3,j)+0.5D0*dzj
21252           xj=mod(xj,boxxsize)
21253           if (xj.lt.0) xj=xj+boxxsize
21254           yj=mod(yj,boxysize)
21255           if (yj.lt.0) yj=yj+boxysize
21256           zj=mod(zj,boxzsize)
21257           if (zj.lt.0) zj=zj+boxzsize
21258       isubchap=0
21259       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21260       xj_safe=xj
21261       yj_safe=yj
21262       zj_safe=zj
21263       do xshift=-1,1
21264       do yshift=-1,1
21265       do zshift=-1,1
21266           xj=xj_safe+xshift*boxxsize
21267           yj=yj_safe+yshift*boxysize
21268           zj=zj_safe+zshift*boxzsize
21269           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21270           if(dist_temp.lt.dist_init) then
21271             dist_init=dist_temp
21272             xj_temp=xj
21273             yj_temp=yj
21274             zj_temp=zj
21275             isubchap=1
21276           endif
21277        enddo
21278        enddo
21279        enddo
21280        if (isubchap.eq.1) then
21281 !C          print *,i,j
21282           xj=xj_temp-xmedi
21283           yj=yj_temp-ymedi
21284           zj=zj_temp-zmedi
21285        else
21286           xj=xj_safe-xmedi
21287           yj=yj_safe-ymedi
21288           zj=zj_safe-zmedi
21289        endif
21290
21291           rij=xj*xj+yj*yj+zj*zj
21292 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21293           fac=(r0pp**2/rij)**3
21294           ev1=epspp*fac*fac
21295           ev2=epspp*fac
21296           evdw1ij=ev1-2*ev2
21297           fac=(-ev1-evdw1ij)/rij
21298 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21299           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21300           evdw1=evdw1+evdw1ij
21301 !C
21302 !C Calculate contributions to the Cartesian gradient.
21303 !C
21304           ggg(1)=fac*xj
21305           ggg(2)=fac*yj
21306           ggg(3)=fac*zj
21307           do k=1,3
21308             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21309             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21310           enddo
21311 !c phoshate-phosphate electrostatic interactions
21312           rij=dsqrt(rij)
21313           fac=1.0d0/rij
21314           eesij=dexp(-BEES*rij)*fac
21315 !          write (2,*)"fac",fac," eesijpp",eesij
21316           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21317           ees=ees+eesij
21318 !c          fac=-eesij*fac
21319           fac=-(fac+BEES)*eesij*fac
21320           ggg(1)=fac*xj
21321           ggg(2)=fac*yj
21322           ggg(3)=fac*zj
21323 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21324 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21325 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21326           do k=1,3
21327             gelpp(k,i)=gelpp(k,i)-ggg(k)
21328             gelpp(k,j)=gelpp(k,j)+ggg(k)
21329           enddo
21330         enddo ! j
21331       enddo   ! i
21332 !c      ees=332.0d0*ees
21333       ees=AEES*ees
21334       do i=nnt,nct
21335 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21336         do k=1,3
21337           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21338 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21339           gelpp(k,i)=AEES*gelpp(k,i)
21340         enddo
21341 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21342       enddo
21343 !c      write (2,*) "total EES",ees
21344       return
21345       end subroutine epp_nucl_sub
21346 !---------------------------------------------------------------------
21347       subroutine epsb(evdwpsb,eelpsb)
21348 !      use comm_locel
21349 !C
21350 !C This subroutine calculates the excluded-volume interaction energy between
21351 !C peptide-group centers and side chains and its gradient in virtual-bond and
21352 !C side-chain vectors.
21353 !C
21354       real(kind=8),dimension(3):: ggg
21355       integer :: i,iint,j,k,iteli,itypj,subchap
21356       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21357                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21358       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21359                     dist_temp, dist_init
21360       integer xshift,yshift,zshift
21361
21362 !cd    print '(a)','Enter ESCP'
21363 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21364       eelpsb=0.0d0
21365       evdwpsb=0.0d0
21366 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21367       do i=iatscp_s_nucl,iatscp_e_nucl
21368         if (itype(i,2).eq.ntyp1_molec(2) &
21369          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21370         xi=0.5D0*(c(1,i)+c(1,i+1))
21371         yi=0.5D0*(c(2,i)+c(2,i+1))
21372         zi=0.5D0*(c(3,i)+c(3,i+1))
21373           xi=mod(xi,boxxsize)
21374           if (xi.lt.0) xi=xi+boxxsize
21375           yi=mod(yi,boxysize)
21376           if (yi.lt.0) yi=yi+boxysize
21377           zi=mod(zi,boxzsize)
21378           if (zi.lt.0) zi=zi+boxzsize
21379
21380         do iint=1,nscp_gr_nucl(i)
21381
21382         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21383           itypj=itype(j,2)
21384           if (itypj.eq.ntyp1_molec(2)) cycle
21385 !C Uncomment following three lines for SC-p interactions
21386 !c         xj=c(1,nres+j)-xi
21387 !c         yj=c(2,nres+j)-yi
21388 !c         zj=c(3,nres+j)-zi
21389 !C Uncomment following three lines for Ca-p interactions
21390 !          xj=c(1,j)-xi
21391 !          yj=c(2,j)-yi
21392 !          zj=c(3,j)-zi
21393           xj=c(1,j)
21394           yj=c(2,j)
21395           zj=c(3,j)
21396           xj=mod(xj,boxxsize)
21397           if (xj.lt.0) xj=xj+boxxsize
21398           yj=mod(yj,boxysize)
21399           if (yj.lt.0) yj=yj+boxysize
21400           zj=mod(zj,boxzsize)
21401           if (zj.lt.0) zj=zj+boxzsize
21402       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21403       xj_safe=xj
21404       yj_safe=yj
21405       zj_safe=zj
21406       subchap=0
21407       do xshift=-1,1
21408       do yshift=-1,1
21409       do zshift=-1,1
21410           xj=xj_safe+xshift*boxxsize
21411           yj=yj_safe+yshift*boxysize
21412           zj=zj_safe+zshift*boxzsize
21413           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21414           if(dist_temp.lt.dist_init) then
21415             dist_init=dist_temp
21416             xj_temp=xj
21417             yj_temp=yj
21418             zj_temp=zj
21419             subchap=1
21420           endif
21421        enddo
21422        enddo
21423        enddo
21424        if (subchap.eq.1) then
21425           xj=xj_temp-xi
21426           yj=yj_temp-yi
21427           zj=zj_temp-zi
21428        else
21429           xj=xj_safe-xi
21430           yj=yj_safe-yi
21431           zj=zj_safe-zi
21432        endif
21433
21434           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21435           fac=rrij**expon2
21436           e1=fac*fac*aad_nucl(itypj)
21437           e2=fac*bad_nucl(itypj)
21438           if (iabs(j-i) .le. 2) then
21439             e1=scal14*e1
21440             e2=scal14*e2
21441           endif
21442           evdwij=e1+e2
21443           evdwpsb=evdwpsb+evdwij
21444           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21445              'evdw2',i,j,evdwij,"tu4"
21446 !C
21447 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21448 !C
21449           fac=-(evdwij+e1)*rrij
21450           ggg(1)=xj*fac
21451           ggg(2)=yj*fac
21452           ggg(3)=zj*fac
21453           do k=1,3
21454             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21455             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21456           enddo
21457         enddo
21458
21459         enddo ! iint
21460       enddo ! i
21461       do i=1,nct
21462         do j=1,3
21463           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21464           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21465         enddo
21466       enddo
21467       return
21468       end subroutine epsb
21469
21470 !------------------------------------------------------
21471       subroutine esb_gb(evdwsb,eelsb)
21472       use comm_locel
21473       use calc_data_nucl
21474       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21475       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21476       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21477       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21478                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21479       integer :: ii
21480       logical lprn
21481       evdw=0.0D0
21482       eelsb=0.0d0
21483       ecorr=0.0d0
21484       evdwsb=0.0D0
21485       lprn=.false.
21486       ind=0
21487 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21488       do i=iatsc_s_nucl,iatsc_e_nucl
21489         num_conti=0
21490         num_conti2=0
21491         itypi=itype(i,2)
21492 !        PRINT *,"I=",i,itypi
21493         if (itypi.eq.ntyp1_molec(2)) cycle
21494         itypi1=itype(i+1,2)
21495         xi=c(1,nres+i)
21496         yi=c(2,nres+i)
21497         zi=c(3,nres+i)
21498           xi=dmod(xi,boxxsize)
21499           if (xi.lt.0) xi=xi+boxxsize
21500           yi=dmod(yi,boxysize)
21501           if (yi.lt.0) yi=yi+boxysize
21502           zi=dmod(zi,boxzsize)
21503           if (zi.lt.0) zi=zi+boxzsize
21504
21505         dxi=dc_norm(1,nres+i)
21506         dyi=dc_norm(2,nres+i)
21507         dzi=dc_norm(3,nres+i)
21508         dsci_inv=vbld_inv(i+nres)
21509 !C
21510 !C Calculate SC interaction energy.
21511 !C
21512         do iint=1,nint_gr_nucl(i)
21513 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21514           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21515             ind=ind+1
21516 !            print *,"JESTEM"
21517             itypj=itype(j,2)
21518             if (itypj.eq.ntyp1_molec(2)) cycle
21519             dscj_inv=vbld_inv(j+nres)
21520             sig0ij=sigma_nucl(itypi,itypj)
21521             chi1=chi_nucl(itypi,itypj)
21522             chi2=chi_nucl(itypj,itypi)
21523             chi12=chi1*chi2
21524             chip1=chip_nucl(itypi,itypj)
21525             chip2=chip_nucl(itypj,itypi)
21526             chip12=chip1*chip2
21527 !            xj=c(1,nres+j)-xi
21528 !            yj=c(2,nres+j)-yi
21529 !            zj=c(3,nres+j)-zi
21530            xj=c(1,nres+j)
21531            yj=c(2,nres+j)
21532            zj=c(3,nres+j)
21533           xj=dmod(xj,boxxsize)
21534           if (xj.lt.0) xj=xj+boxxsize
21535           yj=dmod(yj,boxysize)
21536           if (yj.lt.0) yj=yj+boxysize
21537           zj=dmod(zj,boxzsize)
21538           if (zj.lt.0) zj=zj+boxzsize
21539       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21540       xj_safe=xj
21541       yj_safe=yj
21542       zj_safe=zj
21543       subchap=0
21544       do xshift=-1,1
21545       do yshift=-1,1
21546       do zshift=-1,1
21547           xj=xj_safe+xshift*boxxsize
21548           yj=yj_safe+yshift*boxysize
21549           zj=zj_safe+zshift*boxzsize
21550           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21551           if(dist_temp.lt.dist_init) then
21552             dist_init=dist_temp
21553             xj_temp=xj
21554             yj_temp=yj
21555             zj_temp=zj
21556             subchap=1
21557           endif
21558        enddo
21559        enddo
21560        enddo
21561        if (subchap.eq.1) then
21562           xj=xj_temp-xi
21563           yj=yj_temp-yi
21564           zj=zj_temp-zi
21565        else
21566           xj=xj_safe-xi
21567           yj=yj_safe-yi
21568           zj=zj_safe-zi
21569        endif
21570
21571             dxj=dc_norm(1,nres+j)
21572             dyj=dc_norm(2,nres+j)
21573             dzj=dc_norm(3,nres+j)
21574             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21575             rij=dsqrt(rrij)
21576 !C Calculate angle-dependent terms of energy and contributions to their
21577 !C derivatives.
21578             erij(1)=xj*rij
21579             erij(2)=yj*rij
21580             erij(3)=zj*rij
21581             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21582             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21583             om12=dxi*dxj+dyi*dyj+dzi*dzj
21584             call sc_angular_nucl
21585             sigsq=1.0D0/sigsq
21586             sig=sig0ij*dsqrt(sigsq)
21587             rij_shift=1.0D0/rij-sig+sig0ij
21588 !            print *,rij_shift,"rij_shift"
21589 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21590 !c     &       " rij_shift",rij_shift
21591             if (rij_shift.le.0.0D0) then
21592               evdw=1.0D20
21593               return
21594             endif
21595             sigder=-sig*sigsq
21596 !c---------------------------------------------------------------
21597             rij_shift=1.0D0/rij_shift
21598             fac=rij_shift**expon
21599             e1=fac*fac*aa_nucl(itypi,itypj)
21600             e2=fac*bb_nucl(itypi,itypj)
21601             evdwij=eps1*eps2rt*(e1+e2)
21602 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21603 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21604             eps2der=evdwij
21605             evdwij=evdwij*eps2rt
21606             evdwsb=evdwsb+evdwij
21607             if (lprn) then
21608             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21609             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21610             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21611              restyp(itypi,2),i,restyp(itypj,2),j, &
21612              epsi,sigm,chi1,chi2,chip1,chip2, &
21613              eps1,eps2rt**2,sig,sig0ij, &
21614              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21615             evdwij
21616             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21617             endif
21618
21619             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21620                              'evdw',i,j,evdwij,"tu3"
21621
21622
21623 !C Calculate gradient components.
21624             e1=e1*eps1*eps2rt**2
21625             fac=-expon*(e1+evdwij)*rij_shift
21626             sigder=fac*sigder
21627             fac=rij*fac
21628 !c            fac=0.0d0
21629 !C Calculate the radial part of the gradient
21630             gg(1)=xj*fac
21631             gg(2)=yj*fac
21632             gg(3)=zj*fac
21633 !C Calculate angular part of the gradient.
21634             call sc_grad_nucl
21635             call eelsbij(eelij,num_conti2)
21636             if (energy_dec .and. &
21637            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21638           write (istat,'(e14.5)') evdwij
21639             eelsb=eelsb+eelij
21640           enddo      ! j
21641         enddo        ! iint
21642         num_cont_hb(i)=num_conti2
21643       enddo          ! i
21644 !c      write (iout,*) "Number of loop steps in EGB:",ind
21645 !cccc      energy_dec=.false.
21646       return
21647       end subroutine esb_gb
21648 !-------------------------------------------------------------------------------
21649       subroutine eelsbij(eesij,num_conti2)
21650       use comm_locel
21651       use calc_data_nucl
21652       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21653       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21654       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21655                     dist_temp, dist_init,rlocshield,fracinbuf
21656       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21657
21658 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21659       real(kind=8) scal_el /0.5d0/
21660       integer :: iteli,itelj,kkk,kkll,m,isubchap
21661       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21662       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21663       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21664                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21665                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21666                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21667                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21668                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21669                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21670                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21671       ind=ind+1
21672       itypi=itype(i,2)
21673       itypj=itype(j,2)
21674 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21675       ael6i=ael6_nucl(itypi,itypj)
21676       ael3i=ael3_nucl(itypi,itypj)
21677       ael63i=ael63_nucl(itypi,itypj)
21678       ael32i=ael32_nucl(itypi,itypj)
21679 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21680 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21681       dxj=dc(1,j+nres)
21682       dyj=dc(2,j+nres)
21683       dzj=dc(3,j+nres)
21684       dx_normi=dc_norm(1,i+nres)
21685       dy_normi=dc_norm(2,i+nres)
21686       dz_normi=dc_norm(3,i+nres)
21687       dx_normj=dc_norm(1,j+nres)
21688       dy_normj=dc_norm(2,j+nres)
21689       dz_normj=dc_norm(3,j+nres)
21690 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21691 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21692 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21693       if (ipot_nucl.ne.2) then
21694         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21695         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21696         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21697       else
21698         cosa=om12
21699         cosb=om1
21700         cosg=om2
21701       endif
21702       r3ij=rij*rrij
21703       r6ij=r3ij*r3ij
21704       fac=cosa-3.0D0*cosb*cosg
21705       facfac=fac*fac
21706       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21707       fac3=ael6i*r6ij
21708       fac4=ael3i*r3ij
21709       fac5=ael63i*r6ij
21710       fac6=ael32i*r6ij
21711 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21712 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21713       el1=fac3*(4.0D0+facfac-fac1)
21714       el2=fac4*fac
21715       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21716       el4=fac6*facfac
21717       eesij=el1+el2+el3+el4
21718 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21719       ees0ij=4.0D0+facfac-fac1
21720
21721       if (energy_dec) then
21722           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21723           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21724            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21725            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21726            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21727           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21728       endif
21729
21730 !C
21731 !C Calculate contributions to the Cartesian gradient.
21732 !C
21733       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21734       fac1=fac
21735 !c      erij(1)=xj*rmij
21736 !c      erij(2)=yj*rmij
21737 !c      erij(3)=zj*rmij
21738 !*
21739 !* Radial derivatives. First process both termini of the fragment (i,j)
21740 !*
21741       ggg(1)=facel*xj
21742       ggg(2)=facel*yj
21743       ggg(3)=facel*zj
21744       do k=1,3
21745         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21746         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21747         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21748         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21749       enddo
21750 !*
21751 !* Angular part
21752 !*
21753       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21754       fac4=-3.0D0*fac4
21755       fac3=-6.0D0*fac3
21756       fac5= 6.0d0*fac5
21757       fac6=-6.0d0*fac6
21758       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21759        fac6*fac1*cosg
21760       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21761        fac6*fac1*cosb
21762       do k=1,3
21763         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21764         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21765       enddo
21766       do k=1,3
21767         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21768       enddo
21769       do k=1,3
21770         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21771              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21772              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21773         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21774              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21775              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21776         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21777         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21778       enddo
21779 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21780        IF ( j.gt.i+1 .and.&
21781           num_conti.le.maxconts) THEN
21782 !C
21783 !C Calculate the contact function. The ith column of the array JCONT will
21784 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21785 !C greater than I). The arrays FACONT and GACONT will contain the values of
21786 !C the contact function and its derivative.
21787         r0ij=2.20D0*sigma(itypi,itypj)
21788 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21789         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21790 !c        write (2,*) "fcont",fcont
21791         if (fcont.gt.0.0D0) then
21792           num_conti=num_conti+1
21793           num_conti2=num_conti2+1
21794
21795           if (num_conti.gt.maxconts) then
21796             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21797                           ' will skip next contacts for this conf.'
21798           else
21799             jcont_hb(num_conti,i)=j
21800 !c            write (iout,*) "num_conti",num_conti,
21801 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21802 !C Calculate contact energies
21803             cosa4=4.0D0*cosa
21804             wij=cosa-3.0D0*cosb*cosg
21805             cosbg1=cosb+cosg
21806             cosbg2=cosb-cosg
21807             fac3=dsqrt(-ael6i)*r3ij
21808 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21809             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21810             if (ees0tmp.gt.0) then
21811               ees0pij=dsqrt(ees0tmp)
21812             else
21813               ees0pij=0
21814             endif
21815             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21816             if (ees0tmp.gt.0) then
21817               ees0mij=dsqrt(ees0tmp)
21818             else
21819               ees0mij=0
21820             endif
21821             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21822             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21823 !c            write (iout,*) "i",i," j",j,
21824 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21825             ees0pij1=fac3/ees0pij
21826             ees0mij1=fac3/ees0mij
21827             fac3p=-3.0D0*fac3*rrij
21828             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21829             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21830             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21831             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21832             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21833             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21834             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21835             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21836             ecosap=ecosa1+ecosa2
21837             ecosbp=ecosb1+ecosb2
21838             ecosgp=ecosg1+ecosg2
21839             ecosam=ecosa1-ecosa2
21840             ecosbm=ecosb1-ecosb2
21841             ecosgm=ecosg1-ecosg2
21842 !C End diagnostics
21843             facont_hb(num_conti,i)=fcont
21844             fprimcont=fprimcont/rij
21845             do k=1,3
21846               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21847               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21848             enddo
21849             gggp(1)=gggp(1)+ees0pijp*xj
21850             gggp(2)=gggp(2)+ees0pijp*yj
21851             gggp(3)=gggp(3)+ees0pijp*zj
21852             gggm(1)=gggm(1)+ees0mijp*xj
21853             gggm(2)=gggm(2)+ees0mijp*yj
21854             gggm(3)=gggm(3)+ees0mijp*zj
21855 !C Derivatives due to the contact function
21856             gacont_hbr(1,num_conti,i)=fprimcont*xj
21857             gacont_hbr(2,num_conti,i)=fprimcont*yj
21858             gacont_hbr(3,num_conti,i)=fprimcont*zj
21859             do k=1,3
21860 !c
21861 !c Gradient of the correlation terms
21862 !c
21863               gacontp_hb1(k,num_conti,i)= &
21864              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21865             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21866               gacontp_hb2(k,num_conti,i)= &
21867              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21868             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21869               gacontp_hb3(k,num_conti,i)=gggp(k)
21870               gacontm_hb1(k,num_conti,i)= &
21871              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21872             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21873               gacontm_hb2(k,num_conti,i)= &
21874              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21875             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21876               gacontm_hb3(k,num_conti,i)=gggm(k)
21877             enddo
21878           endif
21879         endif
21880       ENDIF
21881       return
21882       end subroutine eelsbij
21883 !------------------------------------------------------------------
21884       subroutine sc_grad_nucl
21885       use comm_locel
21886       use calc_data_nucl
21887       real(kind=8),dimension(3) :: dcosom1,dcosom2
21888       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21889       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21890       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21891       do k=1,3
21892         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21893         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21894       enddo
21895       do k=1,3
21896         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21897       enddo
21898       do k=1,3
21899         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21900                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21901                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21902         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21903                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21904                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21905       enddo
21906 !C
21907 !C Calculate the components of the gradient in DC and X
21908 !C
21909       do l=1,3
21910         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21911         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21912       enddo
21913       return
21914       end subroutine sc_grad_nucl
21915 !-----------------------------------------------------------------------
21916       subroutine esb(esbloc)
21917 !C Calculate the local energy of a side chain and its derivatives in the
21918 !C corresponding virtual-bond valence angles THETA and the spherical angles
21919 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21920 !C added by Urszula Kozlowska. 07/11/2007
21921 !C
21922       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21923       real(kind=8),dimension(9):: x
21924      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21925       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21926       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21927       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21928        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21929        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21930        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21931        integer::it,nlobit,i,j,k
21932 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21933       delta=0.02d0*pi
21934       esbloc=0.0D0
21935       do i=loc_start_nucl,loc_end_nucl
21936         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21937         costtab(i+1) =dcos(theta(i+1))
21938         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21939         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21940         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21941         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21942         cosfac=dsqrt(cosfac2)
21943         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21944         sinfac=dsqrt(sinfac2)
21945         it=itype(i,2)
21946         if (it.eq.10) goto 1
21947
21948 !c
21949 !C  Compute the axes of tghe local cartesian coordinates system; store in
21950 !c   x_prime, y_prime and z_prime
21951 !c
21952         do j=1,3
21953           x_prime(j) = 0.00
21954           y_prime(j) = 0.00
21955           z_prime(j) = 0.00
21956         enddo
21957 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21958 !C     &   dc_norm(3,i+nres)
21959         do j = 1,3
21960           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21961           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21962         enddo
21963         do j = 1,3
21964           z_prime(j) = -uz(j,i-1)
21965 !           z_prime(j)=0.0
21966         enddo
21967
21968         xx=0.0d0
21969         yy=0.0d0
21970         zz=0.0d0
21971         do j = 1,3
21972           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21973           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21974           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21975         enddo
21976
21977         xxtab(i)=xx
21978         yytab(i)=yy
21979         zztab(i)=zz
21980          it=itype(i,2)
21981         do j = 1,9
21982           x(j) = sc_parmin_nucl(j,it)
21983         enddo
21984 #ifdef CHECK_COORD
21985 !Cc diagnostics - remove later
21986         xx1 = dcos(alph(2))
21987         yy1 = dsin(alph(2))*dcos(omeg(2))
21988         zz1 = -dsin(alph(2))*dsin(omeg(2))
21989         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21990          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21991          xx1,yy1,zz1
21992 !C,"  --- ", xx_w,yy_w,zz_w
21993 !c end diagnostics
21994 #endif
21995         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21996         esbloc = esbloc + sumene
21997         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21998 !        print *,"enecomp",sumene,sumene2
21999 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22000 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22001 #ifdef DEBUG
22002         write (2,*) "x",(x(k),k=1,9)
22003 !C
22004 !C This section to check the numerical derivatives of the energy of ith side
22005 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22006 !C #define DEBUG in the code to turn it on.
22007 !C
22008         write (2,*) "sumene               =",sumene
22009         aincr=1.0d-7
22010         xxsave=xx
22011         xx=xx+aincr
22012         write (2,*) xx,yy,zz
22013         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22014         de_dxx_num=(sumenep-sumene)/aincr
22015         xx=xxsave
22016         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22017         yysave=yy
22018         yy=yy+aincr
22019         write (2,*) xx,yy,zz
22020         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22021         de_dyy_num=(sumenep-sumene)/aincr
22022         yy=yysave
22023         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22024         zzsave=zz
22025         zz=zz+aincr
22026         write (2,*) xx,yy,zz
22027         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22028         de_dzz_num=(sumenep-sumene)/aincr
22029         zz=zzsave
22030         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22031         costsave=cost2tab(i+1)
22032         sintsave=sint2tab(i+1)
22033         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22034         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22035         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22036         de_dt_num=(sumenep-sumene)/aincr
22037         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22038         cost2tab(i+1)=costsave
22039         sint2tab(i+1)=sintsave
22040 !C End of diagnostics section.
22041 #endif
22042 !C
22043 !C Compute the gradient of esc
22044 !C
22045         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22046         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22047         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22048         de_dtt=0.0d0
22049 #ifdef DEBUG
22050         write (2,*) "x",(x(k),k=1,9)
22051         write (2,*) "xx",xx," yy",yy," zz",zz
22052         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22053           " de_zz   ",de_zz," de_tt   ",de_tt
22054         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22055           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22056 #endif
22057 !C
22058        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22059        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22060        cosfac2xx=cosfac2*xx
22061        sinfac2yy=sinfac2*yy
22062        do k = 1,3
22063          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22064            vbld_inv(i+1)
22065          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22066            vbld_inv(i)
22067          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22068          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22069 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22070 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22071 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22072 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22073          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22074          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22075          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22076          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22077          dZZ_Ci1(k)=0.0d0
22078          dZZ_Ci(k)=0.0d0
22079          do j=1,3
22080            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22081            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22082          enddo
22083
22084          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22085          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22086          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22087 !c
22088          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22089          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22090        enddo
22091
22092        do k=1,3
22093          dXX_Ctab(k,i)=dXX_Ci(k)
22094          dXX_C1tab(k,i)=dXX_Ci1(k)
22095          dYY_Ctab(k,i)=dYY_Ci(k)
22096          dYY_C1tab(k,i)=dYY_Ci1(k)
22097          dZZ_Ctab(k,i)=dZZ_Ci(k)
22098          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22099          dXX_XYZtab(k,i)=dXX_XYZ(k)
22100          dYY_XYZtab(k,i)=dYY_XYZ(k)
22101          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22102        enddo
22103        do k = 1,3
22104 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22105 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22106 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22107 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22108 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22109 !c     &    dt_dci(k)
22110 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22111 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22112          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22113          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22114          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22115          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22116          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22117          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22118 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22119        enddo
22120 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22121 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22122
22123 !C to check gradient call subroutine check_grad
22124
22125     1 continue
22126       enddo
22127       return
22128       end subroutine esb
22129 !=-------------------------------------------------------
22130       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22131 !      implicit none
22132       real(kind=8),dimension(9):: x(9)
22133        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22134       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22135       integer i
22136 !c      write (2,*) "enesc"
22137 !c      write (2,*) "x",(x(i),i=1,9)
22138 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22139       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22140         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22141         + x(9)*yy*zz
22142       enesc_nucl=sumene
22143       return
22144       end function enesc_nucl
22145 !-----------------------------------------------------------------------------
22146       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22147 #ifdef MPI
22148       include 'mpif.h'
22149       integer,parameter :: max_cont=2000
22150       integer,parameter:: max_dim=2*(8*3+6)
22151       integer, parameter :: msglen1=max_cont*max_dim
22152       integer,parameter :: msglen2=2*msglen1
22153       integer source,CorrelType,CorrelID,Error
22154       real(kind=8) :: buffer(max_cont,max_dim)
22155       integer status(MPI_STATUS_SIZE)
22156       integer :: ierror,nbytes
22157 #endif
22158       real(kind=8),dimension(3):: gx(3),gx1(3)
22159       real(kind=8) :: time00
22160       logical lprn,ldone
22161       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22162       real(kind=8) ecorr,ecorr3
22163       integer :: n_corr,n_corr1,mm,msglen
22164 !C Set lprn=.true. for debugging
22165       lprn=.false.
22166       n_corr=0
22167       n_corr1=0
22168 #ifdef MPI
22169       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22170
22171       if (nfgtasks.le.1) goto 30
22172       if (lprn) then
22173         write (iout,'(a)') 'Contact function values:'
22174         do i=nnt,nct-1
22175           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22176          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22177          j=1,num_cont_hb(i))
22178         enddo
22179       endif
22180 !C Caution! Following code assumes that electrostatic interactions concerning
22181 !C a given atom are split among at most two processors!
22182       CorrelType=477
22183       CorrelID=fg_rank+1
22184       ldone=.false.
22185       do i=1,max_cont
22186         do j=1,max_dim
22187           buffer(i,j)=0.0D0
22188         enddo
22189       enddo
22190       mm=mod(fg_rank,2)
22191 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22192       if (mm) 20,20,10
22193    10 continue
22194 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22195       if (fg_rank.gt.0) then
22196 !C Send correlation contributions to the preceding processor
22197         msglen=msglen1
22198         nn=num_cont_hb(iatel_s_nucl)
22199         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22200 !c        write (*,*) 'The BUFFER array:'
22201 !c        do i=1,nn
22202 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22203 !c        enddo
22204         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22205           msglen=msglen2
22206           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22207 !C Clear the contacts of the atom passed to the neighboring processor
22208         nn=num_cont_hb(iatel_s_nucl+1)
22209 !c        do i=1,nn
22210 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22211 !c        enddo
22212             num_cont_hb(iatel_s_nucl)=0
22213         endif
22214 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22215 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22216 !cd   & ' msglen=',msglen
22217 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22218 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22219 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22220         time00=MPI_Wtime()
22221         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22222          CorrelType,FG_COMM,IERROR)
22223         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22224 !cd      write (iout,*) 'Processor ',fg_rank,
22225 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22226 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22227 !c        write (*,*) 'Processor ',fg_rank,
22228 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22229 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22230 !c        msglen=msglen1
22231       endif ! (fg_rank.gt.0)
22232       if (ldone) goto 30
22233       ldone=.true.
22234    20 continue
22235 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22236       if (fg_rank.lt.nfgtasks-1) then
22237 !C Receive correlation contributions from the next processor
22238         msglen=msglen1
22239         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22240 !cd      write (iout,*) 'Processor',fg_rank,
22241 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22242 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22243 !c        write (*,*) 'Processor',fg_rank,
22244 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22245 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22246         time00=MPI_Wtime()
22247         nbytes=-1
22248         do while (nbytes.le.0)
22249           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22250           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22251         enddo
22252 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22253         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22254          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22255         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22256 !c        write (*,*) 'Processor',fg_rank,
22257 !c     &' has received correlation contribution from processor',fg_rank+1,
22258 !c     & ' msglen=',msglen,' nbytes=',nbytes
22259 !c        write (*,*) 'The received BUFFER array:'
22260 !c        do i=1,max_cont
22261 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22262 !c        enddo
22263         if (msglen.eq.msglen1) then
22264           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22265         else if (msglen.eq.msglen2)  then
22266           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22267           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22268         else
22269           write (iout,*) &
22270       'ERROR!!!! message length changed while processing correlations.'
22271           write (*,*) &
22272       'ERROR!!!! message length changed while processing correlations.'
22273           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22274         endif ! msglen.eq.msglen1
22275       endif ! fg_rank.lt.nfgtasks-1
22276       if (ldone) goto 30
22277       ldone=.true.
22278       goto 10
22279    30 continue
22280 #endif
22281       if (lprn) then
22282         write (iout,'(a)') 'Contact function values:'
22283         do i=nnt_molec(2),nct_molec(2)-1
22284           write (iout,'(2i3,50(1x,i2,f5.2))') &
22285          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22286          j=1,num_cont_hb(i))
22287         enddo
22288       endif
22289       ecorr=0.0D0
22290       ecorr3=0.0d0
22291 !C Remove the loop below after debugging !!!
22292 !      do i=nnt_molec(2),nct_molec(2)
22293 !        do j=1,3
22294 !          gradcorr_nucl(j,i)=0.0D0
22295 !          gradxorr_nucl(j,i)=0.0D0
22296 !          gradcorr3_nucl(j,i)=0.0D0
22297 !          gradxorr3_nucl(j,i)=0.0D0
22298 !        enddo
22299 !      enddo
22300 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22301 !C Calculate the local-electrostatic correlation terms
22302       do i=iatsc_s_nucl,iatsc_e_nucl
22303         i1=i+1
22304         num_conti=num_cont_hb(i)
22305         num_conti1=num_cont_hb(i+1)
22306 !        print *,i,num_conti,num_conti1
22307         do jj=1,num_conti
22308           j=jcont_hb(jj,i)
22309           do kk=1,num_conti1
22310             j1=jcont_hb(kk,i1)
22311 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22312 !c     &         ' jj=',jj,' kk=',kk
22313             if (j1.eq.j+1 .or. j1.eq.j-1) then
22314 !C
22315 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22316 !C The system gains extra energy.
22317 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22318 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22319 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22320 !C
22321               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22322               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22323                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22324               n_corr=n_corr+1
22325             else if (j1.eq.j) then
22326 !C
22327 !C Contacts I-J and I-(J+1) occur simultaneously.
22328 !C The system loses extra energy.
22329 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22330 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22331 !C Need to implement full formulas 32 from Liwo et al., 1998.
22332 !C
22333 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22334 !c     &         ' jj=',jj,' kk=',kk
22335               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22336             endif
22337           enddo ! kk
22338           do kk=1,num_conti
22339             j1=jcont_hb(kk,i)
22340 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22341 !c     &         ' jj=',jj,' kk=',kk
22342             if (j1.eq.j+1) then
22343 !C Contacts I-J and (I+1)-J occur simultaneously.
22344 !C The system loses extra energy.
22345               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22346             endif ! j1==j+1
22347           enddo ! kk
22348         enddo ! jj
22349       enddo ! i
22350       return
22351       end subroutine multibody_hb_nucl
22352 !-----------------------------------------------------------
22353       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22354 !      implicit real*8 (a-h,o-z)
22355 !      include 'DIMENSIONS'
22356 !      include 'COMMON.IOUNITS'
22357 !      include 'COMMON.DERIV'
22358 !      include 'COMMON.INTERACT'
22359 !      include 'COMMON.CONTACTS'
22360       real(kind=8),dimension(3) :: gx,gx1
22361       logical :: lprn
22362 !el local variables
22363       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22364       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22365                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22366                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22367                    rlocshield
22368
22369       lprn=.false.
22370       eij=facont_hb(jj,i)
22371       ekl=facont_hb(kk,k)
22372       ees0pij=ees0p(jj,i)
22373       ees0pkl=ees0p(kk,k)
22374       ees0mij=ees0m(jj,i)
22375       ees0mkl=ees0m(kk,k)
22376       ekont=eij*ekl
22377       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22378 !      print *,"ehbcorr_nucl",ekont,ees
22379 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22380 !C Following 4 lines for diagnostics.
22381 !cd    ees0pkl=0.0D0
22382 !cd    ees0pij=1.0D0
22383 !cd    ees0mkl=0.0D0
22384 !cd    ees0mij=1.0D0
22385 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22386 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22387 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22388 !C Calculate the multi-body contribution to energy.
22389 !      ecorr_nucl=ecorr_nucl+ekont*ees
22390 !C Calculate multi-body contributions to the gradient.
22391       coeffpees0pij=coeffp*ees0pij
22392       coeffmees0mij=coeffm*ees0mij
22393       coeffpees0pkl=coeffp*ees0pkl
22394       coeffmees0mkl=coeffm*ees0mkl
22395       do ll=1,3
22396         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22397        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22398        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22399         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22400         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22401         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22402         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22403         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22404         coeffmees0mij*gacontm_hb1(ll,kk,k))
22405         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22406         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22407         coeffmees0mij*gacontm_hb2(ll,kk,k))
22408         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22409           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22410           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22411         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22412         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22413         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22414           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22415           coeffmees0mij*gacontm_hb3(ll,kk,k))
22416         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22417         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22418         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22419         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22420         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22421         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22422       enddo
22423       ehbcorr_nucl=ekont*ees
22424       return
22425       end function ehbcorr_nucl
22426 !-------------------------------------------------------------------------
22427
22428      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22429 !      implicit real*8 (a-h,o-z)
22430 !      include 'DIMENSIONS'
22431 !      include 'COMMON.IOUNITS'
22432 !      include 'COMMON.DERIV'
22433 !      include 'COMMON.INTERACT'
22434 !      include 'COMMON.CONTACTS'
22435       real(kind=8),dimension(3) :: gx,gx1
22436       logical :: lprn
22437 !el local variables
22438       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22439       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22440                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22441                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22442                    rlocshield
22443
22444       lprn=.false.
22445       eij=facont_hb(jj,i)
22446       ekl=facont_hb(kk,k)
22447       ees0pij=ees0p(jj,i)
22448       ees0pkl=ees0p(kk,k)
22449       ees0mij=ees0m(jj,i)
22450       ees0mkl=ees0m(kk,k)
22451       ekont=eij*ekl
22452       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22453 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22454 !C Following 4 lines for diagnostics.
22455 !cd    ees0pkl=0.0D0
22456 !cd    ees0pij=1.0D0
22457 !cd    ees0mkl=0.0D0
22458 !cd    ees0mij=1.0D0
22459 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22460 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22461 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22462 !C Calculate the multi-body contribution to energy.
22463 !      ecorr=ecorr+ekont*ees
22464 !C Calculate multi-body contributions to the gradient.
22465       coeffpees0pij=coeffp*ees0pij
22466       coeffmees0mij=coeffm*ees0mij
22467       coeffpees0pkl=coeffp*ees0pkl
22468       coeffmees0mkl=coeffm*ees0mkl
22469       do ll=1,3
22470         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22471        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22472        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22473         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22474         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22475         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22476         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22477         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22478         coeffmees0mij*gacontm_hb1(ll,kk,k))
22479         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22480         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22481         coeffmees0mij*gacontm_hb2(ll,kk,k))
22482         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22483           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22484           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22485         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22486         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22487         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22488           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22489           coeffmees0mij*gacontm_hb3(ll,kk,k))
22490         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22491         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22492         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22493         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22494         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22495         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22496       enddo
22497       ehbcorr3_nucl=ekont*ees
22498       return
22499       end function ehbcorr3_nucl
22500 #ifdef MPI
22501       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22502       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22503       real(kind=8):: buffer(dimen1,dimen2)
22504       num_kont=num_cont_hb(atom)
22505       do i=1,num_kont
22506         do k=1,8
22507           do j=1,3
22508             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22509           enddo ! j
22510         enddo ! k
22511         buffer(i,indx+25)=facont_hb(i,atom)
22512         buffer(i,indx+26)=ees0p(i,atom)
22513         buffer(i,indx+27)=ees0m(i,atom)
22514         buffer(i,indx+28)=d_cont(i,atom)
22515         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22516       enddo ! i
22517       buffer(1,indx+30)=dfloat(num_kont)
22518       return
22519       end subroutine pack_buffer
22520 !c------------------------------------------------------------------------------
22521       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22522       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22523       real(kind=8):: buffer(dimen1,dimen2)
22524 !      double precision zapas
22525 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22526 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22527 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22528 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22529       num_kont=buffer(1,indx+30)
22530       num_kont_old=num_cont_hb(atom)
22531       num_cont_hb(atom)=num_kont+num_kont_old
22532       do i=1,num_kont
22533         ii=i+num_kont_old
22534         do k=1,8
22535           do j=1,3
22536             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22537           enddo ! j
22538         enddo ! k
22539         facont_hb(ii,atom)=buffer(i,indx+25)
22540         ees0p(ii,atom)=buffer(i,indx+26)
22541         ees0m(ii,atom)=buffer(i,indx+27)
22542         d_cont(i,atom)=buffer(i,indx+28)
22543         jcont_hb(ii,atom)=buffer(i,indx+29)
22544       enddo ! i
22545       return
22546       end subroutine unpack_buffer
22547 !c------------------------------------------------------------------------------
22548 #endif
22549       subroutine ecatcat(ecationcation)
22550         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22551         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22552         r7,r4,ecationcation,k0,rcal
22553         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22554         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22555         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22556         gg,r
22557
22558         ecationcation=0.0d0
22559         if (nres_molec(5).eq.0) return
22560         rcat0=3.472
22561         epscalc=0.05
22562         r06 = rcat0**6
22563         r012 = r06**2
22564         k0 = 332.0*(2.0*2.0)/80.0
22565         itmp=0
22566
22567         do i=1,4
22568         itmp=itmp+nres_molec(i)
22569         enddo
22570 !        write(iout,*) "itmp",itmp
22571         do i=itmp+1,itmp+nres_molec(5)-1
22572
22573         xi=c(1,i)
22574         yi=c(2,i)
22575         zi=c(3,i)
22576
22577           xi=mod(xi,boxxsize)
22578           if (xi.lt.0) xi=xi+boxxsize
22579           yi=mod(yi,boxysize)
22580           if (yi.lt.0) yi=yi+boxysize
22581           zi=mod(zi,boxzsize)
22582           if (zi.lt.0) zi=zi+boxzsize
22583
22584           do j=i+1,itmp+nres_molec(5)
22585 !           print *,i,j,'catcat'
22586            xj=c(1,j)
22587            yj=c(2,j)
22588            zj=c(3,j)
22589           xj=dmod(xj,boxxsize)
22590           if (xj.lt.0) xj=xj+boxxsize
22591           yj=dmod(yj,boxysize)
22592           if (yj.lt.0) yj=yj+boxysize
22593           zj=dmod(zj,boxzsize)
22594           if (zj.lt.0) zj=zj+boxzsize
22595 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22596       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22597       xj_safe=xj
22598       yj_safe=yj
22599       zj_safe=zj
22600       subchap=0
22601       do xshift=-1,1
22602       do yshift=-1,1
22603       do zshift=-1,1
22604           xj=xj_safe+xshift*boxxsize
22605           yj=yj_safe+yshift*boxysize
22606           zj=zj_safe+zshift*boxzsize
22607           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22608           if(dist_temp.lt.dist_init) then
22609             dist_init=dist_temp
22610             xj_temp=xj
22611             yj_temp=yj
22612             zj_temp=zj
22613             subchap=1
22614           endif
22615        enddo
22616        enddo
22617        enddo
22618        if (subchap.eq.1) then
22619           xj=xj_temp-xi
22620           yj=yj_temp-yi
22621           zj=zj_temp-zi
22622        else
22623           xj=xj_safe-xi
22624           yj=yj_safe-yi
22625           zj=zj_safe-zi
22626        endif
22627        rcal =xj**2+yj**2+zj**2
22628         ract=sqrt(rcal)
22629 !        rcat0=3.472
22630 !        epscalc=0.05
22631 !        r06 = rcat0**6
22632 !        r012 = r06**2
22633 !        k0 = 332*(2*2)/80
22634         Evan1cat=epscalc*(r012/rcal**6)
22635         Evan2cat=epscalc*2*(r06/rcal**3)
22636         Eeleccat=k0/ract
22637         r7 = rcal**7
22638         r4 = rcal**4
22639         r(1)=xj
22640         r(2)=yj
22641         r(3)=zj
22642         do k=1,3
22643           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22644           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22645           dEeleccat(k)=-k0*r(k)/ract**3
22646         enddo
22647         do k=1,3
22648           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22649           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22650           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22651         enddo
22652
22653 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22654         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22655        enddo
22656        enddo
22657        return
22658        end subroutine ecatcat
22659 !---------------------------------------------------------------------------
22660        subroutine ecat_prot(ecation_prot)
22661        integer i,j,k,subchap,itmp,inum
22662         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22663         r7,r4,ecationcation
22664         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22665         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22666         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22667         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22668         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22669         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22670         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22671         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22672         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22673         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22674         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22675         ndiv,ndivi
22676         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22677         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22678         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22679         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22680         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22681         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22682         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22683         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22684         dEvan1Cat
22685         real(kind=8),dimension(6) :: vcatprm
22686         ecation_prot=0.0d0
22687 ! first lets calculate interaction with peptide groups
22688         if (nres_molec(5).eq.0) return
22689         itmp=0
22690         do i=1,4
22691         itmp=itmp+nres_molec(i)
22692         enddo
22693 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22694         do i=ibond_start,ibond_end
22695 !         cycle
22696          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22697         xi=0.5d0*(c(1,i)+c(1,i+1))
22698         yi=0.5d0*(c(2,i)+c(2,i+1))
22699         zi=0.5d0*(c(3,i)+c(3,i+1))
22700           xi=mod(xi,boxxsize)
22701           if (xi.lt.0) xi=xi+boxxsize
22702           yi=mod(yi,boxysize)
22703           if (yi.lt.0) yi=yi+boxysize
22704           zi=mod(zi,boxzsize)
22705           if (zi.lt.0) zi=zi+boxzsize
22706
22707          do j=itmp+1,itmp+nres_molec(5)
22708 !           print *,"WTF",itmp,j,i
22709 ! all parameters were for Ca2+ to approximate single charge divide by two
22710          ndiv=1.0
22711          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22712          wconst=78*ndiv
22713         wdip =1.092777950857032D2
22714         wdip=wdip/wconst
22715         wmodquad=-2.174122713004870D4
22716         wmodquad=wmodquad/wconst
22717         wquad1 = 3.901232068562804D1
22718         wquad1=wquad1/wconst
22719         wquad2 = 3
22720         wquad2=wquad2/wconst
22721         wvan1 = 0.1
22722         wvan2 = 6
22723 !        itmp=0
22724
22725            xj=c(1,j)
22726            yj=c(2,j)
22727            zj=c(3,j)
22728           xj=dmod(xj,boxxsize)
22729           if (xj.lt.0) xj=xj+boxxsize
22730           yj=dmod(yj,boxysize)
22731           if (yj.lt.0) yj=yj+boxysize
22732           zj=dmod(zj,boxzsize)
22733           if (zj.lt.0) zj=zj+boxzsize
22734       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22735       xj_safe=xj
22736       yj_safe=yj
22737       zj_safe=zj
22738       subchap=0
22739       do xshift=-1,1
22740       do yshift=-1,1
22741       do zshift=-1,1
22742           xj=xj_safe+xshift*boxxsize
22743           yj=yj_safe+yshift*boxysize
22744           zj=zj_safe+zshift*boxzsize
22745           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22746           if(dist_temp.lt.dist_init) then
22747             dist_init=dist_temp
22748             xj_temp=xj
22749             yj_temp=yj
22750             zj_temp=zj
22751             subchap=1
22752           endif
22753        enddo
22754        enddo
22755        enddo
22756        if (subchap.eq.1) then
22757           xj=xj_temp-xi
22758           yj=yj_temp-yi
22759           zj=zj_temp-zi
22760        else
22761           xj=xj_safe-xi
22762           yj=yj_safe-yi
22763           zj=zj_safe-zi
22764        endif
22765 !       enddo
22766 !       enddo
22767        rcpm = sqrt(xj**2+yj**2+zj**2)
22768        drcp_norm(1)=xj/rcpm
22769        drcp_norm(2)=yj/rcpm
22770        drcp_norm(3)=zj/rcpm
22771        dcmag=0.0
22772        do k=1,3
22773        dcmag=dcmag+dc(k,i)**2
22774        enddo
22775        dcmag=dsqrt(dcmag)
22776        do k=1,3
22777          myd_norm(k)=dc(k,i)/dcmag
22778        enddo
22779         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22780         drcp_norm(3)*myd_norm(3)
22781         rsecp = rcpm**2
22782         Ir = 1.0d0/rcpm
22783         Irsecp = 1.0d0/rsecp
22784         Irthrp = Irsecp/rcpm
22785         Irfourp = Irthrp/rcpm
22786         Irfiftp = Irfourp/rcpm
22787         Irsistp=Irfiftp/rcpm
22788         Irseven=Irsistp/rcpm
22789         Irtwelv=Irsistp*Irsistp
22790         Irthir=Irtwelv/rcpm
22791         sin2thet = (1-costhet*costhet)
22792         sinthet=sqrt(sin2thet)
22793         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22794              *sin2thet
22795         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22796              2*wvan2**6*Irsistp)
22797         ecation_prot = ecation_prot+E1+E2
22798 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22799         dE1dr = -2*costhet*wdip*Irthrp-&
22800          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22801         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22802           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22803         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22804         do k=1,3
22805           drdpep(k) = -drcp_norm(k)
22806           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22807           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22808           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22809           dEddci(k) = dEdcos*dcosddci(k)
22810         enddo
22811         do k=1,3
22812         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22813         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22814         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22815         enddo
22816        enddo ! j
22817        enddo ! i
22818 !------------------------------------------sidechains
22819 !        do i=1,nres_molec(1)
22820         do i=ibond_start,ibond_end
22821          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22822 !         cycle
22823 !        print *,i,ecation_prot
22824         xi=(c(1,i+nres))
22825         yi=(c(2,i+nres))
22826         zi=(c(3,i+nres))
22827           xi=mod(xi,boxxsize)
22828           if (xi.lt.0) xi=xi+boxxsize
22829           yi=mod(yi,boxysize)
22830           if (yi.lt.0) yi=yi+boxysize
22831           zi=mod(zi,boxzsize)
22832           if (zi.lt.0) zi=zi+boxzsize
22833           do k=1,3
22834             cm1(k)=dc(k,i+nres)
22835           enddo
22836            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22837          do j=itmp+1,itmp+nres_molec(5)
22838          ndiv=1.0
22839          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22840
22841            xj=c(1,j)
22842            yj=c(2,j)
22843            zj=c(3,j)
22844           xj=dmod(xj,boxxsize)
22845           if (xj.lt.0) xj=xj+boxxsize
22846           yj=dmod(yj,boxysize)
22847           if (yj.lt.0) yj=yj+boxysize
22848           zj=dmod(zj,boxzsize)
22849           if (zj.lt.0) zj=zj+boxzsize
22850       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22851       xj_safe=xj
22852       yj_safe=yj
22853       zj_safe=zj
22854       subchap=0
22855       do xshift=-1,1
22856       do yshift=-1,1
22857       do zshift=-1,1
22858           xj=xj_safe+xshift*boxxsize
22859           yj=yj_safe+yshift*boxysize
22860           zj=zj_safe+zshift*boxzsize
22861           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22862           if(dist_temp.lt.dist_init) then
22863             dist_init=dist_temp
22864             xj_temp=xj
22865             yj_temp=yj
22866             zj_temp=zj
22867             subchap=1
22868           endif
22869        enddo
22870        enddo
22871        enddo
22872        if (subchap.eq.1) then
22873           xj=xj_temp-xi
22874           yj=yj_temp-yi
22875           zj=zj_temp-zi
22876        else
22877           xj=xj_safe-xi
22878           yj=yj_safe-yi
22879           zj=zj_safe-zi
22880        endif
22881 !       enddo
22882 !       enddo
22883 ! 15- Glu 16-Asp
22884          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
22885          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
22886          (itype(i,1).eq.25))) then
22887             if(itype(i,1).eq.16) then
22888             inum=1
22889             else
22890             inum=2
22891             endif
22892             do k=1,6
22893             vcatprm(k)=catprm(k,inum)
22894             enddo
22895             dASGL=catprm(7,inum)
22896 !             do k=1,3
22897 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22898                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
22899                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
22900                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
22901
22902 !                valpha(k)=c(k,i)
22903 !                vcat(k)=c(k,j)
22904                 if (subchap.eq.1) then
22905                  vcat(1)=xj_temp
22906                  vcat(2)=yj_temp
22907                  vcat(3)=zj_temp
22908                  else
22909                 vcat(1)=xj_safe
22910                 vcat(2)=yj_safe
22911                 vcat(3)=zj_safe
22912                  endif
22913                 valpha(1)=xi-c(1,i+nres)+c(1,i)
22914                 valpha(2)=yi-c(2,i+nres)+c(2,i)
22915                 valpha(3)=zi-c(3,i+nres)+c(3,i)
22916
22917 !              enddo
22918         do k=1,3
22919           dx(k) = vcat(k)-vcm(k)
22920         enddo
22921         do k=1,3
22922           v1(k)=(vcm(k)-valpha(k))
22923           v2(k)=(vcat(k)-valpha(k))
22924         enddo
22925         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22926         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22927         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22928
22929 !  The weights of the energy function calculated from
22930 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22931           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22932             ndivi=0.5
22933           else
22934             ndivi=1.0
22935           endif
22936          ndiv=1.0
22937          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22938
22939         wh2o=78*ndivi*ndiv
22940         wc = vcatprm(1)
22941         wc=wc/wh2o
22942         wdip =vcatprm(2)
22943         wdip=wdip/wh2o
22944         wquad1 =vcatprm(3)
22945         wquad1=wquad1/wh2o
22946         wquad2 = vcatprm(4)
22947         wquad2=wquad2/wh2o
22948         wquad2p = 1.0d0-wquad2
22949         wvan1 = vcatprm(5)
22950         wvan2 =vcatprm(6)
22951         opt = dx(1)**2+dx(2)**2
22952         rsecp = opt+dx(3)**2
22953         rs = sqrt(rsecp)
22954         rthrp = rsecp*rs
22955         rfourp = rthrp*rs
22956         rsixp = rfourp*rsecp
22957         reight=rsixp*rsecp
22958         Ir = 1.0d0/rs
22959         Irsecp = 1.0d0/rsecp
22960         Irthrp = Irsecp/rs
22961         Irfourp = Irthrp/rs
22962         Irsixp = 1.0d0/rsixp
22963         Ireight=1.0d0/reight
22964         Irtw=Irsixp*Irsixp
22965         Irthir=Irtw/rs
22966         Irfourt=Irthir/rs
22967         opt1 = (4*rs*dx(3)*wdip)
22968         opt2 = 6*rsecp*wquad1*opt
22969         opt3 = wquad1*wquad2p*Irsixp
22970         opt4 = (wvan1*wvan2**12)
22971         opt5 = opt4*12*Irfourt
22972         opt6 = 2*wvan1*wvan2**6
22973         opt7 = 6*opt6*Ireight
22974         opt8 = wdip/v1m
22975         opt10 = wdip/v2m
22976         opt11 = (rsecp*v2m)**2
22977         opt12 = (rsecp*v1m)**2
22978         opt14 = (v1m*v2m*rsecp)**2
22979         opt15 = -wquad1/v2m**2
22980         opt16 = (rthrp*(v1m*v2m)**2)**2
22981         opt17 = (v1m**2*rthrp)**2
22982         opt18 = -wquad1/rthrp
22983         opt19 = (v1m**2*v2m**2)**2
22984         Ec = wc*Ir
22985         do k=1,3
22986           dEcCat(k) = -(dx(k)*wc)*Irthrp
22987           dEcCm(k)=(dx(k)*wc)*Irthrp
22988           dEcCalp(k)=0.0d0
22989         enddo
22990         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22991         do k=1,3
22992           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22993                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22994           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22995                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22996           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22997                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22998                       *v1dpv2)/opt14
22999         enddo
23000         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23001         do k=1,3
23002           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23003                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23004                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23005           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23006                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23007                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23008           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23009                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23010                         v1dpv2**2)/opt19
23011         enddo
23012         Equad2=wquad1*wquad2p*Irthrp
23013         do k=1,3
23014           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23015           dEquad2Cm(k)=3*dx(k)*rs*opt3
23016           dEquad2Calp(k)=0.0d0
23017         enddo
23018         Evan1=opt4*Irtw
23019         do k=1,3
23020           dEvan1Cat(k)=-dx(k)*opt5
23021           dEvan1Cm(k)=dx(k)*opt5
23022           dEvan1Calp(k)=0.0d0
23023         enddo
23024         Evan2=-opt6*Irsixp
23025         do k=1,3
23026           dEvan2Cat(k)=dx(k)*opt7
23027           dEvan2Cm(k)=-dx(k)*opt7
23028           dEvan2Calp(k)=0.0d0
23029         enddo
23030         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23031 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23032
23033         do k=1,3
23034           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23035                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23036 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23037           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23038                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23039           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23040                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23041         enddo
23042             dscmag = 0.0d0
23043             do k=1,3
23044               dscvec(k) = dc(k,i+nres)
23045               dscmag = dscmag+dscvec(k)*dscvec(k)
23046             enddo
23047             dscmag3 = dscmag
23048             dscmag = sqrt(dscmag)
23049             dscmag3 = dscmag3*dscmag
23050             constA = 1.0d0+dASGL/dscmag
23051             constB = 0.0d0
23052             do k=1,3
23053               constB = constB+dscvec(k)*dEtotalCm(k)
23054             enddo
23055             constB = constB*dASGL/dscmag3
23056             do k=1,3
23057               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23058               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23059                constA*dEtotalCm(k)-constB*dscvec(k)
23060 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23061               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23062               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23063              enddo
23064         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23065            if(itype(i,1).eq.14) then
23066             inum=3
23067             else
23068             inum=4
23069             endif
23070             do k=1,6
23071             vcatprm(k)=catprm(k,inum)
23072             enddo
23073             dASGL=catprm(7,inum)
23074 !             do k=1,3
23075 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23076 !                valpha(k)=c(k,i)
23077 !                vcat(k)=c(k,j)
23078 !              enddo
23079                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23080                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23081                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23082                 if (subchap.eq.1) then
23083                  vcat(1)=xj_temp
23084                  vcat(2)=yj_temp
23085                  vcat(3)=zj_temp
23086                  else
23087                 vcat(1)=xj_safe
23088                 vcat(2)=yj_safe
23089                 vcat(3)=zj_safe
23090                 endif
23091                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23092                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23093                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23094
23095
23096         do k=1,3
23097           dx(k) = vcat(k)-vcm(k)
23098         enddo
23099         do k=1,3
23100           v1(k)=(vcm(k)-valpha(k))
23101           v2(k)=(vcat(k)-valpha(k))
23102         enddo
23103         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23104         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23105         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23106 !  The weights of the energy function calculated from
23107 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23108          ndiv=1.0
23109          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23110
23111         wh2o=78*ndiv
23112         wdip =vcatprm(2)
23113         wdip=wdip/wh2o
23114         wquad1 =vcatprm(3)
23115         wquad1=wquad1/wh2o
23116         wquad2 = vcatprm(4)
23117         wquad2=wquad2/wh2o
23118         wquad2p = 1-wquad2
23119         wvan1 = vcatprm(5)
23120         wvan2 =vcatprm(6)
23121         opt = dx(1)**2+dx(2)**2
23122         rsecp = opt+dx(3)**2
23123         rs = sqrt(rsecp)
23124         rthrp = rsecp*rs
23125         rfourp = rthrp*rs
23126         rsixp = rfourp*rsecp
23127         reight=rsixp*rsecp
23128         Ir = 1.0d0/rs
23129         Irsecp = 1/rsecp
23130         Irthrp = Irsecp/rs
23131         Irfourp = Irthrp/rs
23132         Irsixp = 1/rsixp
23133         Ireight=1/reight
23134         Irtw=Irsixp*Irsixp
23135         Irthir=Irtw/rs
23136         Irfourt=Irthir/rs
23137         opt1 = (4*rs*dx(3)*wdip)
23138         opt2 = 6*rsecp*wquad1*opt
23139         opt3 = wquad1*wquad2p*Irsixp
23140         opt4 = (wvan1*wvan2**12)
23141         opt5 = opt4*12*Irfourt
23142         opt6 = 2*wvan1*wvan2**6
23143         opt7 = 6*opt6*Ireight
23144         opt8 = wdip/v1m
23145         opt10 = wdip/v2m
23146         opt11 = (rsecp*v2m)**2
23147         opt12 = (rsecp*v1m)**2
23148         opt14 = (v1m*v2m*rsecp)**2
23149         opt15 = -wquad1/v2m**2
23150         opt16 = (rthrp*(v1m*v2m)**2)**2
23151         opt17 = (v1m**2*rthrp)**2
23152         opt18 = -wquad1/rthrp
23153         opt19 = (v1m**2*v2m**2)**2
23154         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23155         do k=1,3
23156           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23157                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23158          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23159                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23160           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23161                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23162                       *v1dpv2)/opt14
23163         enddo
23164         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23165         do k=1,3
23166           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23167                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23168                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23169           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23170                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23171                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23172           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23173                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23174                         v1dpv2**2)/opt19
23175         enddo
23176         Equad2=wquad1*wquad2p*Irthrp
23177         do k=1,3
23178           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23179           dEquad2Cm(k)=3*dx(k)*rs*opt3
23180           dEquad2Calp(k)=0.0d0
23181         enddo
23182         Evan1=opt4*Irtw
23183         do k=1,3
23184           dEvan1Cat(k)=-dx(k)*opt5
23185           dEvan1Cm(k)=dx(k)*opt5
23186           dEvan1Calp(k)=0.0d0
23187         enddo
23188         Evan2=-opt6*Irsixp
23189         do k=1,3
23190           dEvan2Cat(k)=dx(k)*opt7
23191           dEvan2Cm(k)=-dx(k)*opt7
23192           dEvan2Calp(k)=0.0d0
23193         enddo
23194          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23195         do k=1,3
23196           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23197                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23198           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23199                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23200           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23201                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23202         enddo
23203             dscmag = 0.0d0
23204             do k=1,3
23205               dscvec(k) = c(k,i+nres)-c(k,i)
23206 ! TU SPRAWDZ???
23207 !              dscvec(1) = xj
23208 !              dscvec(2) = yj
23209 !              dscvec(3) = zj
23210
23211               dscmag = dscmag+dscvec(k)*dscvec(k)
23212             enddo
23213             dscmag3 = dscmag
23214             dscmag = sqrt(dscmag)
23215             dscmag3 = dscmag3*dscmag
23216             constA = 1+dASGL/dscmag
23217             constB = 0.0d0
23218             do k=1,3
23219               constB = constB+dscvec(k)*dEtotalCm(k)
23220             enddo
23221             constB = constB*dASGL/dscmag3
23222             do k=1,3
23223               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23224               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23225                constA*dEtotalCm(k)-constB*dscvec(k)
23226               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23227               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23228              enddo
23229            else
23230             rcal = 0.0d0
23231             do k=1,3
23232 !              r(k) = c(k,j)-c(k,i+nres)
23233               r(1) = xj
23234               r(2) = yj
23235               r(3) = zj
23236               rcal = rcal+r(k)*r(k)
23237             enddo
23238             ract=sqrt(rcal)
23239             rocal=1.5
23240             epscalc=0.2
23241             r0p=0.5*(rocal+sig0(itype(i,1)))
23242             r06 = r0p**6
23243             r012 = r06*r06
23244             Evan1=epscalc*(r012/rcal**6)
23245             Evan2=epscalc*2*(r06/rcal**3)
23246             r4 = rcal**4
23247             r7 = rcal**7
23248             do k=1,3
23249               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23250               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23251             enddo
23252             do k=1,3
23253               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23254             enddo
23255                  ecation_prot = ecation_prot+ Evan1+Evan2
23256             do  k=1,3
23257                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23258                dEtotalCm(k)
23259               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23260               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23261              enddo
23262          endif ! 13-16 residues
23263        enddo !j
23264        enddo !i
23265        return
23266        end subroutine ecat_prot
23267
23268 !----------------------------------------------------------------------------
23269 !-----------------------------------------------------------------------------
23270 !-----------------------------------------------------------------------------
23271       subroutine eprot_sc_base(escbase)
23272       use calc_data
23273 !      implicit real*8 (a-h,o-z)
23274 !      include 'DIMENSIONS'
23275 !      include 'COMMON.GEO'
23276 !      include 'COMMON.VAR'
23277 !      include 'COMMON.LOCAL'
23278 !      include 'COMMON.CHAIN'
23279 !      include 'COMMON.DERIV'
23280 !      include 'COMMON.NAMES'
23281 !      include 'COMMON.INTERACT'
23282 !      include 'COMMON.IOUNITS'
23283 !      include 'COMMON.CALC'
23284 !      include 'COMMON.CONTROL'
23285 !      include 'COMMON.SBRIDGE'
23286       logical :: lprn
23287 !el local variables
23288       integer :: iint,itypi,itypi1,itypj,subchap
23289       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23290       real(kind=8) :: evdw,sig0ij
23291       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23292                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23293                     sslipi,sslipj,faclip
23294       integer :: ii
23295       real(kind=8) :: fracinbuf
23296        real (kind=8) :: escbase
23297        real (kind=8),dimension(4):: ener
23298        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23299        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23300         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23301         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23302         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23303         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23304         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23305         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23306        real(kind=8),dimension(3,2)::chead,erhead_tail
23307        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23308        integer troll
23309        eps_out=80.0d0
23310        escbase=0.0d0
23311 !       do i=1,nres_molec(1)
23312         do i=ibond_start,ibond_end
23313         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23314         itypi  = itype(i,1)
23315         dxi    = dc_norm(1,nres+i)
23316         dyi    = dc_norm(2,nres+i)
23317         dzi    = dc_norm(3,nres+i)
23318         dsci_inv = vbld_inv(i+nres)
23319         xi=c(1,nres+i)
23320         yi=c(2,nres+i)
23321         zi=c(3,nres+i)
23322         xi=mod(xi,boxxsize)
23323          if (xi.lt.0) xi=xi+boxxsize
23324         yi=mod(yi,boxysize)
23325          if (yi.lt.0) yi=yi+boxysize
23326         zi=mod(zi,boxzsize)
23327          if (zi.lt.0) zi=zi+boxzsize
23328          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23329            itypj= itype(j,2)
23330            if (itype(j,2).eq.ntyp1_molec(2))cycle
23331            xj=c(1,j+nres)
23332            yj=c(2,j+nres)
23333            zj=c(3,j+nres)
23334            xj=dmod(xj,boxxsize)
23335            if (xj.lt.0) xj=xj+boxxsize
23336            yj=dmod(yj,boxysize)
23337            if (yj.lt.0) yj=yj+boxysize
23338            zj=dmod(zj,boxzsize)
23339            if (zj.lt.0) zj=zj+boxzsize
23340           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23341           xj_safe=xj
23342           yj_safe=yj
23343           zj_safe=zj
23344           subchap=0
23345
23346           do xshift=-1,1
23347           do yshift=-1,1
23348           do zshift=-1,1
23349           xj=xj_safe+xshift*boxxsize
23350           yj=yj_safe+yshift*boxysize
23351           zj=zj_safe+zshift*boxzsize
23352           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23353           if(dist_temp.lt.dist_init) then
23354             dist_init=dist_temp
23355             xj_temp=xj
23356             yj_temp=yj
23357             zj_temp=zj
23358             subchap=1
23359           endif
23360           enddo
23361           enddo
23362           enddo
23363           if (subchap.eq.1) then
23364           xj=xj_temp-xi
23365           yj=yj_temp-yi
23366           zj=zj_temp-zi
23367           else
23368           xj=xj_safe-xi
23369           yj=yj_safe-yi
23370           zj=zj_safe-zi
23371           endif
23372           dxj = dc_norm( 1, nres+j )
23373           dyj = dc_norm( 2, nres+j )
23374           dzj = dc_norm( 3, nres+j )
23375 !          print *,i,j,itypi,itypj
23376           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23377           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23378 !          d1i=0.0d0
23379 !          d1j=0.0d0
23380 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23381 ! Gay-berne var's
23382           sig0ij = sigma_scbase( itypi,itypj )
23383           chi1   = chi_scbase( itypi, itypj,1 )
23384           chi2   = chi_scbase( itypi, itypj,2 )
23385 !          chi1=0.0d0
23386 !          chi2=0.0d0
23387           chi12  = chi1 * chi2
23388           chip1  = chipp_scbase( itypi, itypj,1 )
23389           chip2  = chipp_scbase( itypi, itypj,2 )
23390 !          chip1=0.0d0
23391 !          chip2=0.0d0
23392           chip12 = chip1 * chip2
23393 ! not used by momo potential, but needed by sc_angular which is shared
23394 ! by all energy_potential subroutines
23395           alf1   = 0.0d0
23396           alf2   = 0.0d0
23397           alf12  = 0.0d0
23398           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23399 !       a12sq = a12sq * a12sq
23400 ! charge of amino acid itypi is...
23401           chis1 = chis_scbase(itypi,itypj,1)
23402           chis2 = chis_scbase(itypi,itypj,2)
23403           chis12 = chis1 * chis2
23404           sig1 = sigmap1_scbase(itypi,itypj)
23405           sig2 = sigmap2_scbase(itypi,itypj)
23406 !       write (*,*) "sig1 = ", sig1
23407 !       write (*,*) "sig2 = ", sig2
23408 ! alpha factors from Fcav/Gcav
23409           b1 = alphasur_scbase(1,itypi,itypj)
23410 !          b1=0.0d0
23411           b2 = alphasur_scbase(2,itypi,itypj)
23412           b3 = alphasur_scbase(3,itypi,itypj)
23413           b4 = alphasur_scbase(4,itypi,itypj)
23414 ! used to determine whether we want to do quadrupole calculations
23415 ! used by Fgb
23416        eps_in = epsintab_scbase(itypi,itypj)
23417        if (eps_in.eq.0.0) eps_in=1.0
23418        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23419 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23420 !-------------------------------------------------------------------
23421 ! tail location and distance calculations
23422        DO k = 1,3
23423 ! location of polar head is computed by taking hydrophobic centre
23424 ! and moving by a d1 * dc_norm vector
23425 ! see unres publications for very informative images
23426         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23427         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23428 ! distance
23429 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23430 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23431         Rhead_distance(k) = chead(k,2) - chead(k,1)
23432        END DO
23433 ! pitagoras (root of sum of squares)
23434        Rhead = dsqrt( &
23435           (Rhead_distance(1)*Rhead_distance(1)) &
23436         + (Rhead_distance(2)*Rhead_distance(2)) &
23437         + (Rhead_distance(3)*Rhead_distance(3)))
23438 !-------------------------------------------------------------------
23439 ! zero everything that should be zero'ed
23440        evdwij = 0.0d0
23441        ECL = 0.0d0
23442        Elj = 0.0d0
23443        Equad = 0.0d0
23444        Epol = 0.0d0
23445        Fcav=0.0d0
23446        eheadtail = 0.0d0
23447        dGCLdOM1 = 0.0d0
23448        dGCLdOM2 = 0.0d0
23449        dGCLdOM12 = 0.0d0
23450        dPOLdOM1 = 0.0d0
23451        dPOLdOM2 = 0.0d0
23452           Fcav = 0.0d0
23453           dFdR = 0.0d0
23454           dCAVdOM1  = 0.0d0
23455           dCAVdOM2  = 0.0d0
23456           dCAVdOM12 = 0.0d0
23457           dscj_inv = vbld_inv(j+nres)
23458 !          print *,i,j,dscj_inv,dsci_inv
23459 ! rij holds 1/(distance of Calpha atoms)
23460           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23461           rij  = dsqrt(rrij)
23462 !----------------------------
23463           CALL sc_angular
23464 ! this should be in elgrad_init but om's are calculated by sc_angular
23465 ! which in turn is used by older potentials
23466 ! om = omega, sqom = om^2
23467           sqom1  = om1 * om1
23468           sqom2  = om2 * om2
23469           sqom12 = om12 * om12
23470
23471 ! now we calculate EGB - Gey-Berne
23472 ! It will be summed up in evdwij and saved in evdw
23473           sigsq     = 1.0D0  / sigsq
23474           sig       = sig0ij * dsqrt(sigsq)
23475 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23476           rij_shift = 1.0/rij - sig + sig0ij
23477           IF (rij_shift.le.0.0D0) THEN
23478            evdw = 1.0D20
23479            RETURN
23480           END IF
23481           sigder = -sig * sigsq
23482           rij_shift = 1.0D0 / rij_shift
23483           fac       = rij_shift**expon
23484           c1        = fac  * fac * aa_scbase(itypi,itypj)
23485 !          c1        = 0.0d0
23486           c2        = fac  * bb_scbase(itypi,itypj)
23487 !          c2        = 0.0d0
23488           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23489           eps2der   = eps3rt * evdwij
23490           eps3der   = eps2rt * evdwij
23491 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23492           evdwij    = eps2rt * eps3rt * evdwij
23493           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23494           fac    = -expon * (c1 + evdwij) * rij_shift
23495           sigder = fac * sigder
23496 !          fac    = rij * fac
23497 ! Calculate distance derivative
23498           gg(1) =  fac
23499           gg(2) =  fac
23500           gg(3) =  fac
23501 !          if (b2.gt.0.0) then
23502           fac = chis1 * sqom1 + chis2 * sqom2 &
23503           - 2.0d0 * chis12 * om1 * om2 * om12
23504 ! we will use pom later in Gcav, so dont mess with it!
23505           pom = 1.0d0 - chis1 * chis2 * sqom12
23506           Lambf = (1.0d0 - (fac / pom))
23507           Lambf = dsqrt(Lambf)
23508           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23509 !       write (*,*) "sparrow = ", sparrow
23510           Chif = 1.0d0/rij * sparrow
23511           ChiLambf = Chif * Lambf
23512           eagle = dsqrt(ChiLambf)
23513           bat = ChiLambf ** 11.0d0
23514           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23515           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23516           botsq = bot * bot
23517           Fcav = top / bot
23518 !          print *,i,j,Fcav
23519           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23520           dbot = 12.0d0 * b4 * bat * Lambf
23521           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23522 !       dFdR = 0.0d0
23523 !      write (*,*) "dFcav/dR = ", dFdR
23524           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23525           dbot = 12.0d0 * b4 * bat * Chif
23526           eagle = Lambf * pom
23527           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23528           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23529           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23530               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23531
23532           dFdL = ((dtop * bot - top * dbot) / botsq)
23533 !       dFdL = 0.0d0
23534           dCAVdOM1  = dFdL * ( dFdOM1 )
23535           dCAVdOM2  = dFdL * ( dFdOM2 )
23536           dCAVdOM12 = dFdL * ( dFdOM12 )
23537
23538           ertail(1) = xj*rij
23539           ertail(2) = yj*rij
23540           ertail(3) = zj*rij
23541 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23542 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23543 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23544 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23545 !           print *,"EOMY",eom1,eom2,eom12
23546 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23547 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23548 ! here dtail=0.0
23549 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23550 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23551        DO k = 1, 3
23552 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23553 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23554         pom = ertail(k)
23555 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23556         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23557                   - (( dFdR + gg(k) ) * pom)
23558 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23559 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23560 !     &             - ( dFdR * pom )
23561         pom = ertail(k)
23562 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23563         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23564                   + (( dFdR + gg(k) ) * pom)
23565 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23566 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23567 !c!     &             + ( dFdR * pom )
23568
23569         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23570                   - (( dFdR + gg(k) ) * ertail(k))
23571 !c!     &             - ( dFdR * ertail(k))
23572
23573         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23574                   + (( dFdR + gg(k) ) * ertail(k))
23575 !c!     &             + ( dFdR * ertail(k))
23576
23577         gg(k) = 0.0d0
23578 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23579 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23580       END DO
23581
23582 !          else
23583
23584 !          endif
23585 !Now dipole-dipole
23586          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23587        w1 = wdipdip_scbase(1,itypi,itypj)
23588        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23589        w3 = wdipdip_scbase(2,itypi,itypj)
23590 !c!-------------------------------------------------------------------
23591 !c! ECL
23592        fac = (om12 - 3.0d0 * om1 * om2)
23593        c1 = (w1 / (Rhead**3.0d0)) * fac
23594        c2 = (w2 / Rhead ** 6.0d0)  &
23595          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23596        c3= (w3/ Rhead ** 6.0d0)  &
23597          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23598        ECL = c1 - c2 + c3
23599 !c!       write (*,*) "w1 = ", w1
23600 !c!       write (*,*) "w2 = ", w2
23601 !c!       write (*,*) "om1 = ", om1
23602 !c!       write (*,*) "om2 = ", om2
23603 !c!       write (*,*) "om12 = ", om12
23604 !c!       write (*,*) "fac = ", fac
23605 !c!       write (*,*) "c1 = ", c1
23606 !c!       write (*,*) "c2 = ", c2
23607 !c!       write (*,*) "Ecl = ", Ecl
23608 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23609 !c!       write (*,*) "c2_2 = ",
23610 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23611 !c!-------------------------------------------------------------------
23612 !c! dervative of ECL is GCL...
23613 !c! dECL/dr
23614        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23615        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23616          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23617        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23618          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23619        dGCLdR = c1 - c2 + c3
23620 !c! dECL/dom1
23621        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23622        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23623          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23624        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23625        dGCLdOM1 = c1 - c2 + c3
23626 !c! dECL/dom2
23627        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23628        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23629          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23630        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23631        dGCLdOM2 = c1 - c2 + c3
23632 !c! dECL/dom12
23633        c1 = w1 / (Rhead ** 3.0d0)
23634        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23635        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23636        dGCLdOM12 = c1 - c2 + c3
23637        DO k= 1, 3
23638         erhead(k) = Rhead_distance(k)/Rhead
23639        END DO
23640        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23641        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23642        facd1 = d1i * vbld_inv(i+nres)
23643        facd2 = d1j * vbld_inv(j+nres)
23644        DO k = 1, 3
23645
23646         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23647         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23648                   - dGCLdR * pom
23649         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23650         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23651                   + dGCLdR * pom
23652
23653         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23654                   - dGCLdR * erhead(k)
23655         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23656                   + dGCLdR * erhead(k)
23657        END DO
23658        endif
23659 !now charge with dipole eg. ARG-dG
23660        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23661       alphapol1 = alphapol_scbase(itypi,itypj)
23662        w1        = wqdip_scbase(1,itypi,itypj)
23663        w2        = wqdip_scbase(2,itypi,itypj)
23664 !       w1=0.0d0
23665 !       w2=0.0d0
23666 !       pis       = sig0head_scbase(itypi,itypj)
23667 !       eps_head   = epshead_scbase(itypi,itypj)
23668 !c!-------------------------------------------------------------------
23669 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23670        R1 = 0.0d0
23671        DO k = 1, 3
23672 !c! Calculate head-to-tail distances tail is center of side-chain
23673         R1=R1+(c(k,j+nres)-chead(k,1))**2
23674        END DO
23675 !c! Pitagoras
23676        R1 = dsqrt(R1)
23677
23678 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23679 !c!     &        +dhead(1,1,itypi,itypj))**2))
23680 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23681 !c!     &        +dhead(2,1,itypi,itypj))**2))
23682
23683 !c!-------------------------------------------------------------------
23684 !c! ecl
23685        sparrow  = w1  *  om1
23686        hawk     = w2 *  (1.0d0 - sqom2)
23687        Ecl = sparrow / Rhead**2.0d0 &
23688            - hawk    / Rhead**4.0d0
23689 !c!-------------------------------------------------------------------
23690 !c! derivative of ecl is Gcl
23691 !c! dF/dr part
23692        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23693                 + 4.0d0 * hawk    / Rhead**5.0d0
23694 !c! dF/dom1
23695        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23696 !c! dF/dom2
23697        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23698 !c--------------------------------------------------------------------
23699 !c Polarization energy
23700 !c Epol
23701        MomoFac1 = (1.0d0 - chi1 * sqom2)
23702        RR1  = R1 * R1 / MomoFac1
23703        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23704        fgb1 = sqrt( RR1 + a12sq * ee1)
23705 !       eps_inout_fac=0.0d0
23706        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23707 ! derivative of Epol is Gpol...
23708        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23709                 / (fgb1 ** 5.0d0)
23710        dFGBdR1 = ( (R1 / MomoFac1) &
23711              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23712              / ( 2.0d0 * fgb1 )
23713        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23714                * (2.0d0 - 0.5d0 * ee1) ) &
23715                / (2.0d0 * fgb1)
23716        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23717 !       dPOLdR1 = 0.0d0
23718        dPOLdOM1 = 0.0d0
23719        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23720        DO k = 1, 3
23721         erhead(k) = Rhead_distance(k)/Rhead
23722         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23723        END DO
23724
23725        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23726        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23727        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23728 !       bat=0.0d0
23729        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23730        facd1 = d1i * vbld_inv(i+nres)
23731        facd2 = d1j * vbld_inv(j+nres)
23732 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23733
23734        DO k = 1, 3
23735         hawk = (erhead_tail(k,1) + &
23736         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23737 !        facd1=0.0d0
23738 !        facd2=0.0d0
23739         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23740         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23741                    - dGCLdR * pom &
23742                    - dPOLdR1 *  (erhead_tail(k,1))
23743 !     &             - dGLJdR * pom
23744
23745         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23746         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23747                    + dGCLdR * pom  &
23748                    + dPOLdR1 * (erhead_tail(k,1))
23749 !     &             + dGLJdR * pom
23750
23751
23752         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23753                   - dGCLdR * erhead(k) &
23754                   - dPOLdR1 * erhead_tail(k,1)
23755 !     &             - dGLJdR * erhead(k)
23756
23757         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23758                   + dGCLdR * erhead(k)  &
23759                   + dPOLdR1 * erhead_tail(k,1)
23760 !     &             + dGLJdR * erhead(k)
23761
23762        END DO
23763        endif
23764 !       print *,i,j,evdwij,epol,Fcav,ECL
23765        escbase=escbase+evdwij+epol+Fcav+ECL
23766        call sc_grad_scbase
23767          enddo
23768       enddo
23769
23770       return
23771       end subroutine eprot_sc_base
23772       SUBROUTINE sc_grad_scbase
23773       use calc_data
23774
23775        real (kind=8) :: dcosom1(3),dcosom2(3)
23776        eom1  =    &
23777               eps2der * eps2rt_om1   &
23778             - 2.0D0 * alf1 * eps3der &
23779             + sigder * sigsq_om1     &
23780             + dCAVdOM1               &
23781             + dGCLdOM1               &
23782             + dPOLdOM1
23783
23784        eom2  =  &
23785               eps2der * eps2rt_om2   &
23786             + 2.0D0 * alf2 * eps3der &
23787             + sigder * sigsq_om2     &
23788             + dCAVdOM2               &
23789             + dGCLdOM2               &
23790             + dPOLdOM2
23791
23792        eom12 =    &
23793               evdwij  * eps1_om12     &
23794             + eps2der * eps2rt_om12   &
23795             - 2.0D0 * alf12 * eps3der &
23796             + sigder *sigsq_om12      &
23797             + dCAVdOM12               &
23798             + dGCLdOM12
23799
23800 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23801 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23802 !               gg(1),gg(2),"rozne"
23803        DO k = 1, 3
23804         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23805         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23806         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23807         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23808                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23809                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23810         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23811                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23812                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23813         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23814         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23815        END DO
23816        RETURN
23817       END SUBROUTINE sc_grad_scbase
23818
23819
23820       subroutine epep_sc_base(epepbase)
23821       use calc_data
23822       logical :: lprn
23823 !el local variables
23824       integer :: iint,itypi,itypi1,itypj,subchap
23825       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23826       real(kind=8) :: evdw,sig0ij
23827       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23828                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23829                     sslipi,sslipj,faclip
23830       integer :: ii
23831       real(kind=8) :: fracinbuf
23832        real (kind=8) :: epepbase
23833        real (kind=8),dimension(4):: ener
23834        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23835        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23836         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23837         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23838         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23839         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23840         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23841         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23842        real(kind=8),dimension(3,2)::chead,erhead_tail
23843        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23844        integer troll
23845        eps_out=80.0d0
23846        epepbase=0.0d0
23847 !       do i=1,nres_molec(1)-1
23848         do i=ibond_start,ibond_end
23849         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23850 !C        itypi  = itype(i,1)
23851         dxi    = dc_norm(1,i)
23852         dyi    = dc_norm(2,i)
23853         dzi    = dc_norm(3,i)
23854 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23855         dsci_inv = vbld_inv(i+1)/2.0
23856         xi=(c(1,i)+c(1,i+1))/2.0
23857         yi=(c(2,i)+c(2,i+1))/2.0
23858         zi=(c(3,i)+c(3,i+1))/2.0
23859         xi=mod(xi,boxxsize)
23860          if (xi.lt.0) xi=xi+boxxsize
23861         yi=mod(yi,boxysize)
23862          if (yi.lt.0) yi=yi+boxysize
23863         zi=mod(zi,boxzsize)
23864          if (zi.lt.0) zi=zi+boxzsize
23865          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23866            itypj= itype(j,2)
23867            if (itype(j,2).eq.ntyp1_molec(2))cycle
23868            xj=c(1,j+nres)
23869            yj=c(2,j+nres)
23870            zj=c(3,j+nres)
23871            xj=dmod(xj,boxxsize)
23872            if (xj.lt.0) xj=xj+boxxsize
23873            yj=dmod(yj,boxysize)
23874            if (yj.lt.0) yj=yj+boxysize
23875            zj=dmod(zj,boxzsize)
23876            if (zj.lt.0) zj=zj+boxzsize
23877           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23878           xj_safe=xj
23879           yj_safe=yj
23880           zj_safe=zj
23881           subchap=0
23882
23883           do xshift=-1,1
23884           do yshift=-1,1
23885           do zshift=-1,1
23886           xj=xj_safe+xshift*boxxsize
23887           yj=yj_safe+yshift*boxysize
23888           zj=zj_safe+zshift*boxzsize
23889           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23890           if(dist_temp.lt.dist_init) then
23891             dist_init=dist_temp
23892             xj_temp=xj
23893             yj_temp=yj
23894             zj_temp=zj
23895             subchap=1
23896           endif
23897           enddo
23898           enddo
23899           enddo
23900           if (subchap.eq.1) then
23901           xj=xj_temp-xi
23902           yj=yj_temp-yi
23903           zj=zj_temp-zi
23904           else
23905           xj=xj_safe-xi
23906           yj=yj_safe-yi
23907           zj=zj_safe-zi
23908           endif
23909           dxj = dc_norm( 1, nres+j )
23910           dyj = dc_norm( 2, nres+j )
23911           dzj = dc_norm( 3, nres+j )
23912 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23913 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23914
23915 ! Gay-berne var's
23916           sig0ij = sigma_pepbase(itypj )
23917           chi1   = chi_pepbase(itypj,1 )
23918           chi2   = chi_pepbase(itypj,2 )
23919 !          chi1=0.0d0
23920 !          chi2=0.0d0
23921           chi12  = chi1 * chi2
23922           chip1  = chipp_pepbase(itypj,1 )
23923           chip2  = chipp_pepbase(itypj,2 )
23924 !          chip1=0.0d0
23925 !          chip2=0.0d0
23926           chip12 = chip1 * chip2
23927           chis1 = chis_pepbase(itypj,1)
23928           chis2 = chis_pepbase(itypj,2)
23929           chis12 = chis1 * chis2
23930           sig1 = sigmap1_pepbase(itypj)
23931           sig2 = sigmap2_pepbase(itypj)
23932 !       write (*,*) "sig1 = ", sig1
23933 !       write (*,*) "sig2 = ", sig2
23934        DO k = 1,3
23935 ! location of polar head is computed by taking hydrophobic centre
23936 ! and moving by a d1 * dc_norm vector
23937 ! see unres publications for very informative images
23938         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23939 ! + d1i * dc_norm(k, i+nres)
23940         chead(k,2) = c(k, j+nres)
23941 ! + d1j * dc_norm(k, j+nres)
23942 ! distance
23943 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23944 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23945         Rhead_distance(k) = chead(k,2) - chead(k,1)
23946 !        print *,gvdwc_pepbase(k,i)
23947
23948        END DO
23949        Rhead = dsqrt( &
23950           (Rhead_distance(1)*Rhead_distance(1)) &
23951         + (Rhead_distance(2)*Rhead_distance(2)) &
23952         + (Rhead_distance(3)*Rhead_distance(3)))
23953
23954 ! alpha factors from Fcav/Gcav
23955           b1 = alphasur_pepbase(1,itypj)
23956 !          b1=0.0d0
23957           b2 = alphasur_pepbase(2,itypj)
23958           b3 = alphasur_pepbase(3,itypj)
23959           b4 = alphasur_pepbase(4,itypj)
23960           alf1   = 0.0d0
23961           alf2   = 0.0d0
23962           alf12  = 0.0d0
23963           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23964 !          print *,i,j,rrij
23965           rij  = dsqrt(rrij)
23966 !----------------------------
23967        evdwij = 0.0d0
23968        ECL = 0.0d0
23969        Elj = 0.0d0
23970        Equad = 0.0d0
23971        Epol = 0.0d0
23972        Fcav=0.0d0
23973        eheadtail = 0.0d0
23974        dGCLdOM1 = 0.0d0
23975        dGCLdOM2 = 0.0d0
23976        dGCLdOM12 = 0.0d0
23977        dPOLdOM1 = 0.0d0
23978        dPOLdOM2 = 0.0d0
23979           Fcav = 0.0d0
23980           dFdR = 0.0d0
23981           dCAVdOM1  = 0.0d0
23982           dCAVdOM2  = 0.0d0
23983           dCAVdOM12 = 0.0d0
23984           dscj_inv = vbld_inv(j+nres)
23985           CALL sc_angular
23986 ! this should be in elgrad_init but om's are calculated by sc_angular
23987 ! which in turn is used by older potentials
23988 ! om = omega, sqom = om^2
23989           sqom1  = om1 * om1
23990           sqom2  = om2 * om2
23991           sqom12 = om12 * om12
23992
23993 ! now we calculate EGB - Gey-Berne
23994 ! It will be summed up in evdwij and saved in evdw
23995           sigsq     = 1.0D0  / sigsq
23996           sig       = sig0ij * dsqrt(sigsq)
23997           rij_shift = 1.0/rij - sig + sig0ij
23998           IF (rij_shift.le.0.0D0) THEN
23999            evdw = 1.0D20
24000            RETURN
24001           END IF
24002           sigder = -sig * sigsq
24003           rij_shift = 1.0D0 / rij_shift
24004           fac       = rij_shift**expon
24005           c1        = fac  * fac * aa_pepbase(itypj)
24006 !          c1        = 0.0d0
24007           c2        = fac  * bb_pepbase(itypj)
24008 !          c2        = 0.0d0
24009           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24010           eps2der   = eps3rt * evdwij
24011           eps3der   = eps2rt * evdwij
24012 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24013           evdwij    = eps2rt * eps3rt * evdwij
24014           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24015           fac    = -expon * (c1 + evdwij) * rij_shift
24016           sigder = fac * sigder
24017 !          fac    = rij * fac
24018 ! Calculate distance derivative
24019           gg(1) =  fac
24020           gg(2) =  fac
24021           gg(3) =  fac
24022           fac = chis1 * sqom1 + chis2 * sqom2 &
24023           - 2.0d0 * chis12 * om1 * om2 * om12
24024 ! we will use pom later in Gcav, so dont mess with it!
24025           pom = 1.0d0 - chis1 * chis2 * sqom12
24026           Lambf = (1.0d0 - (fac / pom))
24027           Lambf = dsqrt(Lambf)
24028           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24029 !       write (*,*) "sparrow = ", sparrow
24030           Chif = 1.0d0/rij * sparrow
24031           ChiLambf = Chif * Lambf
24032           eagle = dsqrt(ChiLambf)
24033           bat = ChiLambf ** 11.0d0
24034           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24035           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24036           botsq = bot * bot
24037           Fcav = top / bot
24038 !          print *,i,j,Fcav
24039           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24040           dbot = 12.0d0 * b4 * bat * Lambf
24041           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24042 !       dFdR = 0.0d0
24043 !      write (*,*) "dFcav/dR = ", dFdR
24044           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24045           dbot = 12.0d0 * b4 * bat * Chif
24046           eagle = Lambf * pom
24047           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24048           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24049           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24050               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24051
24052           dFdL = ((dtop * bot - top * dbot) / botsq)
24053 !       dFdL = 0.0d0
24054           dCAVdOM1  = dFdL * ( dFdOM1 )
24055           dCAVdOM2  = dFdL * ( dFdOM2 )
24056           dCAVdOM12 = dFdL * ( dFdOM12 )
24057
24058           ertail(1) = xj*rij
24059           ertail(2) = yj*rij
24060           ertail(3) = zj*rij
24061        DO k = 1, 3
24062 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24063 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24064         pom = ertail(k)
24065 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24066         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24067                   - (( dFdR + gg(k) ) * pom)/2.0
24068 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24069 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24070 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24071 !     &             - ( dFdR * pom )
24072         pom = ertail(k)
24073 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24074         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24075                   + (( dFdR + gg(k) ) * pom)
24076 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24077 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24078 !c!     &             + ( dFdR * pom )
24079
24080         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24081                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24082 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24083
24084 !c!     &             - ( dFdR * ertail(k))
24085
24086         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24087                   + (( dFdR + gg(k) ) * ertail(k))
24088 !c!     &             + ( dFdR * ertail(k))
24089
24090         gg(k) = 0.0d0
24091 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24092 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24093       END DO
24094
24095
24096        w1 = wdipdip_pepbase(1,itypj)
24097        w2 = -wdipdip_pepbase(3,itypj)/2.0
24098        w3 = wdipdip_pepbase(2,itypj)
24099 !       w1=0.0d0
24100 !       w2=0.0d0
24101 !c!-------------------------------------------------------------------
24102 !c! ECL
24103 !       w3=0.0d0
24104        fac = (om12 - 3.0d0 * om1 * om2)
24105        c1 = (w1 / (Rhead**3.0d0)) * fac
24106        c2 = (w2 / Rhead ** 6.0d0)  &
24107          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24108        c3= (w3/ Rhead ** 6.0d0)  &
24109          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24110
24111        ECL = c1 - c2 + c3
24112
24113        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24114        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24115          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24116        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24117          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24118
24119        dGCLdR = c1 - c2 + c3
24120 !c! dECL/dom1
24121        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24122        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24123          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24124        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24125        dGCLdOM1 = c1 - c2 + c3
24126 !c! dECL/dom2
24127        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24128        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24129          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24130        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24131
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 = d1 * vbld_inv(i+nres)
24144 !       facd2 = d2 * vbld_inv(j+nres)
24145        DO k = 1, 3
24146
24147 !        pom = erhead(k)
24148 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24149 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24150 !                  - dGCLdR * pom
24151         pom = erhead(k)
24152 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24153         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24154                   + dGCLdR * pom
24155
24156         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24157                   - dGCLdR * erhead(k)/2.0d0
24158 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24159         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24160                   - dGCLdR * erhead(k)/2.0d0
24161 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24162         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24163                   + dGCLdR * erhead(k)
24164        END DO
24165 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24166        epepbase=epepbase+evdwij+Fcav+ECL
24167        call sc_grad_pepbase
24168        enddo
24169        enddo
24170       END SUBROUTINE epep_sc_base
24171       SUBROUTINE sc_grad_pepbase
24172       use calc_data
24173
24174        real (kind=8) :: dcosom1(3),dcosom2(3)
24175        eom1  =    &
24176               eps2der * eps2rt_om1   &
24177             - 2.0D0 * alf1 * eps3der &
24178             + sigder * sigsq_om1     &
24179             + dCAVdOM1               &
24180             + dGCLdOM1               &
24181             + dPOLdOM1
24182
24183        eom2  =  &
24184               eps2der * eps2rt_om2   &
24185             + 2.0D0 * alf2 * eps3der &
24186             + sigder * sigsq_om2     &
24187             + dCAVdOM2               &
24188             + dGCLdOM2               &
24189             + dPOLdOM2
24190
24191        eom12 =    &
24192               evdwij  * eps1_om12     &
24193             + eps2der * eps2rt_om12   &
24194             - 2.0D0 * alf12 * eps3der &
24195             + sigder *sigsq_om12      &
24196             + dCAVdOM12               &
24197             + dGCLdOM12
24198 !        om12=0.0
24199 !        eom12=0.0
24200 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24201 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24202 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24203 !                 *dsci_inv*2.0
24204 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24205 !               gg(1),gg(2),"rozne"
24206        DO k = 1, 3
24207         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24208         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24209         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24210         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24211                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24212                  *dsci_inv*2.0 &
24213                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24214         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24215                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24216                  *dsci_inv*2.0 &
24217                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24218 !         print *,eom12,eom2,om12,om2
24219 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24220 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24221         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24222                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24223                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24224         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24225        END DO
24226        RETURN
24227       END SUBROUTINE sc_grad_pepbase
24228       subroutine eprot_sc_phosphate(escpho)
24229       use calc_data
24230 !      implicit real*8 (a-h,o-z)
24231 !      include 'DIMENSIONS'
24232 !      include 'COMMON.GEO'
24233 !      include 'COMMON.VAR'
24234 !      include 'COMMON.LOCAL'
24235 !      include 'COMMON.CHAIN'
24236 !      include 'COMMON.DERIV'
24237 !      include 'COMMON.NAMES'
24238 !      include 'COMMON.INTERACT'
24239 !      include 'COMMON.IOUNITS'
24240 !      include 'COMMON.CALC'
24241 !      include 'COMMON.CONTROL'
24242 !      include 'COMMON.SBRIDGE'
24243       logical :: lprn
24244 !el local variables
24245       integer :: iint,itypi,itypi1,itypj,subchap
24246       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24247       real(kind=8) :: evdw,sig0ij
24248       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24249                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24250                     sslipi,sslipj,faclip,alpha_sco
24251       integer :: ii
24252       real(kind=8) :: fracinbuf
24253        real (kind=8) :: escpho
24254        real (kind=8),dimension(4):: ener
24255        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24256        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24257         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24258         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24259         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24260         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24261         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24262         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24263        real(kind=8),dimension(3,2)::chead,erhead_tail
24264        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24265        integer troll
24266        eps_out=80.0d0
24267        escpho=0.0d0
24268 !       do i=1,nres_molec(1)
24269         do i=ibond_start,ibond_end
24270         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24271         itypi  = itype(i,1)
24272         dxi    = dc_norm(1,nres+i)
24273         dyi    = dc_norm(2,nres+i)
24274         dzi    = dc_norm(3,nres+i)
24275         dsci_inv = vbld_inv(i+nres)
24276         xi=c(1,nres+i)
24277         yi=c(2,nres+i)
24278         zi=c(3,nres+i)
24279         xi=mod(xi,boxxsize)
24280          if (xi.lt.0) xi=xi+boxxsize
24281         yi=mod(yi,boxysize)
24282          if (yi.lt.0) yi=yi+boxysize
24283         zi=mod(zi,boxzsize)
24284          if (zi.lt.0) zi=zi+boxzsize
24285          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24286            itypj= itype(j,2)
24287            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24288             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24289            xj=(c(1,j)+c(1,j+1))/2.0
24290            yj=(c(2,j)+c(2,j+1))/2.0
24291            zj=(c(3,j)+c(3,j+1))/2.0
24292            xj=dmod(xj,boxxsize)
24293            if (xj.lt.0) xj=xj+boxxsize
24294            yj=dmod(yj,boxysize)
24295            if (yj.lt.0) yj=yj+boxysize
24296            zj=dmod(zj,boxzsize)
24297            if (zj.lt.0) zj=zj+boxzsize
24298           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24299           xj_safe=xj
24300           yj_safe=yj
24301           zj_safe=zj
24302           subchap=0
24303           do xshift=-1,1
24304           do yshift=-1,1
24305           do zshift=-1,1
24306           xj=xj_safe+xshift*boxxsize
24307           yj=yj_safe+yshift*boxysize
24308           zj=zj_safe+zshift*boxzsize
24309           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24310           if(dist_temp.lt.dist_init) then
24311             dist_init=dist_temp
24312             xj_temp=xj
24313             yj_temp=yj
24314             zj_temp=zj
24315             subchap=1
24316           endif
24317           enddo
24318           enddo
24319           enddo
24320           if (subchap.eq.1) then
24321           xj=xj_temp-xi
24322           yj=yj_temp-yi
24323           zj=zj_temp-zi
24324           else
24325           xj=xj_safe-xi
24326           yj=yj_safe-yi
24327           zj=zj_safe-zi
24328           endif
24329           dxj = dc_norm( 1,j )
24330           dyj = dc_norm( 2,j )
24331           dzj = dc_norm( 3,j )
24332           dscj_inv = vbld_inv(j+1)
24333
24334 ! Gay-berne var's
24335           sig0ij = sigma_scpho(itypi )
24336           chi1   = chi_scpho(itypi,1 )
24337           chi2   = chi_scpho(itypi,2 )
24338 !          chi1=0.0d0
24339 !          chi2=0.0d0
24340           chi12  = chi1 * chi2
24341           chip1  = chipp_scpho(itypi,1 )
24342           chip2  = chipp_scpho(itypi,2 )
24343 !          chip1=0.0d0
24344 !          chip2=0.0d0
24345           chip12 = chip1 * chip2
24346           chis1 = chis_scpho(itypi,1)
24347           chis2 = chis_scpho(itypi,2)
24348           chis12 = chis1 * chis2
24349           sig1 = sigmap1_scpho(itypi)
24350           sig2 = sigmap2_scpho(itypi)
24351 !       write (*,*) "sig1 = ", sig1
24352 !       write (*,*) "sig1 = ", sig1
24353 !       write (*,*) "sig2 = ", sig2
24354 ! alpha factors from Fcav/Gcav
24355           alf1   = 0.0d0
24356           alf2   = 0.0d0
24357           alf12  = 0.0d0
24358           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24359
24360           b1 = alphasur_scpho(1,itypi)
24361 !          b1=0.0d0
24362           b2 = alphasur_scpho(2,itypi)
24363           b3 = alphasur_scpho(3,itypi)
24364           b4 = alphasur_scpho(4,itypi)
24365 ! used to determine whether we want to do quadrupole calculations
24366 ! used by Fgb
24367        eps_in = epsintab_scpho(itypi)
24368        if (eps_in.eq.0.0) eps_in=1.0
24369        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24370 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24371 !-------------------------------------------------------------------
24372 ! tail location and distance calculations
24373           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24374           d1j = 0.0
24375        DO k = 1,3
24376 ! location of polar head is computed by taking hydrophobic centre
24377 ! and moving by a d1 * dc_norm vector
24378 ! see unres publications for very informative images
24379         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24380         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24381 ! distance
24382 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24383 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24384         Rhead_distance(k) = chead(k,2) - chead(k,1)
24385        END DO
24386 ! pitagoras (root of sum of squares)
24387        Rhead = dsqrt( &
24388           (Rhead_distance(1)*Rhead_distance(1)) &
24389         + (Rhead_distance(2)*Rhead_distance(2)) &
24390         + (Rhead_distance(3)*Rhead_distance(3)))
24391        Rhead_sq=Rhead**2.0
24392 !-------------------------------------------------------------------
24393 ! zero everything that should be zero'ed
24394        evdwij = 0.0d0
24395        ECL = 0.0d0
24396        Elj = 0.0d0
24397        Equad = 0.0d0
24398        Epol = 0.0d0
24399        Fcav=0.0d0
24400        eheadtail = 0.0d0
24401        dGCLdR=0.0d0
24402        dGCLdOM1 = 0.0d0
24403        dGCLdOM2 = 0.0d0
24404        dGCLdOM12 = 0.0d0
24405        dPOLdOM1 = 0.0d0
24406        dPOLdOM2 = 0.0d0
24407           Fcav = 0.0d0
24408           dFdR = 0.0d0
24409           dCAVdOM1  = 0.0d0
24410           dCAVdOM2  = 0.0d0
24411           dCAVdOM12 = 0.0d0
24412           dscj_inv = vbld_inv(j+1)/2.0
24413 !dhead_scbasej(itypi,itypj)
24414 !          print *,i,j,dscj_inv,dsci_inv
24415 ! rij holds 1/(distance of Calpha atoms)
24416           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24417           rij  = dsqrt(rrij)
24418 !----------------------------
24419           CALL sc_angular
24420 ! this should be in elgrad_init but om's are calculated by sc_angular
24421 ! which in turn is used by older potentials
24422 ! om = omega, sqom = om^2
24423           sqom1  = om1 * om1
24424           sqom2  = om2 * om2
24425           sqom12 = om12 * om12
24426
24427 ! now we calculate EGB - Gey-Berne
24428 ! It will be summed up in evdwij and saved in evdw
24429           sigsq     = 1.0D0  / sigsq
24430           sig       = sig0ij * dsqrt(sigsq)
24431 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24432           rij_shift = 1.0/rij - sig + sig0ij
24433           IF (rij_shift.le.0.0D0) THEN
24434            evdw = 1.0D20
24435            RETURN
24436           END IF
24437           sigder = -sig * sigsq
24438           rij_shift = 1.0D0 / rij_shift
24439           fac       = rij_shift**expon
24440           c1        = fac  * fac * aa_scpho(itypi)
24441 !          c1        = 0.0d0
24442           c2        = fac  * bb_scpho(itypi)
24443 !          c2        = 0.0d0
24444           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24445           eps2der   = eps3rt * evdwij
24446           eps3der   = eps2rt * evdwij
24447 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24448           evdwij    = eps2rt * eps3rt * evdwij
24449           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24450           fac    = -expon * (c1 + evdwij) * rij_shift
24451           sigder = fac * sigder
24452 !          fac    = rij * fac
24453 ! Calculate distance derivative
24454           gg(1) =  fac
24455           gg(2) =  fac
24456           gg(3) =  fac
24457           fac = chis1 * sqom1 + chis2 * sqom2 &
24458           - 2.0d0 * chis12 * om1 * om2 * om12
24459 ! we will use pom later in Gcav, so dont mess with it!
24460           pom = 1.0d0 - chis1 * chis2 * sqom12
24461           Lambf = (1.0d0 - (fac / pom))
24462           Lambf = dsqrt(Lambf)
24463           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24464 !       write (*,*) "sparrow = ", sparrow
24465           Chif = 1.0d0/rij * sparrow
24466           ChiLambf = Chif * Lambf
24467           eagle = dsqrt(ChiLambf)
24468           bat = ChiLambf ** 11.0d0
24469           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24470           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24471           botsq = bot * bot
24472           Fcav = top / bot
24473           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24474           dbot = 12.0d0 * b4 * bat * Lambf
24475           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24476 !       dFdR = 0.0d0
24477 !      write (*,*) "dFcav/dR = ", dFdR
24478           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24479           dbot = 12.0d0 * b4 * bat * Chif
24480           eagle = Lambf * pom
24481           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24482           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24483           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24484               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24485
24486           dFdL = ((dtop * bot - top * dbot) / botsq)
24487 !       dFdL = 0.0d0
24488           dCAVdOM1  = dFdL * ( dFdOM1 )
24489           dCAVdOM2  = dFdL * ( dFdOM2 )
24490           dCAVdOM12 = dFdL * ( dFdOM12 )
24491
24492           ertail(1) = xj*rij
24493           ertail(2) = yj*rij
24494           ertail(3) = zj*rij
24495        DO k = 1, 3
24496 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24497 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24498 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24499
24500         pom = ertail(k)
24501 !        print *,pom,gg(k),dFdR
24502 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24503         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24504                   - (( dFdR + gg(k) ) * pom)
24505 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24506 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24507 !     &             - ( dFdR * pom )
24508 !        pom = ertail(k)
24509 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24510 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24511 !                  + (( dFdR + gg(k) ) * pom)
24512 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24513 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24514 !c!     &             + ( dFdR * pom )
24515
24516         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24517                   - (( dFdR + gg(k) ) * ertail(k))
24518 !c!     &             - ( dFdR * ertail(k))
24519
24520         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24521                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24522
24523         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24524                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24525
24526 !c!     &             + ( dFdR * ertail(k))
24527
24528         gg(k) = 0.0d0
24529         ENDDO
24530 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24531 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24532 !      alphapol1 = alphapol_scpho(itypi)
24533        if (wqq_scpho(itypi).ne.0.0) then
24534        Qij=wqq_scpho(itypi)/eps_in
24535        alpha_sco=1.d0/alphi_scpho(itypi)
24536 !       Qij=0.0
24537        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24538 !c! derivative of Ecl is Gcl...
24539        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24540                 (Rhead*alpha_sco+1) ) / Rhead_sq
24541        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24542        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24543        w1        = wqdip_scpho(1,itypi)
24544        w2        = wqdip_scpho(2,itypi)
24545 !       w1=0.0d0
24546 !       w2=0.0d0
24547 !       pis       = sig0head_scbase(itypi,itypj)
24548 !       eps_head   = epshead_scbase(itypi,itypj)
24549 !c!-------------------------------------------------------------------
24550
24551 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24552 !c!     &        +dhead(1,1,itypi,itypj))**2))
24553 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24554 !c!     &        +dhead(2,1,itypi,itypj))**2))
24555
24556 !c!-------------------------------------------------------------------
24557 !c! ecl
24558        sparrow  = w1  *  om1
24559        hawk     = w2 *  (1.0d0 - sqom2)
24560        Ecl = sparrow / Rhead**2.0d0 &
24561            - hawk    / Rhead**4.0d0
24562 !c!-------------------------------------------------------------------
24563        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24564            1.0/rij,sparrow
24565
24566 !c! derivative of ecl is Gcl
24567 !c! dF/dr part
24568        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24569                 + 4.0d0 * hawk    / Rhead**5.0d0
24570 !c! dF/dom1
24571        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24572 !c! dF/dom2
24573        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24574        endif
24575
24576 !c--------------------------------------------------------------------
24577 !c Polarization energy
24578 !c Epol
24579        R1 = 0.0d0
24580        DO k = 1, 3
24581 !c! Calculate head-to-tail distances tail is center of side-chain
24582         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24583        END DO
24584 !c! Pitagoras
24585        R1 = dsqrt(R1)
24586
24587       alphapol1 = alphapol_scpho(itypi)
24588 !      alphapol1=0.0
24589        MomoFac1 = (1.0d0 - chi2 * sqom1)
24590        RR1  = R1 * R1 / MomoFac1
24591        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24592 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24593        fgb1 = sqrt( RR1 + a12sq * ee1)
24594 !       eps_inout_fac=0.0d0
24595        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24596 ! derivative of Epol is Gpol...
24597        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24598                 / (fgb1 ** 5.0d0)
24599        dFGBdR1 = ( (R1 / MomoFac1) &
24600              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24601              / ( 2.0d0 * fgb1 )
24602        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24603                * (2.0d0 - 0.5d0 * ee1) ) &
24604                / (2.0d0 * fgb1)
24605        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24606 !       dPOLdR1 = 0.0d0
24607 !       dPOLdOM1 = 0.0d0
24608        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24609                * (2.0d0 - 0.5d0 * ee1) ) &
24610                / (2.0d0 * fgb1)
24611
24612        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24613        dPOLdOM2 = 0.0
24614        DO k = 1, 3
24615         erhead(k) = Rhead_distance(k)/Rhead
24616         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24617        END DO
24618
24619        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24620        erdxj = scalar( erhead(1), dC_norm(1,j) )
24621        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24622 !       bat=0.0d0
24623        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24624        facd1 = d1i * vbld_inv(i+nres)
24625        facd2 = d1j * vbld_inv(j)
24626 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24627
24628        DO k = 1, 3
24629         hawk = (erhead_tail(k,1) + &
24630         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24631 !        facd1=0.0d0
24632 !        facd2=0.0d0
24633 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24634 !                pom,(erhead_tail(k,1))
24635
24636 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24637         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24638         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24639                    - dGCLdR * pom &
24640                    - dPOLdR1 *  (erhead_tail(k,1))
24641 !     &             - dGLJdR * pom
24642
24643         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24644 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24645 !                   + dGCLdR * pom  &
24646 !                   + dPOLdR1 * (erhead_tail(k,1))
24647 !     &             + dGLJdR * pom
24648
24649
24650         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24651                   - dGCLdR * erhead(k) &
24652                   - dPOLdR1 * erhead_tail(k,1)
24653 !     &             - dGLJdR * erhead(k)
24654
24655         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24656                   + (dGCLdR * erhead(k)  &
24657                   + dPOLdR1 * erhead_tail(k,1))/2.0
24658         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24659                   + (dGCLdR * erhead(k)  &
24660                   + dPOLdR1 * erhead_tail(k,1))/2.0
24661
24662 !     &             + dGLJdR * erhead(k)
24663 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24664
24665        END DO
24666 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24667        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24668         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24669        escpho=escpho+evdwij+epol+Fcav+ECL
24670        call sc_grad_scpho
24671          enddo
24672
24673       enddo
24674
24675       return
24676       end subroutine eprot_sc_phosphate
24677       SUBROUTINE sc_grad_scpho
24678       use calc_data
24679
24680        real (kind=8) :: dcosom1(3),dcosom2(3)
24681        eom1  =    &
24682               eps2der * eps2rt_om1   &
24683             - 2.0D0 * alf1 * eps3der &
24684             + sigder * sigsq_om1     &
24685             + dCAVdOM1               &
24686             + dGCLdOM1               &
24687             + dPOLdOM1
24688
24689        eom2  =  &
24690               eps2der * eps2rt_om2   &
24691             + 2.0D0 * alf2 * eps3der &
24692             + sigder * sigsq_om2     &
24693             + dCAVdOM2               &
24694             + dGCLdOM2               &
24695             + dPOLdOM2
24696
24697        eom12 =    &
24698               evdwij  * eps1_om12     &
24699             + eps2der * eps2rt_om12   &
24700             - 2.0D0 * alf12 * eps3der &
24701             + sigder *sigsq_om12      &
24702             + dCAVdOM12               &
24703             + dGCLdOM12
24704 !        om12=0.0
24705 !        eom12=0.0
24706 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24707 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24708 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24709 !                 *dsci_inv*2.0
24710 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24711 !               gg(1),gg(2),"rozne"
24712        DO k = 1, 3
24713         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24714         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24715         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24716         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24717                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24718                  *dscj_inv*2.0 &
24719                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24720         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24721                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24722                  *dscj_inv*2.0 &
24723                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24724         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24725                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24726                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24727
24728 !         print *,eom12,eom2,om12,om2
24729 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24730 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24731 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24732 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24733 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24734         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24735        END DO
24736        RETURN
24737       END SUBROUTINE sc_grad_scpho
24738       subroutine eprot_pep_phosphate(epeppho)
24739       use calc_data
24740 !      implicit real*8 (a-h,o-z)
24741 !      include 'DIMENSIONS'
24742 !      include 'COMMON.GEO'
24743 !      include 'COMMON.VAR'
24744 !      include 'COMMON.LOCAL'
24745 !      include 'COMMON.CHAIN'
24746 !      include 'COMMON.DERIV'
24747 !      include 'COMMON.NAMES'
24748 !      include 'COMMON.INTERACT'
24749 !      include 'COMMON.IOUNITS'
24750 !      include 'COMMON.CALC'
24751 !      include 'COMMON.CONTROL'
24752 !      include 'COMMON.SBRIDGE'
24753       logical :: lprn
24754 !el local variables
24755       integer :: iint,itypi,itypi1,itypj,subchap
24756       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24757       real(kind=8) :: evdw,sig0ij
24758       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24759                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24760                     sslipi,sslipj,faclip
24761       integer :: ii
24762       real(kind=8) :: fracinbuf
24763        real (kind=8) :: epeppho
24764        real (kind=8),dimension(4):: ener
24765        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24766        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24767         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24768         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24769         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24770         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24771         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24772         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24773        real(kind=8),dimension(3,2)::chead,erhead_tail
24774        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24775        integer troll
24776        real (kind=8) :: dcosom1(3),dcosom2(3)
24777        epeppho=0.0d0
24778 !       do i=1,nres_molec(1)
24779         do i=ibond_start,ibond_end
24780         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24781         itypi  = itype(i,1)
24782         dsci_inv = vbld_inv(i+1)/2.0
24783         dxi    = dc_norm(1,i)
24784         dyi    = dc_norm(2,i)
24785         dzi    = dc_norm(3,i)
24786         xi=(c(1,i)+c(1,i+1))/2.0
24787         yi=(c(2,i)+c(2,i+1))/2.0
24788         zi=(c(3,i)+c(3,i+1))/2.0
24789         xi=mod(xi,boxxsize)
24790          if (xi.lt.0) xi=xi+boxxsize
24791         yi=mod(yi,boxysize)
24792          if (yi.lt.0) yi=yi+boxysize
24793         zi=mod(zi,boxzsize)
24794          if (zi.lt.0) zi=zi+boxzsize
24795          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24796            itypj= itype(j,2)
24797            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24798             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24799            xj=(c(1,j)+c(1,j+1))/2.0
24800            yj=(c(2,j)+c(2,j+1))/2.0
24801            zj=(c(3,j)+c(3,j+1))/2.0
24802            xj=dmod(xj,boxxsize)
24803            if (xj.lt.0) xj=xj+boxxsize
24804            yj=dmod(yj,boxysize)
24805            if (yj.lt.0) yj=yj+boxysize
24806            zj=dmod(zj,boxzsize)
24807            if (zj.lt.0) zj=zj+boxzsize
24808           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24809           xj_safe=xj
24810           yj_safe=yj
24811           zj_safe=zj
24812           subchap=0
24813           do xshift=-1,1
24814           do yshift=-1,1
24815           do zshift=-1,1
24816           xj=xj_safe+xshift*boxxsize
24817           yj=yj_safe+yshift*boxysize
24818           zj=zj_safe+zshift*boxzsize
24819           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24820           if(dist_temp.lt.dist_init) then
24821             dist_init=dist_temp
24822             xj_temp=xj
24823             yj_temp=yj
24824             zj_temp=zj
24825             subchap=1
24826           endif
24827           enddo
24828           enddo
24829           enddo
24830           if (subchap.eq.1) then
24831           xj=xj_temp-xi
24832           yj=yj_temp-yi
24833           zj=zj_temp-zi
24834           else
24835           xj=xj_safe-xi
24836           yj=yj_safe-yi
24837           zj=zj_safe-zi
24838           endif
24839           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24840           rij  = dsqrt(rrij)
24841           dxj = dc_norm( 1,j )
24842           dyj = dc_norm( 2,j )
24843           dzj = dc_norm( 3,j )
24844           dscj_inv = vbld_inv(j+1)/2.0
24845 ! Gay-berne var's
24846           sig0ij = sigma_peppho
24847 !          chi1=0.0d0
24848 !          chi2=0.0d0
24849           chi12  = chi1 * chi2
24850 !          chip1=0.0d0
24851 !          chip2=0.0d0
24852           chip12 = chip1 * chip2
24853 !          chis1 = 0.0d0
24854 !          chis2 = 0.0d0
24855           chis12 = chis1 * chis2
24856           sig1 = sigmap1_peppho
24857           sig2 = sigmap2_peppho
24858 !       write (*,*) "sig1 = ", sig1
24859 !       write (*,*) "sig1 = ", sig1
24860 !       write (*,*) "sig2 = ", sig2
24861 ! alpha factors from Fcav/Gcav
24862           alf1   = 0.0d0
24863           alf2   = 0.0d0
24864           alf12  = 0.0d0
24865           b1 = alphasur_peppho(1)
24866 !          b1=0.0d0
24867           b2 = alphasur_peppho(2)
24868           b3 = alphasur_peppho(3)
24869           b4 = alphasur_peppho(4)
24870           CALL sc_angular
24871        sqom1=om1*om1
24872        evdwij = 0.0d0
24873        ECL = 0.0d0
24874        Elj = 0.0d0
24875        Equad = 0.0d0
24876        Epol = 0.0d0
24877        Fcav=0.0d0
24878        eheadtail = 0.0d0
24879        dGCLdR=0.0d0
24880        dGCLdOM1 = 0.0d0
24881        dGCLdOM2 = 0.0d0
24882        dGCLdOM12 = 0.0d0
24883        dPOLdOM1 = 0.0d0
24884        dPOLdOM2 = 0.0d0
24885           Fcav = 0.0d0
24886           dFdR = 0.0d0
24887           dCAVdOM1  = 0.0d0
24888           dCAVdOM2  = 0.0d0
24889           dCAVdOM12 = 0.0d0
24890           rij_shift = rij
24891           fac       = rij_shift**expon
24892           c1        = fac  * fac * aa_peppho
24893 !          c1        = 0.0d0
24894           c2        = fac  * bb_peppho
24895 !          c2        = 0.0d0
24896           evdwij    =  c1 + c2
24897 ! Now cavity....................
24898        eagle = dsqrt(1.0/rij_shift)
24899        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24900           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24901           botsq = bot * bot
24902           Fcav = top / bot
24903           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24904           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24905           dFdR = ((dtop * bot - top * dbot) / botsq)
24906        w1        = wqdip_peppho(1)
24907        w2        = wqdip_peppho(2)
24908 !       w1=0.0d0
24909 !       w2=0.0d0
24910 !       pis       = sig0head_scbase(itypi,itypj)
24911 !       eps_head   = epshead_scbase(itypi,itypj)
24912 !c!-------------------------------------------------------------------
24913
24914 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24915 !c!     &        +dhead(1,1,itypi,itypj))**2))
24916 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24917 !c!     &        +dhead(2,1,itypi,itypj))**2))
24918
24919 !c!-------------------------------------------------------------------
24920 !c! ecl
24921        sparrow  = w1  *  om1
24922        hawk     = w2 *  (1.0d0 - sqom1)
24923        Ecl = sparrow * rij_shift**2.0d0 &
24924            - hawk    * rij_shift**4.0d0
24925 !c!-------------------------------------------------------------------
24926 !c! derivative of ecl is Gcl
24927 !c! dF/dr part
24928 !       rij_shift=5.0
24929        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24930                 + 4.0d0 * hawk    * rij_shift**5.0d0
24931 !c! dF/dom1
24932        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24933 !c! dF/dom2
24934        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24935        eom1  =    dGCLdOM1+dGCLdOM2
24936        eom2  =    0.0
24937
24938           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24939 !          fac=0.0
24940           gg(1) =  fac*xj*rij
24941           gg(2) =  fac*yj*rij
24942           gg(3) =  fac*zj*rij
24943          do k=1,3
24944          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24945          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24946          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24947          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24948          gg(k)=0.0
24949          enddo
24950
24951       DO k = 1, 3
24952         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24953         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24954         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24955         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24956 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24957         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24958 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24959         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24960                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24961         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24962                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24963         enddo
24964        epeppho=epeppho+evdwij+Fcav+ECL
24965 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24966        enddo
24967        enddo
24968       end subroutine eprot_pep_phosphate
24969 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24970       subroutine emomo(evdw)
24971       use calc_data
24972       use comm_momo
24973 !      implicit real*8 (a-h,o-z)
24974 !      include 'DIMENSIONS'
24975 !      include 'COMMON.GEO'
24976 !      include 'COMMON.VAR'
24977 !      include 'COMMON.LOCAL'
24978 !      include 'COMMON.CHAIN'
24979 !      include 'COMMON.DERIV'
24980 !      include 'COMMON.NAMES'
24981 !      include 'COMMON.INTERACT'
24982 !      include 'COMMON.IOUNITS'
24983 !      include 'COMMON.CALC'
24984 !      include 'COMMON.CONTROL'
24985 !      include 'COMMON.SBRIDGE'
24986       logical :: lprn
24987 !el local variables
24988       integer :: iint,itypi1,subchap,isel
24989       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24990       real(kind=8) :: evdw
24991       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24992                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24993                     sslipi,sslipj,faclip,alpha_sco
24994       integer :: ii
24995       real(kind=8) :: fracinbuf
24996        real (kind=8) :: escpho
24997        real (kind=8),dimension(4):: ener
24998        real(kind=8) :: b1,b2,egb
24999        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25000         Lambf,&
25001         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25002         dFdOM2,dFdL,dFdOM12,&
25003         federmaus,&
25004         d1i,d1j
25005 !       real(kind=8),dimension(3,2)::erhead_tail
25006 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25007        real(kind=8) ::  facd4, adler, Fgb, facd3
25008        integer troll,jj,istate
25009        real (kind=8) :: dcosom1(3),dcosom2(3)
25010        eps_out=80.0d0
25011        sss_ele_cut=1.0d0
25012 !       print *,"EVDW KURW",evdw,nres
25013       do i=iatsc_s,iatsc_e
25014 !        print *,"I am in EVDW",i
25015         itypi=iabs(itype(i,1))
25016 !        if (i.ne.47) cycle
25017         if (itypi.eq.ntyp1) cycle
25018         itypi1=iabs(itype(i+1,1))
25019         xi=c(1,nres+i)
25020         yi=c(2,nres+i)
25021         zi=c(3,nres+i)
25022           xi=dmod(xi,boxxsize)
25023           if (xi.lt.0) xi=xi+boxxsize
25024           yi=dmod(yi,boxysize)
25025           if (yi.lt.0) yi=yi+boxysize
25026           zi=dmod(zi,boxzsize)
25027           if (zi.lt.0) zi=zi+boxzsize
25028
25029        if ((zi.gt.bordlipbot)  &
25030         .and.(zi.lt.bordliptop)) then
25031 !C the energy transfer exist
25032         if (zi.lt.buflipbot) then
25033 !C what fraction I am in
25034          fracinbuf=1.0d0-  &
25035               ((zi-bordlipbot)/lipbufthick)
25036 !C lipbufthick is thickenes of lipid buffore
25037          sslipi=sscalelip(fracinbuf)
25038          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25039         elseif (zi.gt.bufliptop) then
25040          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25041          sslipi=sscalelip(fracinbuf)
25042          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25043         else
25044          sslipi=1.0d0
25045          ssgradlipi=0.0
25046         endif
25047        else
25048          sslipi=0.0d0
25049          ssgradlipi=0.0
25050        endif
25051 !       print *, sslipi,ssgradlipi
25052         dxi=dc_norm(1,nres+i)
25053         dyi=dc_norm(2,nres+i)
25054         dzi=dc_norm(3,nres+i)
25055 !        dsci_inv=dsc_inv(itypi)
25056         dsci_inv=vbld_inv(i+nres)
25057 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25058 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25059 !
25060 ! Calculate SC interaction energy.
25061 !
25062         do iint=1,nint_gr(i)
25063           do j=istart(i,iint),iend(i,iint)
25064 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25065             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25066               call dyn_ssbond_ene(i,j,evdwij)
25067               evdw=evdw+evdwij
25068               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25069                               'evdw',i,j,evdwij,' ss'
25070 !              if (energy_dec) write (iout,*) &
25071 !                              'evdw',i,j,evdwij,' ss'
25072              do k=j+1,iend(i,iint)
25073 !C search over all next residues
25074               if (dyn_ss_mask(k)) then
25075 !C check if they are cysteins
25076 !C              write(iout,*) 'k=',k
25077
25078 !c              write(iout,*) "PRZED TRI", evdwij
25079 !               evdwij_przed_tri=evdwij
25080               call triple_ssbond_ene(i,j,k,evdwij)
25081 !c               if(evdwij_przed_tri.ne.evdwij) then
25082 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25083 !c               endif
25084
25085 !c              write(iout,*) "PO TRI", evdwij
25086 !C call the energy function that removes the artifical triple disulfide
25087 !C bond the soubroutine is located in ssMD.F
25088               evdw=evdw+evdwij
25089               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25090                             'evdw',i,j,evdwij,'tss'
25091               endif!dyn_ss_mask(k)
25092              enddo! k
25093             ELSE
25094 !el            ind=ind+1
25095             itypj=iabs(itype(j,1))
25096             if (itypj.eq.ntyp1) cycle
25097              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25098
25099 !             if (j.ne.78) cycle
25100 !            dscj_inv=dsc_inv(itypj)
25101             dscj_inv=vbld_inv(j+nres)
25102            xj=c(1,j+nres)
25103            yj=c(2,j+nres)
25104            zj=c(3,j+nres)
25105            xj=dmod(xj,boxxsize)
25106            if (xj.lt.0) xj=xj+boxxsize
25107            yj=dmod(yj,boxysize)
25108            if (yj.lt.0) yj=yj+boxysize
25109            zj=dmod(zj,boxzsize)
25110            if (zj.lt.0) zj=zj+boxzsize
25111           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25112           xj_safe=xj
25113           yj_safe=yj
25114           zj_safe=zj
25115           subchap=0
25116
25117           do xshift=-1,1
25118           do yshift=-1,1
25119           do zshift=-1,1
25120           xj=xj_safe+xshift*boxxsize
25121           yj=yj_safe+yshift*boxysize
25122           zj=zj_safe+zshift*boxzsize
25123           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25124           if(dist_temp.lt.dist_init) then
25125             dist_init=dist_temp
25126             xj_temp=xj
25127             yj_temp=yj
25128             zj_temp=zj
25129             subchap=1
25130           endif
25131           enddo
25132           enddo
25133           enddo
25134           if (subchap.eq.1) then
25135           xj=xj_temp-xi
25136           yj=yj_temp-yi
25137           zj=zj_temp-zi
25138           else
25139           xj=xj_safe-xi
25140           yj=yj_safe-yi
25141           zj=zj_safe-zi
25142           endif
25143           dxj = dc_norm( 1, nres+j )
25144           dyj = dc_norm( 2, nres+j )
25145           dzj = dc_norm( 3, nres+j )
25146 !          print *,i,j,itypi,itypj
25147 !          d1i=0.0d0
25148 !          d1j=0.0d0
25149 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25150 ! Gay-berne var's
25151 !1!          sig0ij = sigma_scsc( itypi,itypj )
25152 !          chi1=0.0d0
25153 !          chi2=0.0d0
25154 !          chip1=0.0d0
25155 !          chip2=0.0d0
25156 ! not used by momo potential, but needed by sc_angular which is shared
25157 ! by all energy_potential subroutines
25158           alf1   = 0.0d0
25159           alf2   = 0.0d0
25160           alf12  = 0.0d0
25161           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25162 !       a12sq = a12sq * a12sq
25163 ! charge of amino acid itypi is...
25164           chis1 = chis(itypi,itypj)
25165           chis2 = chis(itypj,itypi)
25166           chis12 = chis1 * chis2
25167           sig1 = sigmap1(itypi,itypj)
25168           sig2 = sigmap2(itypi,itypj)
25169 !       write (*,*) "sig1 = ", sig1
25170 !          chis1=0.0
25171 !          chis2=0.0
25172 !                    chis12 = chis1 * chis2
25173 !          sig1=0.0
25174 !          sig2=0.0
25175 !       write (*,*) "sig2 = ", sig2
25176 ! alpha factors from Fcav/Gcav
25177           b1cav = alphasur(1,itypi,itypj)
25178 !          b1cav=0.0d0
25179           b2cav = alphasur(2,itypi,itypj)
25180           b3cav = alphasur(3,itypi,itypj)
25181           b4cav = alphasur(4,itypi,itypj)
25182 ! used to determine whether we want to do quadrupole calculations
25183        eps_in = epsintab(itypi,itypj)
25184        if (eps_in.eq.0.0) eps_in=1.0
25185
25186        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25187        Rtail = 0.0d0
25188 !       dtail(1,itypi,itypj)=0.0
25189 !       dtail(2,itypi,itypj)=0.0
25190
25191        DO k = 1, 3
25192         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25193         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25194        END DO
25195 !c! tail distances will be themselves usefull elswhere
25196 !c1 (in Gcav, for example)
25197        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25198        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25199        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25200        Rtail = dsqrt( &
25201           (Rtail_distance(1)*Rtail_distance(1)) &
25202         + (Rtail_distance(2)*Rtail_distance(2)) &
25203         + (Rtail_distance(3)*Rtail_distance(3)))
25204
25205 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25206 !-------------------------------------------------------------------
25207 ! tail location and distance calculations
25208        d1 = dhead(1, 1, itypi, itypj)
25209        d2 = dhead(2, 1, itypi, itypj)
25210
25211        DO k = 1,3
25212 ! location of polar head is computed by taking hydrophobic centre
25213 ! and moving by a d1 * dc_norm vector
25214 ! see unres publications for very informative images
25215         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25216         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25217 ! distance
25218 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25219 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25220         Rhead_distance(k) = chead(k,2) - chead(k,1)
25221        END DO
25222 ! pitagoras (root of sum of squares)
25223        Rhead = dsqrt( &
25224           (Rhead_distance(1)*Rhead_distance(1)) &
25225         + (Rhead_distance(2)*Rhead_distance(2)) &
25226         + (Rhead_distance(3)*Rhead_distance(3)))
25227 !-------------------------------------------------------------------
25228 ! zero everything that should be zero'ed
25229        evdwij = 0.0d0
25230        ECL = 0.0d0
25231        Elj = 0.0d0
25232        Equad = 0.0d0
25233        Epol = 0.0d0
25234        Fcav=0.0d0
25235        eheadtail = 0.0d0
25236        dGCLdOM1 = 0.0d0
25237        dGCLdOM2 = 0.0d0
25238        dGCLdOM12 = 0.0d0
25239        dPOLdOM1 = 0.0d0
25240        dPOLdOM2 = 0.0d0
25241           Fcav = 0.0d0
25242           dFdR = 0.0d0
25243           dCAVdOM1  = 0.0d0
25244           dCAVdOM2  = 0.0d0
25245           dCAVdOM12 = 0.0d0
25246           dscj_inv = vbld_inv(j+nres)
25247 !          print *,i,j,dscj_inv,dsci_inv
25248 ! rij holds 1/(distance of Calpha atoms)
25249           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25250           rij  = dsqrt(rrij)
25251 !----------------------------
25252           CALL sc_angular
25253 ! this should be in elgrad_init but om's are calculated by sc_angular
25254 ! which in turn is used by older potentials
25255 ! om = omega, sqom = om^2
25256           sqom1  = om1 * om1
25257           sqom2  = om2 * om2
25258           sqom12 = om12 * om12
25259
25260 ! now we calculate EGB - Gey-Berne
25261 ! It will be summed up in evdwij and saved in evdw
25262           sigsq     = 1.0D0  / sigsq
25263           sig       = sig0ij * dsqrt(sigsq)
25264 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25265           rij_shift = Rtail - sig + sig0ij
25266           IF (rij_shift.le.0.0D0) THEN
25267            evdw = 1.0D20
25268            RETURN
25269           END IF
25270           sigder = -sig * sigsq
25271           rij_shift = 1.0D0 / rij_shift
25272           fac       = rij_shift**expon
25273           c1        = fac  * fac * aa_aq(itypi,itypj)
25274 !          print *,"ADAM",aa_aq(itypi,itypj)
25275
25276 !          c1        = 0.0d0
25277           c2        = fac  * bb_aq(itypi,itypj)
25278 !          c2        = 0.0d0
25279           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25280           eps2der   = eps3rt * evdwij
25281           eps3der   = eps2rt * evdwij
25282 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25283           evdwij    = eps2rt * eps3rt * evdwij
25284 !#ifdef TSCSC
25285 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25286 !           evdw_p = evdw_p + evdwij
25287 !          ELSE
25288 !           evdw_m = evdw_m + evdwij
25289 !          END IF
25290 !#else
25291           evdw = evdw  &
25292               + evdwij
25293 !#endif
25294
25295           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25296           fac    = -expon * (c1 + evdwij) * rij_shift
25297           sigder = fac * sigder
25298 !          fac    = rij * fac
25299 ! Calculate distance derivative
25300           gg(1) =  fac
25301           gg(2) =  fac
25302           gg(3) =  fac
25303 !          if (b2.gt.0.0) then
25304           fac = chis1 * sqom1 + chis2 * sqom2 &
25305           - 2.0d0 * chis12 * om1 * om2 * om12
25306 ! we will use pom later in Gcav, so dont mess with it!
25307           pom = 1.0d0 - chis1 * chis2 * sqom12
25308           Lambf = (1.0d0 - (fac / pom))
25309 !          print *,"fac,pom",fac,pom,Lambf
25310           Lambf = dsqrt(Lambf)
25311           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25312 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25313 !       write (*,*) "sparrow = ", sparrow
25314           Chif = Rtail * sparrow
25315 !           print *,"rij,sparrow",rij , sparrow
25316           ChiLambf = Chif * Lambf
25317           eagle = dsqrt(ChiLambf)
25318           bat = ChiLambf ** 11.0d0
25319           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25320           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25321           botsq = bot * bot
25322 !          print *,top,bot,"bot,top",ChiLambf,Chif
25323           Fcav = top / bot
25324
25325        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25326        dbot = 12.0d0 * b4cav * bat * Lambf
25327        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25328
25329           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25330           dbot = 12.0d0 * b4cav * bat * Chif
25331           eagle = Lambf * pom
25332           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25333           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25334           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25335               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25336
25337           dFdL = ((dtop * bot - top * dbot) / botsq)
25338 !       dFdL = 0.0d0
25339           dCAVdOM1  = dFdL * ( dFdOM1 )
25340           dCAVdOM2  = dFdL * ( dFdOM2 )
25341           dCAVdOM12 = dFdL * ( dFdOM12 )
25342
25343        DO k= 1, 3
25344         ertail(k) = Rtail_distance(k)/Rtail
25345        END DO
25346        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25347        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25348        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25349        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25350        DO k = 1, 3
25351 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25352 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25353         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25354         gvdwx(k,i) = gvdwx(k,i) &
25355                   - (( dFdR + gg(k) ) * pom)
25356 !c!     &             - ( dFdR * pom )
25357         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25358         gvdwx(k,j) = gvdwx(k,j)   &
25359                   + (( dFdR + gg(k) ) * pom)
25360 !c!     &             + ( dFdR * pom )
25361
25362         gvdwc(k,i) = gvdwc(k,i)  &
25363                   - (( dFdR + gg(k) ) * ertail(k))
25364 !c!     &             - ( dFdR * ertail(k))
25365
25366         gvdwc(k,j) = gvdwc(k,j) &
25367                   + (( dFdR + gg(k) ) * ertail(k))
25368 !c!     &             + ( dFdR * ertail(k))
25369
25370         gg(k) = 0.0d0
25371 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25372 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25373       END DO
25374
25375
25376 !c! Compute head-head and head-tail energies for each state
25377
25378           isel = iabs(Qi) + iabs(Qj)
25379 ! double charge for Phophorylated! itype - 25,27,27
25380 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25381 !            Qi=Qi*2
25382 !            Qij=Qij*2
25383 !           endif
25384 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25385 !            Qj=Qj*2
25386 !            Qij=Qij*2
25387 !           endif
25388
25389 !          isel=0
25390           IF (isel.eq.0) THEN
25391 !c! No charges - do nothing
25392            eheadtail = 0.0d0
25393
25394           ELSE IF (isel.eq.4) THEN
25395 !c! Calculate dipole-dipole interactions
25396            CALL edd(ecl)
25397            eheadtail = ECL
25398 !           eheadtail = 0.0d0
25399
25400           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25401 !c! Charge-nonpolar interactions
25402           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25403             Qi=Qi*2
25404             Qij=Qij*2
25405            endif
25406           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25407             Qj=Qj*2
25408             Qij=Qij*2
25409            endif
25410
25411            CALL eqn(epol)
25412            eheadtail = epol
25413 !           eheadtail = 0.0d0
25414
25415           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25416 !c! Nonpolar-charge interactions
25417           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25418             Qi=Qi*2
25419             Qij=Qij*2
25420            endif
25421           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25422             Qj=Qj*2
25423             Qij=Qij*2
25424            endif
25425
25426            CALL enq(epol)
25427            eheadtail = epol
25428 !           eheadtail = 0.0d0
25429
25430           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25431 !c! Charge-dipole interactions
25432           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25433             Qi=Qi*2
25434             Qij=Qij*2
25435            endif
25436           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25437             Qj=Qj*2
25438             Qij=Qij*2
25439            endif
25440
25441            CALL eqd(ecl, elj, epol)
25442            eheadtail = ECL + elj + epol
25443 !           eheadtail = 0.0d0
25444
25445           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25446 !c! Dipole-charge interactions
25447           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25448             Qi=Qi*2
25449             Qij=Qij*2
25450            endif
25451           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25452             Qj=Qj*2
25453             Qij=Qij*2
25454            endif
25455            CALL edq(ecl, elj, epol)
25456           eheadtail = ECL + elj + epol
25457 !           eheadtail = 0.0d0
25458
25459           ELSE IF ((isel.eq.2.and.   &
25460                iabs(Qi).eq.1).and.  &
25461                nstate(itypi,itypj).eq.1) THEN
25462 !c! Same charge-charge interaction ( +/+ or -/- )
25463           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25464             Qi=Qi*2
25465             Qij=Qij*2
25466            endif
25467           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25468             Qj=Qj*2
25469             Qij=Qij*2
25470            endif
25471
25472            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25473            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25474 !           eheadtail = 0.0d0
25475
25476           ELSE IF ((isel.eq.2.and.  &
25477                iabs(Qi).eq.1).and. &
25478                nstate(itypi,itypj).ne.1) THEN
25479 !c! Different charge-charge interaction ( +/- or -/+ )
25480           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25481             Qi=Qi*2
25482             Qij=Qij*2
25483            endif
25484           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25485             Qj=Qj*2
25486             Qij=Qij*2
25487            endif
25488
25489            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25490           END IF
25491        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25492       evdw = evdw  + Fcav + eheadtail
25493
25494        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25495         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25496         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25497         Equad,evdwij+Fcav+eheadtail,evdw
25498 !       evdw = evdw  + Fcav  + eheadtail
25499
25500         iF (nstate(itypi,itypj).eq.1) THEN
25501         CALL sc_grad
25502        END IF
25503 !c!-------------------------------------------------------------------
25504 !c! NAPISY KONCOWE
25505          END DO   ! j
25506         END DO    ! iint
25507        END DO     ! i
25508 !c      write (iout,*) "Number of loop steps in EGB:",ind
25509 !c      energy_dec=.false.
25510 !              print *,"EVDW KURW",evdw,nres
25511
25512        RETURN
25513       END SUBROUTINE emomo
25514 !C------------------------------------------------------------------------------------
25515       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25516       use calc_data
25517       use comm_momo
25518        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25519          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25520 !       integer :: k
25521 !c! Epol and Gpol analytical parameters
25522        alphapol1 = alphapol(itypi,itypj)
25523        alphapol2 = alphapol(itypj,itypi)
25524 !c! Fisocav and Gisocav analytical parameters
25525        al1  = alphiso(1,itypi,itypj)
25526        al2  = alphiso(2,itypi,itypj)
25527        al3  = alphiso(3,itypi,itypj)
25528        al4  = alphiso(4,itypi,itypj)
25529        csig = (1.0d0  &
25530            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25531            + sigiso2(itypi,itypj)**2.0d0))
25532 !c!
25533        pis  = sig0head(itypi,itypj)
25534        eps_head = epshead(itypi,itypj)
25535        Rhead_sq = Rhead * Rhead
25536 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25537 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25538        R1 = 0.0d0
25539        R2 = 0.0d0
25540        DO k = 1, 3
25541 !c! Calculate head-to-tail distances needed by Epol
25542         R1=R1+(ctail(k,2)-chead(k,1))**2
25543         R2=R2+(chead(k,2)-ctail(k,1))**2
25544        END DO
25545 !c! Pitagoras
25546        R1 = dsqrt(R1)
25547        R2 = dsqrt(R2)
25548
25549 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25550 !c!     &        +dhead(1,1,itypi,itypj))**2))
25551 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25552 !c!     &        +dhead(2,1,itypi,itypj))**2))
25553
25554 !c!-------------------------------------------------------------------
25555 !c! Coulomb electrostatic interaction
25556        Ecl = (332.0d0 * Qij) / Rhead
25557 !c! derivative of Ecl is Gcl...
25558        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25559        dGCLdOM1 = 0.0d0
25560        dGCLdOM2 = 0.0d0
25561        dGCLdOM12 = 0.0d0
25562        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25563        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25564        debkap=debaykap(itypi,itypj)
25565        Egb = -(332.0d0 * Qij *&
25566         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25567 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25568 !c! Derivative of Egb is Ggb...
25569        dGGBdFGB = -(-332.0d0 * Qij * &
25570        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25571        -(332.0d0 * Qij *&
25572         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25573        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25574        dGGBdR = dGGBdFGB * dFGBdR
25575 !c!-------------------------------------------------------------------
25576 !c! Fisocav - isotropic cavity creation term
25577 !c! or "how much energy it costs to put charged head in water"
25578        pom = Rhead * csig
25579        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25580        bot = (1.0d0 + al4 * pom**12.0d0)
25581        botsq = bot * bot
25582        FisoCav = top / bot
25583 !      write (*,*) "Rhead = ",Rhead
25584 !      write (*,*) "csig = ",csig
25585 !      write (*,*) "pom = ",pom
25586 !      write (*,*) "al1 = ",al1
25587 !      write (*,*) "al2 = ",al2
25588 !      write (*,*) "al3 = ",al3
25589 !      write (*,*) "al4 = ",al4
25590 !        write (*,*) "top = ",top
25591 !        write (*,*) "bot = ",bot
25592 !c! Derivative of Fisocav is GCV...
25593        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25594        dbot = 12.0d0 * al4 * pom ** 11.0d0
25595        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25596 !c!-------------------------------------------------------------------
25597 !c! Epol
25598 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25599        MomoFac1 = (1.0d0 - chi1 * sqom2)
25600        MomoFac2 = (1.0d0 - chi2 * sqom1)
25601        RR1  = ( R1 * R1 ) / MomoFac1
25602        RR2  = ( R2 * R2 ) / MomoFac2
25603        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25604        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25605        fgb1 = sqrt( RR1 + a12sq * ee1 )
25606        fgb2 = sqrt( RR2 + a12sq * ee2 )
25607        epol = 332.0d0 * eps_inout_fac * ( &
25608       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25609 !c!       epol = 0.0d0
25610        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25611                / (fgb1 ** 5.0d0)
25612        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25613                / (fgb2 ** 5.0d0)
25614        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25615              / ( 2.0d0 * fgb1 )
25616        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25617              / ( 2.0d0 * fgb2 )
25618        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25619                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25620        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25621                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25622        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25623 !c!       dPOLdR1 = 0.0d0
25624        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25625 !c!       dPOLdR2 = 0.0d0
25626        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25627 !c!       dPOLdOM1 = 0.0d0
25628        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25629 !c!       dPOLdOM2 = 0.0d0
25630 !c!-------------------------------------------------------------------
25631 !c! Elj
25632 !c! Lennard-Jones 6-12 interaction between heads
25633        pom = (pis / Rhead)**6.0d0
25634        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25635 !c! derivative of Elj is Glj
25636        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25637              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25638 !c!-------------------------------------------------------------------
25639 !c! Return the results
25640 !c! These things do the dRdX derivatives, that is
25641 !c! allow us to change what we see from function that changes with
25642 !c! distance to function that changes with LOCATION (of the interaction
25643 !c! site)
25644        DO k = 1, 3
25645         erhead(k) = Rhead_distance(k)/Rhead
25646         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25647         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25648        END DO
25649
25650        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25651        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25652        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25653        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25654        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25655        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25656        facd1 = d1 * vbld_inv(i+nres)
25657        facd2 = d2 * vbld_inv(j+nres)
25658        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25659        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25660
25661 !c! Now we add appropriate partial derivatives (one in each dimension)
25662        DO k = 1, 3
25663         hawk   = (erhead_tail(k,1) + &
25664         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25665         condor = (erhead_tail(k,2) + &
25666         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25667
25668         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25669         gvdwx(k,i) = gvdwx(k,i) &
25670                   - dGCLdR * pom&
25671                   - dGGBdR * pom&
25672                   - dGCVdR * pom&
25673                   - dPOLdR1 * hawk&
25674                   - dPOLdR2 * (erhead_tail(k,2)&
25675       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25676                   - dGLJdR * pom
25677
25678         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25679         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25680                    + dGGBdR * pom+ dGCVdR * pom&
25681                   + dPOLdR1 * (erhead_tail(k,1)&
25682       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25683                   + dPOLdR2 * condor + dGLJdR * pom
25684
25685         gvdwc(k,i) = gvdwc(k,i)  &
25686                   - dGCLdR * erhead(k)&
25687                   - dGGBdR * erhead(k)&
25688                   - dGCVdR * erhead(k)&
25689                   - dPOLdR1 * erhead_tail(k,1)&
25690                   - dPOLdR2 * erhead_tail(k,2)&
25691                   - dGLJdR * erhead(k)
25692
25693         gvdwc(k,j) = gvdwc(k,j)         &
25694                   + dGCLdR * erhead(k) &
25695                   + dGGBdR * erhead(k) &
25696                   + dGCVdR * erhead(k) &
25697                   + dPOLdR1 * erhead_tail(k,1) &
25698                   + dPOLdR2 * erhead_tail(k,2)&
25699                   + dGLJdR * erhead(k)
25700
25701        END DO
25702        RETURN
25703       END SUBROUTINE eqq
25704 !c!-------------------------------------------------------------------
25705       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25706       use comm_momo
25707       use calc_data
25708
25709        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25710        double precision ener(4)
25711        double precision dcosom1(3),dcosom2(3)
25712 !c! used in Epol derivatives
25713        double precision facd3, facd4
25714        double precision federmaus, adler
25715        integer istate,ii,jj
25716        real (kind=8) :: Fgb
25717 !       print *,"CALLING EQUAD"
25718 !c! Epol and Gpol analytical parameters
25719        alphapol1 = alphapol(itypi,itypj)
25720        alphapol2 = alphapol(itypj,itypi)
25721 !c! Fisocav and Gisocav analytical parameters
25722        al1  = alphiso(1,itypi,itypj)
25723        al2  = alphiso(2,itypi,itypj)
25724        al3  = alphiso(3,itypi,itypj)
25725        al4  = alphiso(4,itypi,itypj)
25726        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25727             + sigiso2(itypi,itypj)**2.0d0))
25728 !c!
25729        w1   = wqdip(1,itypi,itypj)
25730        w2   = wqdip(2,itypi,itypj)
25731        pis  = sig0head(itypi,itypj)
25732        eps_head = epshead(itypi,itypj)
25733 !c! First things first:
25734 !c! We need to do sc_grad's job with GB and Fcav
25735        eom1  = eps2der * eps2rt_om1 &
25736              - 2.0D0 * alf1 * eps3der&
25737              + sigder * sigsq_om1&
25738              + dCAVdOM1
25739        eom2  = eps2der * eps2rt_om2 &
25740              + 2.0D0 * alf2 * eps3der&
25741              + sigder * sigsq_om2&
25742              + dCAVdOM2
25743        eom12 =  evdwij  * eps1_om12 &
25744              + eps2der * eps2rt_om12 &
25745              - 2.0D0 * alf12 * eps3der&
25746              + sigder *sigsq_om12&
25747              + dCAVdOM12
25748 !c! now some magical transformations to project gradient into
25749 !c! three cartesian vectors
25750        DO k = 1, 3
25751         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25752         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25753         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25754 !c! this acts on hydrophobic center of interaction
25755         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25756                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25757                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25758         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25759                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25760                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25761 !c! this acts on Calpha
25762         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25763         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25764        END DO
25765 !c! sc_grad is done, now we will compute
25766        eheadtail = 0.0d0
25767        eom1 = 0.0d0
25768        eom2 = 0.0d0
25769        eom12 = 0.0d0
25770        DO istate = 1, nstate(itypi,itypj)
25771 !c*************************************************************
25772         IF (istate.ne.1) THEN
25773          IF (istate.lt.3) THEN
25774           ii = 1
25775          ELSE
25776           ii = 2
25777          END IF
25778         jj = istate/ii
25779         d1 = dhead(1,ii,itypi,itypj)
25780         d2 = dhead(2,jj,itypi,itypj)
25781         DO k = 1,3
25782          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25783          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25784          Rhead_distance(k) = chead(k,2) - chead(k,1)
25785         END DO
25786 !c! pitagoras (root of sum of squares)
25787         Rhead = dsqrt( &
25788                (Rhead_distance(1)*Rhead_distance(1))  &
25789              + (Rhead_distance(2)*Rhead_distance(2))  &
25790              + (Rhead_distance(3)*Rhead_distance(3)))
25791         END IF
25792         Rhead_sq = Rhead * Rhead
25793
25794 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25795 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25796         R1 = 0.0d0
25797         R2 = 0.0d0
25798         DO k = 1, 3
25799 !c! Calculate head-to-tail distances
25800          R1=R1+(ctail(k,2)-chead(k,1))**2
25801          R2=R2+(chead(k,2)-ctail(k,1))**2
25802         END DO
25803 !c! Pitagoras
25804         R1 = dsqrt(R1)
25805         R2 = dsqrt(R2)
25806         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25807 !c!        Ecl = 0.0d0
25808 !c!        write (*,*) "Ecl = ", Ecl
25809 !c! derivative of Ecl is Gcl...
25810         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25811 !c!        dGCLdR = 0.0d0
25812         dGCLdOM1 = 0.0d0
25813         dGCLdOM2 = 0.0d0
25814         dGCLdOM12 = 0.0d0
25815 !c!-------------------------------------------------------------------
25816 !c! Generalised Born Solvent Polarization
25817         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25818         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25819         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25820 !c!        Egb = 0.0d0
25821 !c!      write (*,*) "a1*a2 = ", a12sq
25822 !c!      write (*,*) "Rhead = ", Rhead
25823 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25824 !c!      write (*,*) "ee = ", ee
25825 !c!      write (*,*) "Fgb = ", Fgb
25826 !c!      write (*,*) "fac = ", eps_inout_fac
25827 !c!      write (*,*) "Qij = ", Qij
25828 !c!      write (*,*) "Egb = ", Egb
25829 !c! Derivative of Egb is Ggb...
25830 !c! dFGBdR is used by Quad's later...
25831         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25832         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25833                / ( 2.0d0 * Fgb )
25834         dGGBdR = dGGBdFGB * dFGBdR
25835 !c!        dGGBdR = 0.0d0
25836 !c!-------------------------------------------------------------------
25837 !c! Fisocav - isotropic cavity creation term
25838         pom = Rhead * csig
25839         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25840         bot = (1.0d0 + al4 * pom**12.0d0)
25841         botsq = bot * bot
25842         FisoCav = top / bot
25843         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25844         dbot = 12.0d0 * al4 * pom ** 11.0d0
25845         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25846 !c!        dGCVdR = 0.0d0
25847 !c!-------------------------------------------------------------------
25848 !c! Polarization energy
25849 !c! Epol
25850         MomoFac1 = (1.0d0 - chi1 * sqom2)
25851         MomoFac2 = (1.0d0 - chi2 * sqom1)
25852         RR1  = ( R1 * R1 ) / MomoFac1
25853         RR2  = ( R2 * R2 ) / MomoFac2
25854         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25855         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25856         fgb1 = sqrt( RR1 + a12sq * ee1 )
25857         fgb2 = sqrt( RR2 + a12sq * ee2 )
25858         epol = 332.0d0 * eps_inout_fac * (&
25859         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25860 !c!        epol = 0.0d0
25861 !c! derivative of Epol is Gpol...
25862         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25863                   / (fgb1 ** 5.0d0)
25864         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25865                   / (fgb2 ** 5.0d0)
25866         dFGBdR1 = ( (R1 / MomoFac1) &
25867                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25868                 / ( 2.0d0 * fgb1 )
25869         dFGBdR2 = ( (R2 / MomoFac2) &
25870                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25871                 / ( 2.0d0 * fgb2 )
25872         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25873                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25874                  / ( 2.0d0 * fgb1 )
25875         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25876                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25877                  / ( 2.0d0 * fgb2 )
25878         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25879 !c!        dPOLdR1 = 0.0d0
25880         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25881 !c!        dPOLdR2 = 0.0d0
25882         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25883 !c!        dPOLdOM1 = 0.0d0
25884         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25885         pom = (pis / Rhead)**6.0d0
25886         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25887 !c!        Elj = 0.0d0
25888 !c! derivative of Elj is Glj
25889         dGLJdR = 4.0d0 * eps_head &
25890             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25891             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25892 !c!        dGLJdR = 0.0d0
25893 !c!-------------------------------------------------------------------
25894 !c! Equad
25895        IF (Wqd.ne.0.0d0) THEN
25896         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25897              - 37.5d0  * ( sqom1 + sqom2 ) &
25898              + 157.5d0 * ( sqom1 * sqom2 ) &
25899              - 45.0d0  * om1*om2*om12
25900         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25901         Equad = fac * Beta1
25902 !c!        Equad = 0.0d0
25903 !c! derivative of Equad...
25904         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25905 !c!        dQUADdR = 0.0d0
25906         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25907 !c!        dQUADdOM1 = 0.0d0
25908         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25909 !c!        dQUADdOM2 = 0.0d0
25910         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25911        ELSE
25912          Beta1 = 0.0d0
25913          Equad = 0.0d0
25914         END IF
25915 !c!-------------------------------------------------------------------
25916 !c! Return the results
25917 !c! Angular stuff
25918         eom1 = dPOLdOM1 + dQUADdOM1
25919         eom2 = dPOLdOM2 + dQUADdOM2
25920         eom12 = dQUADdOM12
25921 !c! now some magical transformations to project gradient into
25922 !c! three cartesian vectors
25923         DO k = 1, 3
25924          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25925          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25926          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25927         END DO
25928 !c! Radial stuff
25929         DO k = 1, 3
25930          erhead(k) = Rhead_distance(k)/Rhead
25931          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25932          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25933         END DO
25934         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25935         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25936         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25937         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25938         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25939         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25940         facd1 = d1 * vbld_inv(i+nres)
25941         facd2 = d2 * vbld_inv(j+nres)
25942         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25943         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25944         DO k = 1, 3
25945          hawk   = erhead_tail(k,1) + &
25946          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25947          condor = erhead_tail(k,2) + &
25948          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25949
25950          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25951 !c! this acts on hydrophobic center of interaction
25952          gheadtail(k,1,1) = gheadtail(k,1,1) &
25953                          - dGCLdR * pom &
25954                          - dGGBdR * pom &
25955                          - dGCVdR * pom &
25956                          - dPOLdR1 * hawk &
25957                          - dPOLdR2 * (erhead_tail(k,2) &
25958       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25959                          - dGLJdR * pom &
25960                          - dQUADdR * pom&
25961                          - tuna(k) &
25962                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25963                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25964
25965          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25966 !c! this acts on hydrophobic center of interaction
25967          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25968                          + dGCLdR * pom      &
25969                          + dGGBdR * pom      &
25970                          + dGCVdR * pom      &
25971                          + dPOLdR1 * (erhead_tail(k,1) &
25972       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25973                          + dPOLdR2 * condor &
25974                          + dGLJdR * pom &
25975                          + dQUADdR * pom &
25976                          + tuna(k) &
25977                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25978                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25979
25980 !c! this acts on Calpha
25981          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25982                          - dGCLdR * erhead(k)&
25983                          - dGGBdR * erhead(k)&
25984                          - dGCVdR * erhead(k)&
25985                          - dPOLdR1 * erhead_tail(k,1)&
25986                          - dPOLdR2 * erhead_tail(k,2)&
25987                          - dGLJdR * erhead(k) &
25988                          - dQUADdR * erhead(k)&
25989                          - tuna(k)
25990 !c! this acts on Calpha
25991          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25992                           + dGCLdR * erhead(k) &
25993                           + dGGBdR * erhead(k) &
25994                           + dGCVdR * erhead(k) &
25995                           + dPOLdR1 * erhead_tail(k,1) &
25996                           + dPOLdR2 * erhead_tail(k,2) &
25997                           + dGLJdR * erhead(k) &
25998                           + dQUADdR * erhead(k)&
25999                           + tuna(k)
26000         END DO
26001         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26002         eheadtail = eheadtail &
26003                   + wstate(istate, itypi, itypj) &
26004                   * dexp(-betaT * ener(istate))
26005 !c! foreach cartesian dimension
26006         DO k = 1, 3
26007 !c! foreach of two gvdwx and gvdwc
26008          DO l = 1, 4
26009           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26010                            + wstate( istate, itypi, itypj ) &
26011                            * dexp(-betaT * ener(istate)) &
26012                            * gheadtail(k,l,1)
26013           gheadtail(k,l,1) = 0.0d0
26014          END DO
26015         END DO
26016        END DO
26017 !c! Here ended the gigantic DO istate = 1, 4, which starts
26018 !c! at the beggining of the subroutine
26019
26020        DO k = 1, 3
26021         DO l = 1, 4
26022          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26023         END DO
26024         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26025         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26026         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26027         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26028         DO l = 1, 4
26029          gheadtail(k,l,1) = 0.0d0
26030          gheadtail(k,l,2) = 0.0d0
26031         END DO
26032        END DO
26033        eheadtail = (-dlog(eheadtail)) / betaT
26034        dPOLdOM1 = 0.0d0
26035        dPOLdOM2 = 0.0d0
26036        dQUADdOM1 = 0.0d0
26037        dQUADdOM2 = 0.0d0
26038        dQUADdOM12 = 0.0d0
26039        RETURN
26040       END SUBROUTINE energy_quad
26041 !!-----------------------------------------------------------
26042       SUBROUTINE eqn(Epol)
26043       use comm_momo
26044       use calc_data
26045
26046       double precision  facd4, federmaus,epol
26047       alphapol1 = alphapol(itypi,itypj)
26048 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26049        R1 = 0.0d0
26050        DO k = 1, 3
26051 !c! Calculate head-to-tail distances
26052         R1=R1+(ctail(k,2)-chead(k,1))**2
26053        END DO
26054 !c! Pitagoras
26055        R1 = dsqrt(R1)
26056
26057 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26058 !c!     &        +dhead(1,1,itypi,itypj))**2))
26059 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26060 !c!     &        +dhead(2,1,itypi,itypj))**2))
26061 !c--------------------------------------------------------------------
26062 !c Polarization energy
26063 !c Epol
26064        MomoFac1 = (1.0d0 - chi1 * sqom2)
26065        RR1  = R1 * R1 / MomoFac1
26066        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26067        fgb1 = sqrt( RR1 + a12sq * ee1)
26068        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26069        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26070                / (fgb1 ** 5.0d0)
26071        dFGBdR1 = ( (R1 / MomoFac1) &
26072               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26073               / ( 2.0d0 * fgb1 )
26074        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26075                 * (2.0d0 - 0.5d0 * ee1) ) &
26076                 / (2.0d0 * fgb1)
26077        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26078 !c!       dPOLdR1 = 0.0d0
26079        dPOLdOM1 = 0.0d0
26080        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26081        DO k = 1, 3
26082         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26083        END DO
26084        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26085        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26086        facd1 = d1 * vbld_inv(i+nres)
26087        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26088
26089        DO k = 1, 3
26090         hawk = (erhead_tail(k,1) + &
26091         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26092
26093         gvdwx(k,i) = gvdwx(k,i) &
26094                    - dPOLdR1 * hawk
26095         gvdwx(k,j) = gvdwx(k,j) &
26096                    + dPOLdR1 * (erhead_tail(k,1) &
26097        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26098
26099         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26100         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26101
26102        END DO
26103        RETURN
26104       END SUBROUTINE eqn
26105       SUBROUTINE enq(Epol)
26106       use calc_data
26107       use comm_momo
26108        double precision facd3, adler,epol
26109        alphapol2 = alphapol(itypj,itypi)
26110 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26111        R2 = 0.0d0
26112        DO k = 1, 3
26113 !c! Calculate head-to-tail distances
26114         R2=R2+(chead(k,2)-ctail(k,1))**2
26115        END DO
26116 !c! Pitagoras
26117        R2 = dsqrt(R2)
26118
26119 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26120 !c!     &        +dhead(1,1,itypi,itypj))**2))
26121 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26122 !c!     &        +dhead(2,1,itypi,itypj))**2))
26123 !c------------------------------------------------------------------------
26124 !c Polarization energy
26125        MomoFac2 = (1.0d0 - chi2 * sqom1)
26126        RR2  = R2 * R2 / MomoFac2
26127        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26128        fgb2 = sqrt(RR2  + a12sq * ee2)
26129        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26130        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26131                 / (fgb2 ** 5.0d0)
26132        dFGBdR2 = ( (R2 / MomoFac2)  &
26133               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26134               / (2.0d0 * fgb2)
26135        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26136                 * (2.0d0 - 0.5d0 * ee2) ) &
26137                 / (2.0d0 * fgb2)
26138        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26139 !c!       dPOLdR2 = 0.0d0
26140        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26141 !c!       dPOLdOM1 = 0.0d0
26142        dPOLdOM2 = 0.0d0
26143 !c!-------------------------------------------------------------------
26144 !c! Return the results
26145 !c! (See comments in Eqq)
26146        DO k = 1, 3
26147         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26148        END DO
26149        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26150        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26151        facd2 = d2 * vbld_inv(j+nres)
26152        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26153        DO k = 1, 3
26154         condor = (erhead_tail(k,2) &
26155        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26156
26157         gvdwx(k,i) = gvdwx(k,i) &
26158                    - dPOLdR2 * (erhead_tail(k,2) &
26159        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26160         gvdwx(k,j) = gvdwx(k,j)   &
26161                    + dPOLdR2 * condor
26162
26163         gvdwc(k,i) = gvdwc(k,i) &
26164                    - dPOLdR2 * erhead_tail(k,2)
26165         gvdwc(k,j) = gvdwc(k,j) &
26166                    + dPOLdR2 * erhead_tail(k,2)
26167
26168        END DO
26169       RETURN
26170       END SUBROUTINE enq
26171       SUBROUTINE eqd(Ecl,Elj,Epol)
26172       use calc_data
26173       use comm_momo
26174        double precision  facd4, federmaus,ecl,elj,epol
26175        alphapol1 = alphapol(itypi,itypj)
26176        w1        = wqdip(1,itypi,itypj)
26177        w2        = wqdip(2,itypi,itypj)
26178        pis       = sig0head(itypi,itypj)
26179        eps_head   = epshead(itypi,itypj)
26180 !c!-------------------------------------------------------------------
26181 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26182        R1 = 0.0d0
26183        DO k = 1, 3
26184 !c! Calculate head-to-tail distances
26185         R1=R1+(ctail(k,2)-chead(k,1))**2
26186        END DO
26187 !c! Pitagoras
26188        R1 = dsqrt(R1)
26189
26190 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26191 !c!     &        +dhead(1,1,itypi,itypj))**2))
26192 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26193 !c!     &        +dhead(2,1,itypi,itypj))**2))
26194
26195 !c!-------------------------------------------------------------------
26196 !c! ecl
26197        sparrow  = w1 * Qi * om1
26198        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26199        Ecl = sparrow / Rhead**2.0d0 &
26200            - hawk    / Rhead**4.0d0
26201        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26202                  + 4.0d0 * hawk    / Rhead**5.0d0
26203 !c! dF/dom1
26204        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26205 !c! dF/dom2
26206        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26207 !c--------------------------------------------------------------------
26208 !c Polarization energy
26209 !c Epol
26210        MomoFac1 = (1.0d0 - chi1 * sqom2)
26211        RR1  = R1 * R1 / MomoFac1
26212        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26213        fgb1 = sqrt( RR1 + a12sq * ee1)
26214        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26215 !c!       epol = 0.0d0
26216 !c!------------------------------------------------------------------
26217 !c! derivative of Epol is Gpol...
26218        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26219                / (fgb1 ** 5.0d0)
26220        dFGBdR1 = ( (R1 / MomoFac1)  &
26221              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26222              / ( 2.0d0 * fgb1 )
26223        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26224                * (2.0d0 - 0.5d0 * ee1) ) &
26225                / (2.0d0 * fgb1)
26226        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26227 !c!       dPOLdR1 = 0.0d0
26228        dPOLdOM1 = 0.0d0
26229        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26230 !c!       dPOLdOM2 = 0.0d0
26231 !c!-------------------------------------------------------------------
26232 !c! Elj
26233        pom = (pis / Rhead)**6.0d0
26234        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26235 !c! derivative of Elj is Glj
26236        dGLJdR = 4.0d0 * eps_head &
26237           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26238           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26239        DO k = 1, 3
26240         erhead(k) = Rhead_distance(k)/Rhead
26241         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26242        END DO
26243
26244        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26245        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26246        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26247        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26248        facd1 = d1 * vbld_inv(i+nres)
26249        facd2 = d2 * vbld_inv(j+nres)
26250        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26251
26252        DO k = 1, 3
26253         hawk = (erhead_tail(k,1) +  &
26254         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26255
26256         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26257         gvdwx(k,i) = gvdwx(k,i)  &
26258                    - dGCLdR * pom&
26259                    - dPOLdR1 * hawk &
26260                    - dGLJdR * pom
26261
26262         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26263         gvdwx(k,j) = gvdwx(k,j)    &
26264                    + dGCLdR * pom  &
26265                    + dPOLdR1 * (erhead_tail(k,1) &
26266        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26267                    + dGLJdR * pom
26268
26269
26270         gvdwc(k,i) = gvdwc(k,i)          &
26271                    - dGCLdR * erhead(k)  &
26272                    - dPOLdR1 * erhead_tail(k,1) &
26273                    - dGLJdR * erhead(k)
26274
26275         gvdwc(k,j) = gvdwc(k,j)          &
26276                    + dGCLdR * erhead(k)  &
26277                    + dPOLdR1 * erhead_tail(k,1) &
26278                    + dGLJdR * erhead(k)
26279
26280        END DO
26281        RETURN
26282       END SUBROUTINE eqd
26283       SUBROUTINE edq(Ecl,Elj,Epol)
26284 !       IMPLICIT NONE
26285        use comm_momo
26286       use calc_data
26287
26288       double precision  facd3, adler,ecl,elj,epol
26289        alphapol2 = alphapol(itypj,itypi)
26290        w1        = wqdip(1,itypi,itypj)
26291        w2        = wqdip(2,itypi,itypj)
26292        pis       = sig0head(itypi,itypj)
26293        eps_head  = epshead(itypi,itypj)
26294 !c!-------------------------------------------------------------------
26295 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26296        R2 = 0.0d0
26297        DO k = 1, 3
26298 !c! Calculate head-to-tail distances
26299         R2=R2+(chead(k,2)-ctail(k,1))**2
26300        END DO
26301 !c! Pitagoras
26302        R2 = dsqrt(R2)
26303
26304 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26305 !c!     &        +dhead(1,1,itypi,itypj))**2))
26306 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26307 !c!     &        +dhead(2,1,itypi,itypj))**2))
26308
26309
26310 !c!-------------------------------------------------------------------
26311 !c! ecl
26312        sparrow  = w1 * Qi * om1
26313        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26314        ECL = sparrow / Rhead**2.0d0 &
26315            - hawk    / Rhead**4.0d0
26316 !c!-------------------------------------------------------------------
26317 !c! derivative of ecl is Gcl
26318 !c! dF/dr part
26319        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26320                  + 4.0d0 * hawk    / Rhead**5.0d0
26321 !c! dF/dom1
26322        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26323 !c! dF/dom2
26324        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26325 !c--------------------------------------------------------------------
26326 !c Polarization energy
26327 !c Epol
26328        MomoFac2 = (1.0d0 - chi2 * sqom1)
26329        RR2  = R2 * R2 / MomoFac2
26330        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26331        fgb2 = sqrt(RR2  + a12sq * ee2)
26332        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26333        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26334                / (fgb2 ** 5.0d0)
26335        dFGBdR2 = ( (R2 / MomoFac2)  &
26336                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26337                / (2.0d0 * fgb2)
26338        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26339                 * (2.0d0 - 0.5d0 * ee2) ) &
26340                 / (2.0d0 * fgb2)
26341        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26342 !c!       dPOLdR2 = 0.0d0
26343        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26344 !c!       dPOLdOM1 = 0.0d0
26345        dPOLdOM2 = 0.0d0
26346 !c!-------------------------------------------------------------------
26347 !c! Elj
26348        pom = (pis / Rhead)**6.0d0
26349        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26350 !c! derivative of Elj is Glj
26351        dGLJdR = 4.0d0 * eps_head &
26352            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26353            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26354 !c!-------------------------------------------------------------------
26355 !c! Return the results
26356 !c! (see comments in Eqq)
26357        DO k = 1, 3
26358         erhead(k) = Rhead_distance(k)/Rhead
26359         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26360        END DO
26361        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26362        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26363        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26364        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26365        facd1 = d1 * vbld_inv(i+nres)
26366        facd2 = d2 * vbld_inv(j+nres)
26367        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26368        DO k = 1, 3
26369         condor = (erhead_tail(k,2) &
26370        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26371
26372         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26373         gvdwx(k,i) = gvdwx(k,i) &
26374                   - dGCLdR * pom &
26375                   - dPOLdR2 * (erhead_tail(k,2) &
26376        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26377                   - dGLJdR * pom
26378
26379         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26380         gvdwx(k,j) = gvdwx(k,j) &
26381                   + dGCLdR * pom &
26382                   + dPOLdR2 * condor &
26383                   + dGLJdR * pom
26384
26385
26386         gvdwc(k,i) = gvdwc(k,i) &
26387                   - dGCLdR * erhead(k) &
26388                   - dPOLdR2 * erhead_tail(k,2) &
26389                   - dGLJdR * erhead(k)
26390
26391         gvdwc(k,j) = gvdwc(k,j) &
26392                   + dGCLdR * erhead(k) &
26393                   + dPOLdR2 * erhead_tail(k,2) &
26394                   + dGLJdR * erhead(k)
26395
26396        END DO
26397        RETURN
26398       END SUBROUTINE edq
26399       SUBROUTINE edd(ECL)
26400 !       IMPLICIT NONE
26401        use comm_momo
26402       use calc_data
26403
26404        double precision ecl
26405 !c!       csig = sigiso(itypi,itypj)
26406        w1 = wqdip(1,itypi,itypj)
26407        w2 = wqdip(2,itypi,itypj)
26408 !c!-------------------------------------------------------------------
26409 !c! ECL
26410        fac = (om12 - 3.0d0 * om1 * om2)
26411        c1 = (w1 / (Rhead**3.0d0)) * fac
26412        c2 = (w2 / Rhead ** 6.0d0) &
26413           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26414        ECL = c1 - c2
26415 !c!       write (*,*) "w1 = ", w1
26416 !c!       write (*,*) "w2 = ", w2
26417 !c!       write (*,*) "om1 = ", om1
26418 !c!       write (*,*) "om2 = ", om2
26419 !c!       write (*,*) "om12 = ", om12
26420 !c!       write (*,*) "fac = ", fac
26421 !c!       write (*,*) "c1 = ", c1
26422 !c!       write (*,*) "c2 = ", c2
26423 !c!       write (*,*) "Ecl = ", Ecl
26424 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26425 !c!       write (*,*) "c2_2 = ",
26426 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26427 !c!-------------------------------------------------------------------
26428 !c! dervative of ECL is GCL...
26429 !c! dECL/dr
26430        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26431        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26432           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26433        dGCLdR = c1 - c2
26434 !c! dECL/dom1
26435        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26436        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26437           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26438        dGCLdOM1 = c1 - c2
26439 !c! dECL/dom2
26440        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26441        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26442           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26443        dGCLdOM2 = c1 - c2
26444 !c! dECL/dom12
26445        c1 = w1 / (Rhead ** 3.0d0)
26446        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26447        dGCLdOM12 = c1 - c2
26448 !c!-------------------------------------------------------------------
26449 !c! Return the results
26450 !c! (see comments in Eqq)
26451        DO k= 1, 3
26452         erhead(k) = Rhead_distance(k)/Rhead
26453        END DO
26454        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26455        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26456        facd1 = d1 * vbld_inv(i+nres)
26457        facd2 = d2 * vbld_inv(j+nres)
26458        DO k = 1, 3
26459
26460         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26461         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26462         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26463         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26464
26465         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26466         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26467        END DO
26468        RETURN
26469       END SUBROUTINE edd
26470       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26471 !       IMPLICIT NONE
26472        use comm_momo
26473       use calc_data
26474
26475        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26476        eps_out=80.0d0
26477        itypi = itype(i,1)
26478        itypj = itype(j,1)
26479 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26480 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26481 !c!       t_bath = 300
26482 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26483        Rb=0.001986d0
26484        BetaT = 1.0d0 / (298.0d0 * Rb)
26485 !c! Gay-berne var's
26486        sig0ij = sigma( itypi,itypj )
26487        chi1   = chi( itypi, itypj )
26488        chi2   = chi( itypj, itypi )
26489        chi12  = chi1 * chi2
26490        chip1  = chipp( itypi, itypj )
26491        chip2  = chipp( itypj, itypi )
26492        chip12 = chip1 * chip2
26493 !       chi1=0.0
26494 !       chi2=0.0
26495 !       chi12=0.0
26496 !       chip1=0.0
26497 !       chip2=0.0
26498 !       chip12=0.0
26499 !c! not used by momo potential, but needed by sc_angular which is shared
26500 !c! by all energy_potential subroutines
26501        alf1   = 0.0d0
26502        alf2   = 0.0d0
26503        alf12  = 0.0d0
26504 !c! location, location, location
26505 !       xj  = c( 1, nres+j ) - xi
26506 !       yj  = c( 2, nres+j ) - yi
26507 !       zj  = c( 3, nres+j ) - zi
26508        dxj = dc_norm( 1, nres+j )
26509        dyj = dc_norm( 2, nres+j )
26510        dzj = dc_norm( 3, nres+j )
26511 !c! distance from center of chain(?) to polar/charged head
26512 !c!       write (*,*) "istate = ", 1
26513 !c!       write (*,*) "ii = ", 1
26514 !c!       write (*,*) "jj = ", 1
26515        d1 = dhead(1, 1, itypi, itypj)
26516        d2 = dhead(2, 1, itypi, itypj)
26517 !c! ai*aj from Fgb
26518        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26519 !c!       a12sq = a12sq * a12sq
26520 !c! charge of amino acid itypi is...
26521        Qi  = icharge(itypi)
26522        Qj  = icharge(itypj)
26523        Qij = Qi * Qj
26524 !c! chis1,2,12
26525        chis1 = chis(itypi,itypj)
26526        chis2 = chis(itypj,itypi)
26527        chis12 = chis1 * chis2
26528        sig1 = sigmap1(itypi,itypj)
26529        sig2 = sigmap2(itypi,itypj)
26530 !c!       write (*,*) "sig1 = ", sig1
26531 !c!       write (*,*) "sig2 = ", sig2
26532 !c! alpha factors from Fcav/Gcav
26533        b1cav = alphasur(1,itypi,itypj)
26534 !       b1cav=0.0
26535        b2cav = alphasur(2,itypi,itypj)
26536        b3cav = alphasur(3,itypi,itypj)
26537        b4cav = alphasur(4,itypi,itypj)
26538        wqd = wquad(itypi, itypj)
26539 !c! used by Fgb
26540        eps_in = epsintab(itypi,itypj)
26541        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26542 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
26543 !c!-------------------------------------------------------------------
26544 !c! tail location and distance calculations
26545        Rtail = 0.0d0
26546        DO k = 1, 3
26547         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26548         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26549        END DO
26550 !c! tail distances will be themselves usefull elswhere
26551 !c1 (in Gcav, for example)
26552        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26553        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26554        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26555        Rtail = dsqrt(  &
26556           (Rtail_distance(1)*Rtail_distance(1))  &
26557         + (Rtail_distance(2)*Rtail_distance(2))  &
26558         + (Rtail_distance(3)*Rtail_distance(3)))
26559 !c!-------------------------------------------------------------------
26560 !c! Calculate location and distance between polar heads
26561 !c! distance between heads
26562 !c! for each one of our three dimensional space...
26563        d1 = dhead(1, 1, itypi, itypj)
26564        d2 = dhead(2, 1, itypi, itypj)
26565
26566        DO k = 1,3
26567 !c! location of polar head is computed by taking hydrophobic centre
26568 !c! and moving by a d1 * dc_norm vector
26569 !c! see unres publications for very informative images
26570         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26571         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26572 !c! distance
26573 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26574 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26575         Rhead_distance(k) = chead(k,2) - chead(k,1)
26576        END DO
26577 !c! pitagoras (root of sum of squares)
26578        Rhead = dsqrt(   &
26579           (Rhead_distance(1)*Rhead_distance(1)) &
26580         + (Rhead_distance(2)*Rhead_distance(2)) &
26581         + (Rhead_distance(3)*Rhead_distance(3)))
26582 !c!-------------------------------------------------------------------
26583 !c! zero everything that should be zero'ed
26584        Egb = 0.0d0
26585        ECL = 0.0d0
26586        Elj = 0.0d0
26587        Equad = 0.0d0
26588        Epol = 0.0d0
26589        eheadtail = 0.0d0
26590        dGCLdOM1 = 0.0d0
26591        dGCLdOM2 = 0.0d0
26592        dGCLdOM12 = 0.0d0
26593        dPOLdOM1 = 0.0d0
26594        dPOLdOM2 = 0.0d0
26595        RETURN
26596       END SUBROUTINE elgrad_init
26597
26598       double precision function tschebyshev(m,n,x,y)
26599       implicit none
26600       integer i,m,n
26601       double precision x(n),y,yy(0:maxvar),aux
26602 !c Tschebyshev polynomial. Note that the first term is omitted
26603 !c m=0: the constant term is included
26604 !c m=1: the constant term is not included
26605       yy(0)=1.0d0
26606       yy(1)=y
26607       do i=2,n
26608         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
26609       enddo
26610       aux=0.0d0
26611       do i=m,n
26612         aux=aux+x(i)*yy(i)
26613       enddo
26614       tschebyshev=aux
26615       return
26616       end function tschebyshev
26617 !C--------------------------------------------------------------------------
26618       double precision function gradtschebyshev(m,n,x,y)
26619       implicit none
26620       integer i,m,n
26621       double precision x(n+1),y,yy(0:maxvar),aux
26622 !c Tschebyshev polynomial. Note that the first term is omitted
26623 !c m=0: the constant term is included
26624 !c m=1: the constant term is not included
26625       yy(0)=1.0d0
26626       yy(1)=2.0d0*y
26627       do i=2,n
26628         yy(i)=2*y*yy(i-1)-yy(i-2)
26629       enddo
26630       aux=0.0d0
26631       do i=m,n
26632         aux=aux+x(i+1)*yy(i)*(i+1)
26633 !C        print *, x(i+1),yy(i),i
26634       enddo
26635       gradtschebyshev=aux
26636       return
26637       end function gradtschebyshev
26638
26639
26640
26641
26642
26643       end module energy