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       endif
 797       endif
 798       if (tubemode.eq.1) then
 799        call calctube(etube)
 800       else if (tubemode.eq.2) then
 801        call calctube2(etube)
 802       elseif (tubemode.eq.3) then
 803        call calcnano(etube)
 804       else
 805        etube=0.0d0
 806       endif
 807 !--------------------------------------------------------
 808 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 809 !      print *,"before",ees,evdw1,ecorr
 810 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 811       if (nres_molec(2).gt.0) then
 812       call ebond_nucl(estr_nucl)
 813       call ebend_nucl(ebe_nucl)
 814       call etor_nucl(etors_nucl)
 815       call esb_gb(evdwsb,eelsb)
 816       call epp_nucl_sub(evdwpp,eespp)
 817       call epsb(evdwpsb,eelpsb)
 818       call esb(esbloc)
 819       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 820       else
 821        etors_nucl=0.0d0
 822        estr_nucl=0.0d0
 823        ecorr3_nucl=0.0d0
 824        ebe_nucl=0.0d0
 825        evdwsb=0.0d0
 826        eelsb=0.0d0
 827        esbloc=0.0d0
 828        evdwpsb=0.0d0
 829        eelpsb=0.0d0
 830        evdwpp=0.0d0
 831        eespp=0.0d0
 832       endif
 833 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 834 !      print *,"before ecatcat"
 835       if (nfgtasks.gt.1) then
 836       if (fg_rank.eq.0) then
 837       call ecatcat(ecationcation)
 838       endif
 839       else
 840       call ecatcat(ecationcation)
 841       endif
 842       call ecat_prot(ecation_prot)
 843       if (nres_molec(2).gt.0) then
 844       call eprot_sc_base(escbase)
 845       call epep_sc_base(epepbase)
 846       call eprot_sc_phosphate(escpho)
 847       call eprot_pep_phosphate(epeppho)
 848       else
 849       epepbase=0.0
 850       escbase=0.0
 851       escpho=0.0
 852       epeppho=0.0
 853       endif
 854 !      call ecatcat(ecationcation)
 855 !      print *,"after ebend", ebe_nucl
 856 #ifdef TIMING
 857       time_enecalc=time_enecalc+MPI_Wtime()-time00
 858 #endif
 859 !      print *,"Processor",myrank," computed Uconstr"
 860 #ifdef TIMING
 861       time00=MPI_Wtime()
 862 #endif
 863 !
 864 ! Sum the energies
 865 !
 866       energia(1)=evdw
 867 #ifdef SCP14
 868       energia(2)=evdw2-evdw2_14
 869       energia(18)=evdw2_14
 870 #else
 871       energia(2)=evdw2
 872       energia(18)=0.0d0
 873 #endif
 874 #ifdef SPLITELE
 875       energia(3)=ees
 876       energia(16)=evdw1
 877 #else
 878       energia(3)=ees+evdw1
 879       energia(16)=0.0d0
 880 #endif
 881       energia(4)=ecorr
 882       energia(5)=ecorr5
 883       energia(6)=ecorr6
 884       energia(7)=eel_loc
 885       energia(8)=eello_turn3
 886       energia(9)=eello_turn4
 887       energia(10)=eturn6
 888       energia(11)=ebe
 889       energia(12)=escloc
 890       energia(13)=etors
 891       energia(14)=etors_d
 892       energia(15)=ehpb
 893       energia(19)=edihcnstr
 894       energia(17)=estr
 895       energia(20)=Uconst+Uconst_back
 896       energia(21)=esccor
 897       energia(22)=eliptran
 898       energia(23)=Eafmforce
 899       energia(24)=ethetacnstr
 900       energia(25)=etube
 901 !---------------------------------------------------------------
 902       energia(26)=evdwpp
 903       energia(27)=eespp
 904       energia(28)=evdwpsb
 905       energia(29)=eelpsb
 906       energia(30)=evdwsb
 907       energia(31)=eelsb
 908       energia(32)=estr_nucl
 909       energia(33)=ebe_nucl
 910       energia(34)=esbloc
 911       energia(35)=etors_nucl
 912       energia(36)=etors_d_nucl
 913       energia(37)=ecorr_nucl
 914       energia(38)=ecorr3_nucl
 915 !----------------------------------------------------------------------
 916 !    Here are the energies showed per procesor if the are more processors
 917 !    per molecule then we sum it up in sum_energy subroutine
 918 !      print *," Processor",myrank," calls SUM_ENERGY"
 919       energia(41)=ecation_prot
 920       energia(42)=ecationcation
 921       energia(46)=escbase
 922       energia(47)=epepbase
 923       energia(48)=escpho
 924       energia(49)=epeppho
 925       call sum_energy(energia,.true.)
 926       if (dyn_ss) call dyn_set_nss
 927 !      print *," Processor",myrank," left SUM_ENERGY"
 928 #ifdef TIMING
 929       time_sumene=time_sumene+MPI_Wtime()-time00
 930 #endif
 931 !        call enerprint(energia)
 932 !elwrite(iout,*)"finish etotal"
 933       return
 934       end subroutine etotal
 935 !-----------------------------------------------------------------------------
 936       subroutine sum_energy(energia,reduce)
 937 !      implicit real*8 (a-h,o-z)
 938 !      include 'DIMENSIONS'
 939 #ifndef ISNAN
 940       external proc_proc
 941 #ifdef WINPGI
 942 !MS$ATTRIBUTES C ::  proc_proc
 943 #endif
 944 #endif
 945 #ifdef MPI
 946       include "mpif.h"
 947 #endif
 948 !      include 'COMMON.SETUP'
 949 !      include 'COMMON.IOUNITS'
 950       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 951 !      include 'COMMON.FFIELD'
 952 !      include 'COMMON.DERIV'
 953 !      include 'COMMON.INTERACT'
 954 !      include 'COMMON.SBRIDGE'
 955 !      include 'COMMON.CHAIN'
 956 !      include 'COMMON.VAR'
 957 !      include 'COMMON.CONTROL'
 958 !      include 'COMMON.TIME1'
 959       logical :: reduce
 960       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 961       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 962       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 963         eliptran,etube, Eafmforce,ethetacnstr
 964       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 965                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 966                       ecorr3_nucl
 967       real(kind=8) :: ecation_prot,ecationcation
 968       real(kind=8) :: escbase,epepbase,escpho,epeppho
 969       integer :: i
 970 #ifdef MPI
 971       integer :: ierr
 972       real(kind=8) :: time00
 973       if (nfgtasks.gt.1 .and. reduce) then
 974
 975 #ifdef DEBUG
 976         write (iout,*) "energies before REDUCE"
 977         call enerprint(energia)
 978         call flush(iout)
 979 #endif
 980         do i=0,n_ene
 981           enebuff(i)=energia(i)
 982         enddo
 983         time00=MPI_Wtime()
 984         call MPI_Barrier(FG_COMM,IERR)
 985         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 986         time00=MPI_Wtime()
 987         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 988           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 989 #ifdef DEBUG
 990         write (iout,*) "energies after REDUCE"
 991         call enerprint(energia)
 992         call flush(iout)
 993 #endif
 994         time_Reduce=time_Reduce+MPI_Wtime()-time00
 995       endif
 996       if (fg_rank.eq.0) then
 997 #endif
 998       evdw=energia(1)
 999 #ifdef SCP14
1000       evdw2=energia(2)+energia(18)
1001       evdw2_14=energia(18)
1002 #else
1003       evdw2=energia(2)
1004 #endif
1005 #ifdef SPLITELE
1006       ees=energia(3)
1007       evdw1=energia(16)
1008 #else
1009       ees=energia(3)
1010       evdw1=0.0d0
1011 #endif
1012       ecorr=energia(4)
1013       ecorr5=energia(5)
1014       ecorr6=energia(6)
1015       eel_loc=energia(7)
1016       eello_turn3=energia(8)
1017       eello_turn4=energia(9)
1018       eturn6=energia(10)
1019       ebe=energia(11)
1020       escloc=energia(12)
1021       etors=energia(13)
1022       etors_d=energia(14)
1023       ehpb=energia(15)
1024       edihcnstr=energia(19)
1025       estr=energia(17)
1026       Uconst=energia(20)
1027       esccor=energia(21)
1028       eliptran=energia(22)
1029       Eafmforce=energia(23)
1030       ethetacnstr=energia(24)
1031       etube=energia(25)
1032       evdwpp=energia(26)
1033       eespp=energia(27)
1034       evdwpsb=energia(28)
1035       eelpsb=energia(29)
1036       evdwsb=energia(30)
1037       eelsb=energia(31)
1038       estr_nucl=energia(32)
1039       ebe_nucl=energia(33)
1040       esbloc=energia(34)
1041       etors_nucl=energia(35)
1042       etors_d_nucl=energia(36)
1043       ecorr_nucl=energia(37)
1044       ecorr3_nucl=energia(38)
1045       ecation_prot=energia(41)
1046       ecationcation=energia(42)
1047       escbase=energia(46)
1048       epepbase=energia(47)
1049       escpho=energia(48)
1050       epeppho=energia(49)
1051 !      energia(41)=ecation_prot
1052 !      energia(42)=ecationcation
1053
1054
1055 #ifdef SPLITELE
1056       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1057        +wang*ebe+wtor*etors+wscloc*escloc &
1058        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1059        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1060        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1061        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1062        +Eafmforce+ethetacnstr  &
1063        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1064        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1065        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1066        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1067        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1068        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1069 #else
1070       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1071        +wang*ebe+wtor*etors+wscloc*escloc &
1072        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1073        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1074        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1075        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1076        +Eafmforce+ethetacnstr &
1077        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1078        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1079        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1080        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1081        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1082        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1083 #endif
1084       energia(0)=etot
1085 ! detecting NaNQ
1086 #ifdef ISNAN
1087 #ifdef AIX
1088       if (isnan(etot).ne.0) energia(0)=1.0d+99
1089 #else
1090       if (isnan(etot)) energia(0)=1.0d+99
1091 #endif
1092 #else
1093       i=0
1094 #ifdef WINPGI
1095       idumm=proc_proc(etot,i)
1096 #else
1097       call proc_proc(etot,i)
1098 #endif
1099       if(i.eq.1)energia(0)=1.0d+99
1100 #endif
1101 #ifdef MPI
1102       endif
1103 #endif
1104 !      call enerprint(energia)
1105       call flush(iout)
1106       return
1107       end subroutine sum_energy
1108 !-----------------------------------------------------------------------------
1109       subroutine rescale_weights(t_bath)
1110 !      implicit real*8 (a-h,o-z)
1111 #ifdef MPI
1112       include 'mpif.h'
1113 #endif
1114 !      include 'DIMENSIONS'
1115 !      include 'COMMON.IOUNITS'
1116 !      include 'COMMON.FFIELD'
1117 !      include 'COMMON.SBRIDGE'
1118       real(kind=8) :: kfac=2.4d0
1119       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1120 !el local variables
1121       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1122       real(kind=8) :: T0=3.0d2
1123       integer :: ierror
1124 !      facT=temp0/t_bath
1125 !      facT=2*temp0/(t_bath+temp0)
1126       if (rescale_mode.eq.0) then
1127         facT(1)=1.0d0
1128         facT(2)=1.0d0
1129         facT(3)=1.0d0
1130         facT(4)=1.0d0
1131         facT(5)=1.0d0
1132         facT(6)=1.0d0
1133       else if (rescale_mode.eq.1) then
1134         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1135         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1136         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1137         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1138         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1139 #ifdef WHAM_RUN
1140 !#if defined(WHAM_RUN) || defined(CLUSTER)
1141 #if defined(FUNCTH)
1142 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1143         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1144 #elif defined(FUNCT)
1145         facT(6)=t_bath/T0
1146 #else
1147         facT(6)=1.0d0
1148 #endif
1149 #endif
1150       else if (rescale_mode.eq.2) then
1151         x=t_bath/temp0
1152         x2=x*x
1153         x3=x2*x
1154         x4=x3*x
1155         x5=x4*x
1156         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1157         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1158         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1159         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1160         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1161 #ifdef WHAM_RUN
1162 !#if defined(WHAM_RUN) || defined(CLUSTER)
1163 #if defined(FUNCTH)
1164         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1165 #elif defined(FUNCT)
1166         facT(6)=t_bath/T0
1167 #else
1168         facT(6)=1.0d0
1169 #endif
1170 #endif
1171       else
1172         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1173         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1174 #ifdef MPI
1175        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1176 #endif
1177        stop 555
1178       endif
1179       welec=weights(3)*fact(1)
1180       wcorr=weights(4)*fact(3)
1181       wcorr5=weights(5)*fact(4)
1182       wcorr6=weights(6)*fact(5)
1183       wel_loc=weights(7)*fact(2)
1184       wturn3=weights(8)*fact(2)
1185       wturn4=weights(9)*fact(3)
1186       wturn6=weights(10)*fact(5)
1187       wtor=weights(13)*fact(1)
1188       wtor_d=weights(14)*fact(2)
1189       wsccor=weights(21)*fact(1)
1190
1191       return
1192       end subroutine rescale_weights
1193 !-----------------------------------------------------------------------------
1194       subroutine enerprint(energia)
1195 !      implicit real*8 (a-h,o-z)
1196 !      include 'DIMENSIONS'
1197 !      include 'COMMON.IOUNITS'
1198 !      include 'COMMON.FFIELD'
1199 !      include 'COMMON.SBRIDGE'
1200 !      include 'COMMON.MD'
1201       real(kind=8) :: energia(0:n_ene)
1202 !el local variables
1203       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1204       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1205       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1206        etube,ethetacnstr,Eafmforce
1207       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1208                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1209                       ecorr3_nucl
1210       real(kind=8) :: ecation_prot,ecationcation
1211       real(kind=8) :: escbase,epepbase,escpho,epeppho
1212
1213       etot=energia(0)
1214       evdw=energia(1)
1215       evdw2=energia(2)
1216 #ifdef SCP14
1217       evdw2=energia(2)+energia(18)
1218 #else
1219       evdw2=energia(2)
1220 #endif
1221       ees=energia(3)
1222 #ifdef SPLITELE
1223       evdw1=energia(16)
1224 #endif
1225       ecorr=energia(4)
1226       ecorr5=energia(5)
1227       ecorr6=energia(6)
1228       eel_loc=energia(7)
1229       eello_turn3=energia(8)
1230       eello_turn4=energia(9)
1231       eello_turn6=energia(10)
1232       ebe=energia(11)
1233       escloc=energia(12)
1234       etors=energia(13)
1235       etors_d=energia(14)
1236       ehpb=energia(15)
1237       edihcnstr=energia(19)
1238       estr=energia(17)
1239       Uconst=energia(20)
1240       esccor=energia(21)
1241       eliptran=energia(22)
1242       Eafmforce=energia(23)
1243       ethetacnstr=energia(24)
1244       etube=energia(25)
1245       evdwpp=energia(26)
1246       eespp=energia(27)
1247       evdwpsb=energia(28)
1248       eelpsb=energia(29)
1249       evdwsb=energia(30)
1250       eelsb=energia(31)
1251       estr_nucl=energia(32)
1252       ebe_nucl=energia(33)
1253       esbloc=energia(34)
1254       etors_nucl=energia(35)
1255       etors_d_nucl=energia(36)
1256       ecorr_nucl=energia(37)
1257       ecorr3_nucl=energia(38)
1258       ecation_prot=energia(41)
1259       ecationcation=energia(42)
1260       escbase=energia(46)
1261       epepbase=energia(47)
1262       escpho=energia(48)
1263       epeppho=energia(49)
1264 #ifdef SPLITELE
1265       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1266         estr,wbond,ebe,wang,&
1267         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1268         ecorr,wcorr,&
1269         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1270         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1271         edihcnstr,ethetacnstr,ebr*nss,&
1272         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1273         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1274         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1275         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1276         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1277         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1278         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1279         etot
1280    10 format (/'Virtual-chain energies:'// &
1281        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1282        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1283        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1284        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1285        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1286        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1287        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1288        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1289        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1290        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1291        ' (SS bridges & dist. cnstr.)'/ &
1292        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1293        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1294        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1295        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1296        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1297        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1298        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1299        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1300        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1301        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1302        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1303        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1304        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1305        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1306        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1307        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1308        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1309        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1310        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1311        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1312        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1313        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1314        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1315        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1316        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1317        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1318        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1319        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1320        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1321        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1322        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1323        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1324        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1325        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1326        'ETOT=  ',1pE16.6,' (total)')
1327 #else
1328       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1329         estr,wbond,ebe,wang,&
1330         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1331         ecorr,wcorr,&
1332         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1333         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1334         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1335         etube,wtube, &
1336         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1337         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1338         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1339         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1340         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1341         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1342         etot
1343    10 format (/'Virtual-chain energies:'// &
1344        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1345        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1346        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1347        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1348        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1349        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1350        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1351        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1352        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1353        ' (SS bridges & dist. cnstr.)'/ &
1354        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1355        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1356        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1357        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1358        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1359        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1360        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1361        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1362        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1363        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1364        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1365        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1366        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1367        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1368        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1369        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1370        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1371        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1372        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1373        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1374        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1375        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1376        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1377        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1378        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1379        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1380        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1381        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1382        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1383        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1384        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1385        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1386        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1387        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1388        'ETOT=  ',1pE16.6,' (total)')
1389 #endif
1390       return
1391       end subroutine enerprint
1392 !-----------------------------------------------------------------------------
1393       subroutine elj(evdw)
1394 !
1395 ! This subroutine calculates the interaction energy of nonbonded side chains
1396 ! assuming the LJ potential of interaction.
1397 !
1398 !      implicit real*8 (a-h,o-z)
1399 !      include 'DIMENSIONS'
1400       real(kind=8),parameter :: accur=1.0d-10
1401 !      include 'COMMON.GEO'
1402 !      include 'COMMON.VAR'
1403 !      include 'COMMON.LOCAL'
1404 !      include 'COMMON.CHAIN'
1405 !      include 'COMMON.DERIV'
1406 !      include 'COMMON.INTERACT'
1407 !      include 'COMMON.TORSION'
1408 !      include 'COMMON.SBRIDGE'
1409 !      include 'COMMON.NAMES'
1410 !      include 'COMMON.IOUNITS'
1411 !      include 'COMMON.CONTACTS'
1412       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1413       integer :: num_conti
1414 !el local variables
1415       integer :: i,itypi,iint,j,itypi1,itypj,k
1416       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1417       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1418       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1419
1420 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1421       evdw=0.0D0
1422 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1423 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1424 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1425 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1426
1427       do i=iatsc_s,iatsc_e
1428         itypi=iabs(itype(i,1))
1429         if (itypi.eq.ntyp1) cycle
1430         itypi1=iabs(itype(i+1,1))
1431         xi=c(1,nres+i)
1432         yi=c(2,nres+i)
1433         zi=c(3,nres+i)
1434 ! Change 12/1/95
1435         num_conti=0
1436 !
1437 ! Calculate SC interaction energy.
1438 !
1439         do iint=1,nint_gr(i)
1440 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1441 !d   &                  'iend=',iend(i,iint)
1442           do j=istart(i,iint),iend(i,iint)
1443             itypj=iabs(itype(j,1))
1444             if (itypj.eq.ntyp1) cycle
1445             xj=c(1,nres+j)-xi
1446             yj=c(2,nres+j)-yi
1447             zj=c(3,nres+j)-zi
1448 ! Change 12/1/95 to calculate four-body interactions
1449             rij=xj*xj+yj*yj+zj*zj
1450             rrij=1.0D0/rij
1451 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1452             eps0ij=eps(itypi,itypj)
1453             fac=rrij**expon2
1454             e1=fac*fac*aa_aq(itypi,itypj)
1455             e2=fac*bb_aq(itypi,itypj)
1456             evdwij=e1+e2
1457 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1458 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1459 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1460 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1461 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1462 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1463             evdw=evdw+evdwij
1464 !
1465 ! Calculate the components of the gradient in DC and X
1466 !
1467             fac=-rrij*(e1+evdwij)
1468             gg(1)=xj*fac
1469             gg(2)=yj*fac
1470             gg(3)=zj*fac
1471             do k=1,3
1472               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1473               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1474               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1475               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1476             enddo
1477 !grad            do k=i,j-1
1478 !grad              do l=1,3
1479 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1480 !grad              enddo
1481 !grad            enddo
1482 !
1483 ! 12/1/95, revised on 5/20/97
1484 !
1485 ! Calculate the contact function. The ith column of the array JCONT will
1486 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1487 ! greater than I). The arrays FACONT and GACONT will contain the values of
1488 ! the contact function and its derivative.
1489 !
1490 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1491 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1492 ! Uncomment next line, if the correlation interactions are contact function only
1493             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1494               rij=dsqrt(rij)
1495               sigij=sigma(itypi,itypj)
1496               r0ij=rs0(itypi,itypj)
1497 !
1498 ! Check whether the SC's are not too far to make a contact.
1499 !
1500               rcut=1.5d0*r0ij
1501               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1502 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1503 !
1504               if (fcont.gt.0.0D0) then
1505 ! If the SC-SC distance if close to sigma, apply spline.
1506 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1507 !Adam &             fcont1,fprimcont1)
1508 !Adam           fcont1=1.0d0-fcont1
1509 !Adam           if (fcont1.gt.0.0d0) then
1510 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1511 !Adam             fcont=fcont*fcont1
1512 !Adam           endif
1513 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1514 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1515 !ga             do k=1,3
1516 !ga               gg(k)=gg(k)*eps0ij
1517 !ga             enddo
1518 !ga             eps0ij=-evdwij*eps0ij
1519 ! Uncomment for AL's type of SC correlation interactions.
1520 !adam           eps0ij=-evdwij
1521                 num_conti=num_conti+1
1522                 jcont(num_conti,i)=j
1523                 facont(num_conti,i)=fcont*eps0ij
1524                 fprimcont=eps0ij*fprimcont/rij
1525                 fcont=expon*fcont
1526 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1527 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1528 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1529 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1530                 gacont(1,num_conti,i)=-fprimcont*xj
1531                 gacont(2,num_conti,i)=-fprimcont*yj
1532                 gacont(3,num_conti,i)=-fprimcont*zj
1533 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1534 !d              write (iout,'(2i3,3f10.5)')
1535 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1536               endif
1537             endif
1538           enddo      ! j
1539         enddo        ! iint
1540 ! Change 12/1/95
1541         num_cont(i)=num_conti
1542       enddo          ! i
1543       do i=1,nct
1544         do j=1,3
1545           gvdwc(j,i)=expon*gvdwc(j,i)
1546           gvdwx(j,i)=expon*gvdwx(j,i)
1547         enddo
1548       enddo
1549 !******************************************************************************
1550 !
1551 !                              N O T E !!!
1552 !
1553 ! To save time, the factor of EXPON has been extracted from ALL components
1554 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1555 ! use!
1556 !
1557 !******************************************************************************
1558       return
1559       end subroutine elj
1560 !-----------------------------------------------------------------------------
1561       subroutine eljk(evdw)
1562 !
1563 ! This subroutine calculates the interaction energy of nonbonded side chains
1564 ! assuming the LJK potential of interaction.
1565 !
1566 !      implicit real*8 (a-h,o-z)
1567 !      include 'DIMENSIONS'
1568 !      include 'COMMON.GEO'
1569 !      include 'COMMON.VAR'
1570 !      include 'COMMON.LOCAL'
1571 !      include 'COMMON.CHAIN'
1572 !      include 'COMMON.DERIV'
1573 !      include 'COMMON.INTERACT'
1574 !      include 'COMMON.IOUNITS'
1575 !      include 'COMMON.NAMES'
1576       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1577       logical :: scheck
1578 !el local variables
1579       integer :: i,iint,j,itypi,itypi1,k,itypj
1580       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1581       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1582
1583 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1584       evdw=0.0D0
1585       do i=iatsc_s,iatsc_e
1586         itypi=iabs(itype(i,1))
1587         if (itypi.eq.ntyp1) cycle
1588         itypi1=iabs(itype(i+1,1))
1589         xi=c(1,nres+i)
1590         yi=c(2,nres+i)
1591         zi=c(3,nres+i)
1592 !
1593 ! Calculate SC interaction energy.
1594 !
1595         do iint=1,nint_gr(i)
1596           do j=istart(i,iint),iend(i,iint)
1597             itypj=iabs(itype(j,1))
1598             if (itypj.eq.ntyp1) cycle
1599             xj=c(1,nres+j)-xi
1600             yj=c(2,nres+j)-yi
1601             zj=c(3,nres+j)-zi
1602             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1603             fac_augm=rrij**expon
1604             e_augm=augm(itypi,itypj)*fac_augm
1605             r_inv_ij=dsqrt(rrij)
1606             rij=1.0D0/r_inv_ij
1607             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1608             fac=r_shift_inv**expon
1609             e1=fac*fac*aa_aq(itypi,itypj)
1610             e2=fac*bb_aq(itypi,itypj)
1611             evdwij=e_augm+e1+e2
1612 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1613 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1614 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1615 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1616 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1617 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1618 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1619             evdw=evdw+evdwij
1620 !
1621 ! Calculate the components of the gradient in DC and X
1622 !
1623             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1624             gg(1)=xj*fac
1625             gg(2)=yj*fac
1626             gg(3)=zj*fac
1627             do k=1,3
1628               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1629               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1630               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1631               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1632             enddo
1633 !grad            do k=i,j-1
1634 !grad              do l=1,3
1635 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1636 !grad              enddo
1637 !grad            enddo
1638           enddo      ! j
1639         enddo        ! iint
1640       enddo          ! i
1641       do i=1,nct
1642         do j=1,3
1643           gvdwc(j,i)=expon*gvdwc(j,i)
1644           gvdwx(j,i)=expon*gvdwx(j,i)
1645         enddo
1646       enddo
1647       return
1648       end subroutine eljk
1649 !-----------------------------------------------------------------------------
1650       subroutine ebp(evdw)
1651 !
1652 ! This subroutine calculates the interaction energy of nonbonded side chains
1653 ! assuming the Berne-Pechukas potential of interaction.
1654 !
1655       use comm_srutu
1656       use calc_data
1657 !      implicit real*8 (a-h,o-z)
1658 !      include 'DIMENSIONS'
1659 !      include 'COMMON.GEO'
1660 !      include 'COMMON.VAR'
1661 !      include 'COMMON.LOCAL'
1662 !      include 'COMMON.CHAIN'
1663 !      include 'COMMON.DERIV'
1664 !      include 'COMMON.NAMES'
1665 !      include 'COMMON.INTERACT'
1666 !      include 'COMMON.IOUNITS'
1667 !      include 'COMMON.CALC'
1668       use comm_srutu
1669 !el      integer :: icall
1670 !el      common /srutu/ icall
1671 !     double precision rrsave(maxdim)
1672       logical :: lprn
1673 !el local variables
1674       integer :: iint,itypi,itypi1,itypj
1675       real(kind=8) :: rrij,xi,yi,zi
1676       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1677
1678 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1679       evdw=0.0D0
1680 !     if (icall.eq.0) then
1681 !       lprn=.true.
1682 !     else
1683         lprn=.false.
1684 !     endif
1685 !el      ind=0
1686       do i=iatsc_s,iatsc_e
1687         itypi=iabs(itype(i,1))
1688         if (itypi.eq.ntyp1) cycle
1689         itypi1=iabs(itype(i+1,1))
1690         xi=c(1,nres+i)
1691         yi=c(2,nres+i)
1692         zi=c(3,nres+i)
1693         dxi=dc_norm(1,nres+i)
1694         dyi=dc_norm(2,nres+i)
1695         dzi=dc_norm(3,nres+i)
1696 !        dsci_inv=dsc_inv(itypi)
1697         dsci_inv=vbld_inv(i+nres)
1698 !
1699 ! Calculate SC interaction energy.
1700 !
1701         do iint=1,nint_gr(i)
1702           do j=istart(i,iint),iend(i,iint)
1703 !el            ind=ind+1
1704             itypj=iabs(itype(j,1))
1705             if (itypj.eq.ntyp1) cycle
1706 !            dscj_inv=dsc_inv(itypj)
1707             dscj_inv=vbld_inv(j+nres)
1708             chi1=chi(itypi,itypj)
1709             chi2=chi(itypj,itypi)
1710             chi12=chi1*chi2
1711             chip1=chip(itypi)
1712             chip2=chip(itypj)
1713             chip12=chip1*chip2
1714             alf1=alp(itypi)
1715             alf2=alp(itypj)
1716             alf12=0.5D0*(alf1+alf2)
1717 ! For diagnostics only!!!
1718 !           chi1=0.0D0
1719 !           chi2=0.0D0
1720 !           chi12=0.0D0
1721 !           chip1=0.0D0
1722 !           chip2=0.0D0
1723 !           chip12=0.0D0
1724 !           alf1=0.0D0
1725 !           alf2=0.0D0
1726 !           alf12=0.0D0
1727             xj=c(1,nres+j)-xi
1728             yj=c(2,nres+j)-yi
1729             zj=c(3,nres+j)-zi
1730             dxj=dc_norm(1,nres+j)
1731             dyj=dc_norm(2,nres+j)
1732             dzj=dc_norm(3,nres+j)
1733             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1734 !d          if (icall.eq.0) then
1735 !d            rrsave(ind)=rrij
1736 !d          else
1737 !d            rrij=rrsave(ind)
1738 !d          endif
1739             rij=dsqrt(rrij)
1740 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1741             call sc_angular
1742 ! Calculate whole angle-dependent part of epsilon and contributions
1743 ! to its derivatives
1744             fac=(rrij*sigsq)**expon2
1745             e1=fac*fac*aa_aq(itypi,itypj)
1746             e2=fac*bb_aq(itypi,itypj)
1747             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1748             eps2der=evdwij*eps3rt
1749             eps3der=evdwij*eps2rt
1750             evdwij=evdwij*eps2rt*eps3rt
1751             evdw=evdw+evdwij
1752             if (lprn) then
1753             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1754             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1755 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1756 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1757 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1758 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1759 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1760 !d     &        evdwij
1761             endif
1762 ! Calculate gradient components.
1763             e1=e1*eps1*eps2rt**2*eps3rt**2
1764             fac=-expon*(e1+evdwij)
1765             sigder=fac/sigsq
1766             fac=rrij*fac
1767 ! Calculate radial part of the gradient
1768             gg(1)=xj*fac
1769             gg(2)=yj*fac
1770             gg(3)=zj*fac
1771 ! Calculate the angular part of the gradient and sum add the contributions
1772 ! to the appropriate components of the Cartesian gradient.
1773             call sc_grad
1774           enddo      ! j
1775         enddo        ! iint
1776       enddo          ! i
1777 !     stop
1778       return
1779       end subroutine ebp
1780 !-----------------------------------------------------------------------------
1781       subroutine egb(evdw)
1782 !
1783 ! This subroutine calculates the interaction energy of nonbonded side chains
1784 ! assuming the Gay-Berne potential of interaction.
1785 !
1786       use calc_data
1787 !      implicit real*8 (a-h,o-z)
1788 !      include 'DIMENSIONS'
1789 !      include 'COMMON.GEO'
1790 !      include 'COMMON.VAR'
1791 !      include 'COMMON.LOCAL'
1792 !      include 'COMMON.CHAIN'
1793 !      include 'COMMON.DERIV'
1794 !      include 'COMMON.NAMES'
1795 !      include 'COMMON.INTERACT'
1796 !      include 'COMMON.IOUNITS'
1797 !      include 'COMMON.CALC'
1798 !      include 'COMMON.CONTROL'
1799 !      include 'COMMON.SBRIDGE'
1800       logical :: lprn
1801 !el local variables
1802       integer :: iint,itypi,itypi1,itypj,subchap
1803       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1804       real(kind=8) :: evdw,sig0ij
1805       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1806                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1807                     sslipi,sslipj,faclip
1808       integer :: ii
1809       real(kind=8) :: fracinbuf
1810
1811 !cccc      energy_dec=.false.
1812 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1813       evdw=0.0D0
1814       lprn=.false.
1815 !     if (icall.eq.0) lprn=.false.
1816 !el      ind=0
1817       dCAVdOM2=0.0d0
1818       dGCLdOM2=0.0d0
1819       dPOLdOM2=0.0d0
1820       dCAVdOM1=0.0d0
1821       dGCLdOM1=0.0d0
1822       dPOLdOM1=0.0d0
1823
1824
1825       do i=iatsc_s,iatsc_e
1826 !C        print *,"I am in EVDW",i
1827         itypi=iabs(itype(i,1))
1828 !        if (i.ne.47) cycle
1829         if (itypi.eq.ntyp1) cycle
1830         itypi1=iabs(itype(i+1,1))
1831         xi=c(1,nres+i)
1832         yi=c(2,nres+i)
1833         zi=c(3,nres+i)
1834           xi=dmod(xi,boxxsize)
1835           if (xi.lt.0) xi=xi+boxxsize
1836           yi=dmod(yi,boxysize)
1837           if (yi.lt.0) yi=yi+boxysize
1838           zi=dmod(zi,boxzsize)
1839           if (zi.lt.0) zi=zi+boxzsize
1840
1841        if ((zi.gt.bordlipbot)  &
1842         .and.(zi.lt.bordliptop)) then
1843 !C the energy transfer exist
1844         if (zi.lt.buflipbot) then
1845 !C what fraction I am in
1846          fracinbuf=1.0d0-  &
1847               ((zi-bordlipbot)/lipbufthick)
1848 !C lipbufthick is thickenes of lipid buffore
1849          sslipi=sscalelip(fracinbuf)
1850          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1851         elseif (zi.gt.bufliptop) then
1852          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1853          sslipi=sscalelip(fracinbuf)
1854          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1855         else
1856          sslipi=1.0d0
1857          ssgradlipi=0.0
1858         endif
1859        else
1860          sslipi=0.0d0
1861          ssgradlipi=0.0
1862        endif
1863 !       print *, sslipi,ssgradlipi
1864         dxi=dc_norm(1,nres+i)
1865         dyi=dc_norm(2,nres+i)
1866         dzi=dc_norm(3,nres+i)
1867 !        dsci_inv=dsc_inv(itypi)
1868         dsci_inv=vbld_inv(i+nres)
1869 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1870 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1871 !
1872 ! Calculate SC interaction energy.
1873 !
1874         do iint=1,nint_gr(i)
1875           do j=istart(i,iint),iend(i,iint)
1876             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1877               call dyn_ssbond_ene(i,j,evdwij)
1878               evdw=evdw+evdwij
1879               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1880                               'evdw',i,j,evdwij,' ss'
1881 !              if (energy_dec) write (iout,*) &
1882 !                              'evdw',i,j,evdwij,' ss'
1883              do k=j+1,iend(i,iint)
1884 !C search over all next residues
1885               if (dyn_ss_mask(k)) then
1886 !C check if they are cysteins
1887 !C              write(iout,*) 'k=',k
1888
1889 !c              write(iout,*) "PRZED TRI", evdwij
1890 !               evdwij_przed_tri=evdwij
1891               call triple_ssbond_ene(i,j,k,evdwij)
1892 !c               if(evdwij_przed_tri.ne.evdwij) then
1893 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1894 !c               endif
1895
1896 !c              write(iout,*) "PO TRI", evdwij
1897 !C call the energy function that removes the artifical triple disulfide
1898 !C bond the soubroutine is located in ssMD.F
1899               evdw=evdw+evdwij
1900               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1901                             'evdw',i,j,evdwij,'tss'
1902               endif!dyn_ss_mask(k)
1903              enddo! k
1904             ELSE
1905 !el            ind=ind+1
1906             itypj=iabs(itype(j,1))
1907             if (itypj.eq.ntyp1) cycle
1908 !             if (j.ne.78) cycle
1909 !            dscj_inv=dsc_inv(itypj)
1910             dscj_inv=vbld_inv(j+nres)
1911 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1912 !              1.0d0/vbld(j+nres) !d
1913 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1914             sig0ij=sigma(itypi,itypj)
1915             chi1=chi(itypi,itypj)
1916             chi2=chi(itypj,itypi)
1917             chi12=chi1*chi2
1918             chip1=chip(itypi)
1919             chip2=chip(itypj)
1920             chip12=chip1*chip2
1921             alf1=alp(itypi)
1922             alf2=alp(itypj)
1923             alf12=0.5D0*(alf1+alf2)
1924 ! For diagnostics only!!!
1925 !           chi1=0.0D0
1926 !           chi2=0.0D0
1927 !           chi12=0.0D0
1928 !           chip1=0.0D0
1929 !           chip2=0.0D0
1930 !           chip12=0.0D0
1931 !           alf1=0.0D0
1932 !           alf2=0.0D0
1933 !           alf12=0.0D0
1934            xj=c(1,nres+j)
1935            yj=c(2,nres+j)
1936            zj=c(3,nres+j)
1937           xj=dmod(xj,boxxsize)
1938           if (xj.lt.0) xj=xj+boxxsize
1939           yj=dmod(yj,boxysize)
1940           if (yj.lt.0) yj=yj+boxysize
1941           zj=dmod(zj,boxzsize)
1942           if (zj.lt.0) zj=zj+boxzsize
1943 !          print *,"tu",xi,yi,zi,xj,yj,zj
1944 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1945 ! this fragment set correct epsilon for lipid phase
1946        if ((zj.gt.bordlipbot)  &
1947        .and.(zj.lt.bordliptop)) then
1948 !C the energy transfer exist
1949         if (zj.lt.buflipbot) then
1950 !C what fraction I am in
1951          fracinbuf=1.0d0-     &
1952              ((zj-bordlipbot)/lipbufthick)
1953 !C lipbufthick is thickenes of lipid buffore
1954          sslipj=sscalelip(fracinbuf)
1955          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1956         elseif (zj.gt.bufliptop) then
1957          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1958          sslipj=sscalelip(fracinbuf)
1959          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1960         else
1961          sslipj=1.0d0
1962          ssgradlipj=0.0
1963         endif
1964        else
1965          sslipj=0.0d0
1966          ssgradlipj=0.0
1967        endif
1968       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1969        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1970       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1971        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1972 !------------------------------------------------
1973       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1974       xj_safe=xj
1975       yj_safe=yj
1976       zj_safe=zj
1977       subchap=0
1978       do xshift=-1,1
1979       do yshift=-1,1
1980       do zshift=-1,1
1981           xj=xj_safe+xshift*boxxsize
1982           yj=yj_safe+yshift*boxysize
1983           zj=zj_safe+zshift*boxzsize
1984           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1985           if(dist_temp.lt.dist_init) then
1986             dist_init=dist_temp
1987             xj_temp=xj
1988             yj_temp=yj
1989             zj_temp=zj
1990             subchap=1
1991           endif
1992        enddo
1993        enddo
1994        enddo
1995        if (subchap.eq.1) then
1996           xj=xj_temp-xi
1997           yj=yj_temp-yi
1998           zj=zj_temp-zi
1999        else
2000           xj=xj_safe-xi
2001           yj=yj_safe-yi
2002           zj=zj_safe-zi
2003        endif
2004             dxj=dc_norm(1,nres+j)
2005             dyj=dc_norm(2,nres+j)
2006             dzj=dc_norm(3,nres+j)
2007 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2008 !            write (iout,*) "j",j," dc_norm",& !d
2009 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2010 !          write(iout,*)"rrij ",rrij
2011 !          write(iout,*)"xj yj zj ", xj, yj, zj
2012 !          write(iout,*)"xi yi zi ", xi, yi, zi
2013 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2014             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2015             rij=dsqrt(rrij)
2016             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
2017             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
2018 !            print *,sss_ele_cut,sss_ele_grad,&
2019 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2020             if (sss_ele_cut.le.0.0) cycle
2021 ! Calculate angle-dependent terms of energy and contributions to their
2022 ! derivatives.
2023             call sc_angular
2024             sigsq=1.0D0/sigsq
2025             sig=sig0ij*dsqrt(sigsq)
2026             rij_shift=1.0D0/rij-sig+sig0ij
2027 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2028 !            "sig0ij",sig0ij
2029 ! for diagnostics; uncomment
2030 !            rij_shift=1.2*sig0ij
2031 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2032             if (rij_shift.le.0.0D0) then
2033               evdw=1.0D20
2034 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2035 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2036 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2037               return
2038             endif
2039             sigder=-sig*sigsq
2040 !---------------------------------------------------------------
2041             rij_shift=1.0D0/rij_shift
2042             fac=rij_shift**expon
2043             faclip=fac
2044             e1=fac*fac*aa!(itypi,itypj)
2045             e2=fac*bb!(itypi,itypj)
2046             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2047             eps2der=evdwij*eps3rt
2048             eps3der=evdwij*eps2rt
2049 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2050 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2051 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2052             evdwij=evdwij*eps2rt*eps3rt
2053             evdw=evdw+evdwij*sss_ele_cut
2054             if (lprn) then
2055             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2056             epsi=bb**2/aa!(itypi,itypj)
2057             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2058               restyp(itypi,1),i,restyp(itypj,1),j, &
2059               epsi,sigm,chi1,chi2,chip1,chip2, &
2060               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2061               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2062               evdwij
2063             endif
2064
2065             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2066                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2067 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2068 !            if (energy_dec) write (iout,*) &
2069 !                             'evdw',i,j,evdwij
2070 !                       print *,"ZALAMKA", evdw
2071
2072 ! Calculate gradient components.
2073             e1=e1*eps1*eps2rt**2*eps3rt**2
2074             fac=-expon*(e1+evdwij)*rij_shift
2075             sigder=fac*sigder
2076             fac=rij*fac
2077 !            print *,'before fac',fac,rij,evdwij
2078             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2079             /sigma(itypi,itypj)*rij
2080 !            print *,'grad part scale',fac,   &
2081 !             evdwij*sss_ele_grad/sss_ele_cut &
2082 !            /sigma(itypi,itypj)*rij
2083 !            fac=0.0d0
2084 ! Calculate the radial part of the gradient
2085             gg(1)=xj*fac
2086             gg(2)=yj*fac
2087             gg(3)=zj*fac
2088 !C Calculate the radial part of the gradient
2089             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2090        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2091         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2092        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2093             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2094             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2095
2096 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2097 ! Calculate angular part of the gradient.
2098             call sc_grad
2099             ENDIF    ! dyn_ss
2100           enddo      ! j
2101         enddo        ! iint
2102       enddo          ! i
2103 !       print *,"ZALAMKA", evdw
2104 !      write (iout,*) "Number of loop steps in EGB:",ind
2105 !ccc      energy_dec=.false.
2106       return
2107       end subroutine egb
2108 !-----------------------------------------------------------------------------
2109       subroutine egbv(evdw)
2110 !
2111 ! This subroutine calculates the interaction energy of nonbonded side chains
2112 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2113 !
2114       use comm_srutu
2115       use calc_data
2116 !      implicit real*8 (a-h,o-z)
2117 !      include 'DIMENSIONS'
2118 !      include 'COMMON.GEO'
2119 !      include 'COMMON.VAR'
2120 !      include 'COMMON.LOCAL'
2121 !      include 'COMMON.CHAIN'
2122 !      include 'COMMON.DERIV'
2123 !      include 'COMMON.NAMES'
2124 !      include 'COMMON.INTERACT'
2125 !      include 'COMMON.IOUNITS'
2126 !      include 'COMMON.CALC'
2127       use comm_srutu
2128 !el      integer :: icall
2129 !el      common /srutu/ icall
2130       logical :: lprn
2131 !el local variables
2132       integer :: iint,itypi,itypi1,itypj
2133       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2134       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2135
2136 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2137       evdw=0.0D0
2138       lprn=.false.
2139 !     if (icall.eq.0) lprn=.true.
2140 !el      ind=0
2141       do i=iatsc_s,iatsc_e
2142         itypi=iabs(itype(i,1))
2143         if (itypi.eq.ntyp1) cycle
2144         itypi1=iabs(itype(i+1,1))
2145         xi=c(1,nres+i)
2146         yi=c(2,nres+i)
2147         zi=c(3,nres+i)
2148         dxi=dc_norm(1,nres+i)
2149         dyi=dc_norm(2,nres+i)
2150         dzi=dc_norm(3,nres+i)
2151 !        dsci_inv=dsc_inv(itypi)
2152         dsci_inv=vbld_inv(i+nres)
2153 !
2154 ! Calculate SC interaction energy.
2155 !
2156         do iint=1,nint_gr(i)
2157           do j=istart(i,iint),iend(i,iint)
2158 !el            ind=ind+1
2159             itypj=iabs(itype(j,1))
2160             if (itypj.eq.ntyp1) cycle
2161 !            dscj_inv=dsc_inv(itypj)
2162             dscj_inv=vbld_inv(j+nres)
2163             sig0ij=sigma(itypi,itypj)
2164             r0ij=r0(itypi,itypj)
2165             chi1=chi(itypi,itypj)
2166             chi2=chi(itypj,itypi)
2167             chi12=chi1*chi2
2168             chip1=chip(itypi)
2169             chip2=chip(itypj)
2170             chip12=chip1*chip2
2171             alf1=alp(itypi)
2172             alf2=alp(itypj)
2173             alf12=0.5D0*(alf1+alf2)
2174 ! For diagnostics only!!!
2175 !           chi1=0.0D0
2176 !           chi2=0.0D0
2177 !           chi12=0.0D0
2178 !           chip1=0.0D0
2179 !           chip2=0.0D0
2180 !           chip12=0.0D0
2181 !           alf1=0.0D0
2182 !           alf2=0.0D0
2183 !           alf12=0.0D0
2184             xj=c(1,nres+j)-xi
2185             yj=c(2,nres+j)-yi
2186             zj=c(3,nres+j)-zi
2187             dxj=dc_norm(1,nres+j)
2188             dyj=dc_norm(2,nres+j)
2189             dzj=dc_norm(3,nres+j)
2190             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2191             rij=dsqrt(rrij)
2192 ! Calculate angle-dependent terms of energy and contributions to their
2193 ! derivatives.
2194             call sc_angular
2195             sigsq=1.0D0/sigsq
2196             sig=sig0ij*dsqrt(sigsq)
2197             rij_shift=1.0D0/rij-sig+r0ij
2198 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2199             if (rij_shift.le.0.0D0) then
2200               evdw=1.0D20
2201               return
2202             endif
2203             sigder=-sig*sigsq
2204 !---------------------------------------------------------------
2205             rij_shift=1.0D0/rij_shift
2206             fac=rij_shift**expon
2207             e1=fac*fac*aa_aq(itypi,itypj)
2208             e2=fac*bb_aq(itypi,itypj)
2209             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2210             eps2der=evdwij*eps3rt
2211             eps3der=evdwij*eps2rt
2212             fac_augm=rrij**expon
2213             e_augm=augm(itypi,itypj)*fac_augm
2214             evdwij=evdwij*eps2rt*eps3rt
2215             evdw=evdw+evdwij+e_augm
2216             if (lprn) then
2217             sigm=dabs(aa_aq(itypi,itypj)/&
2218             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2219             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2220             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2221               restyp(itypi,1),i,restyp(itypj,1),j,&
2222               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2223               chi1,chi2,chip1,chip2,&
2224               eps1,eps2rt**2,eps3rt**2,&
2225               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2226               evdwij+e_augm
2227             endif
2228 ! Calculate gradient components.
2229             e1=e1*eps1*eps2rt**2*eps3rt**2
2230             fac=-expon*(e1+evdwij)*rij_shift
2231             sigder=fac*sigder
2232             fac=rij*fac-2*expon*rrij*e_augm
2233 ! Calculate the radial part of the gradient
2234             gg(1)=xj*fac
2235             gg(2)=yj*fac
2236             gg(3)=zj*fac
2237 ! Calculate angular part of the gradient.
2238             call sc_grad
2239           enddo      ! j
2240         enddo        ! iint
2241       enddo          ! i
2242       end subroutine egbv
2243 !-----------------------------------------------------------------------------
2244 !el      subroutine sc_angular in module geometry
2245 !-----------------------------------------------------------------------------
2246       subroutine e_softsphere(evdw)
2247 !
2248 ! This subroutine calculates the interaction energy of nonbonded side chains
2249 ! assuming the LJ potential of interaction.
2250 !
2251 !      implicit real*8 (a-h,o-z)
2252 !      include 'DIMENSIONS'
2253       real(kind=8),parameter :: accur=1.0d-10
2254 !      include 'COMMON.GEO'
2255 !      include 'COMMON.VAR'
2256 !      include 'COMMON.LOCAL'
2257 !      include 'COMMON.CHAIN'
2258 !      include 'COMMON.DERIV'
2259 !      include 'COMMON.INTERACT'
2260 !      include 'COMMON.TORSION'
2261 !      include 'COMMON.SBRIDGE'
2262 !      include 'COMMON.NAMES'
2263 !      include 'COMMON.IOUNITS'
2264 !      include 'COMMON.CONTACTS'
2265       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2266 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2267 !el local variables
2268       integer :: i,iint,j,itypi,itypi1,itypj,k
2269       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2270       real(kind=8) :: fac
2271
2272       evdw=0.0D0
2273       do i=iatsc_s,iatsc_e
2274         itypi=iabs(itype(i,1))
2275         if (itypi.eq.ntyp1) cycle
2276         itypi1=iabs(itype(i+1,1))
2277         xi=c(1,nres+i)
2278         yi=c(2,nres+i)
2279         zi=c(3,nres+i)
2280 !
2281 ! Calculate SC interaction energy.
2282 !
2283         do iint=1,nint_gr(i)
2284 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2285 !d   &                  'iend=',iend(i,iint)
2286           do j=istart(i,iint),iend(i,iint)
2287             itypj=iabs(itype(j,1))
2288             if (itypj.eq.ntyp1) cycle
2289             xj=c(1,nres+j)-xi
2290             yj=c(2,nres+j)-yi
2291             zj=c(3,nres+j)-zi
2292             rij=xj*xj+yj*yj+zj*zj
2293 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2294             r0ij=r0(itypi,itypj)
2295             r0ijsq=r0ij*r0ij
2296 !            print *,i,j,r0ij,dsqrt(rij)
2297             if (rij.lt.r0ijsq) then
2298               evdwij=0.25d0*(rij-r0ijsq)**2
2299               fac=rij-r0ijsq
2300             else
2301               evdwij=0.0d0
2302               fac=0.0d0
2303             endif
2304             evdw=evdw+evdwij
2305 !
2306 ! Calculate the components of the gradient in DC and X
2307 !
2308             gg(1)=xj*fac
2309             gg(2)=yj*fac
2310             gg(3)=zj*fac
2311             do k=1,3
2312               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2313               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2314               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2315               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2316             enddo
2317 !grad            do k=i,j-1
2318 !grad              do l=1,3
2319 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2320 !grad              enddo
2321 !grad            enddo
2322           enddo ! j
2323         enddo ! iint
2324       enddo ! i
2325       return
2326       end subroutine e_softsphere
2327 !-----------------------------------------------------------------------------
2328       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2329 !
2330 ! Soft-sphere potential of p-p interaction
2331 !
2332 !      implicit real*8 (a-h,o-z)
2333 !      include 'DIMENSIONS'
2334 !      include 'COMMON.CONTROL'
2335 !      include 'COMMON.IOUNITS'
2336 !      include 'COMMON.GEO'
2337 !      include 'COMMON.VAR'
2338 !      include 'COMMON.LOCAL'
2339 !      include 'COMMON.CHAIN'
2340 !      include 'COMMON.DERIV'
2341 !      include 'COMMON.INTERACT'
2342 !      include 'COMMON.CONTACTS'
2343 !      include 'COMMON.TORSION'
2344 !      include 'COMMON.VECTORS'
2345 !      include 'COMMON.FFIELD'
2346       real(kind=8),dimension(3) :: ggg
2347 !d      write(iout,*) 'In EELEC_soft_sphere'
2348 !el local variables
2349       integer :: i,j,k,num_conti,iteli,itelj
2350       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2351       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2352       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2353
2354       ees=0.0D0
2355       evdw1=0.0D0
2356       eel_loc=0.0d0
2357       eello_turn3=0.0d0
2358       eello_turn4=0.0d0
2359 !el      ind=0
2360       do i=iatel_s,iatel_e
2361         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2362         dxi=dc(1,i)
2363         dyi=dc(2,i)
2364         dzi=dc(3,i)
2365         xmedi=c(1,i)+0.5d0*dxi
2366         ymedi=c(2,i)+0.5d0*dyi
2367         zmedi=c(3,i)+0.5d0*dzi
2368         num_conti=0
2369 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2370         do j=ielstart(i),ielend(i)
2371           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2372 !el          ind=ind+1
2373           iteli=itel(i)
2374           itelj=itel(j)
2375           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2376           r0ij=rpp(iteli,itelj)
2377           r0ijsq=r0ij*r0ij
2378           dxj=dc(1,j)
2379           dyj=dc(2,j)
2380           dzj=dc(3,j)
2381           xj=c(1,j)+0.5D0*dxj-xmedi
2382           yj=c(2,j)+0.5D0*dyj-ymedi
2383           zj=c(3,j)+0.5D0*dzj-zmedi
2384           rij=xj*xj+yj*yj+zj*zj
2385           if (rij.lt.r0ijsq) then
2386             evdw1ij=0.25d0*(rij-r0ijsq)**2
2387             fac=rij-r0ijsq
2388           else
2389             evdw1ij=0.0d0
2390             fac=0.0d0
2391           endif
2392           evdw1=evdw1+evdw1ij
2393 !
2394 ! Calculate contributions to the Cartesian gradient.
2395 !
2396           ggg(1)=fac*xj
2397           ggg(2)=fac*yj
2398           ggg(3)=fac*zj
2399           do k=1,3
2400             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2401             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2402           enddo
2403 !
2404 ! Loop over residues i+1 thru j-1.
2405 !
2406 !grad          do k=i+1,j-1
2407 !grad            do l=1,3
2408 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2409 !grad            enddo
2410 !grad          enddo
2411         enddo ! j
2412       enddo   ! i
2413 !grad      do i=nnt,nct-1
2414 !grad        do k=1,3
2415 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2416 !grad        enddo
2417 !grad        do j=i+1,nct-1
2418 !grad          do k=1,3
2419 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2420 !grad          enddo
2421 !grad        enddo
2422 !grad      enddo
2423       return
2424       end subroutine eelec_soft_sphere
2425 !-----------------------------------------------------------------------------
2426       subroutine vec_and_deriv
2427 !      implicit real*8 (a-h,o-z)
2428 !      include 'DIMENSIONS'
2429 #ifdef MPI
2430       include 'mpif.h'
2431 #endif
2432 !      include 'COMMON.IOUNITS'
2433 !      include 'COMMON.GEO'
2434 !      include 'COMMON.VAR'
2435 !      include 'COMMON.LOCAL'
2436 !      include 'COMMON.CHAIN'
2437 !      include 'COMMON.VECTORS'
2438 !      include 'COMMON.SETUP'
2439 !      include 'COMMON.TIME1'
2440       real(kind=8),dimension(3,3,2) :: uyder,uzder
2441       real(kind=8),dimension(2) :: vbld_inv_temp
2442 ! Compute the local reference systems. For reference system (i), the
2443 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2444 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2445 !el local variables
2446       integer :: i,j,k,l
2447       real(kind=8) :: facy,fac,costh
2448
2449 #ifdef PARVEC
2450       do i=ivec_start,ivec_end
2451 #else
2452       do i=1,nres-1
2453 #endif
2454           if (i.eq.nres-1) then
2455 ! Case of the last full residue
2456 ! Compute the Z-axis
2457             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2458             costh=dcos(pi-theta(nres))
2459             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2460             do k=1,3
2461               uz(k,i)=fac*uz(k,i)
2462             enddo
2463 ! Compute the derivatives of uz
2464             uzder(1,1,1)= 0.0d0
2465             uzder(2,1,1)=-dc_norm(3,i-1)
2466             uzder(3,1,1)= dc_norm(2,i-1)
2467             uzder(1,2,1)= dc_norm(3,i-1)
2468             uzder(2,2,1)= 0.0d0
2469             uzder(3,2,1)=-dc_norm(1,i-1)
2470             uzder(1,3,1)=-dc_norm(2,i-1)
2471             uzder(2,3,1)= dc_norm(1,i-1)
2472             uzder(3,3,1)= 0.0d0
2473             uzder(1,1,2)= 0.0d0
2474             uzder(2,1,2)= dc_norm(3,i)
2475             uzder(3,1,2)=-dc_norm(2,i)
2476             uzder(1,2,2)=-dc_norm(3,i)
2477             uzder(2,2,2)= 0.0d0
2478             uzder(3,2,2)= dc_norm(1,i)
2479             uzder(1,3,2)= dc_norm(2,i)
2480             uzder(2,3,2)=-dc_norm(1,i)
2481             uzder(3,3,2)= 0.0d0
2482 ! Compute the Y-axis
2483             facy=fac
2484             do k=1,3
2485               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2486             enddo
2487 ! Compute the derivatives of uy
2488             do j=1,3
2489               do k=1,3
2490                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2491                               -dc_norm(k,i)*dc_norm(j,i-1)
2492                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2493               enddo
2494               uyder(j,j,1)=uyder(j,j,1)-costh
2495               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2496             enddo
2497             do j=1,2
2498               do k=1,3
2499                 do l=1,3
2500                   uygrad(l,k,j,i)=uyder(l,k,j)
2501                   uzgrad(l,k,j,i)=uzder(l,k,j)
2502                 enddo
2503               enddo
2504             enddo
2505             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2506             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2507             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2508             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2509           else
2510 ! Other residues
2511 ! Compute the Z-axis
2512             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2513             costh=dcos(pi-theta(i+2))
2514             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2515             do k=1,3
2516               uz(k,i)=fac*uz(k,i)
2517             enddo
2518 ! Compute the derivatives of uz
2519             uzder(1,1,1)= 0.0d0
2520             uzder(2,1,1)=-dc_norm(3,i+1)
2521             uzder(3,1,1)= dc_norm(2,i+1)
2522             uzder(1,2,1)= dc_norm(3,i+1)
2523             uzder(2,2,1)= 0.0d0
2524             uzder(3,2,1)=-dc_norm(1,i+1)
2525             uzder(1,3,1)=-dc_norm(2,i+1)
2526             uzder(2,3,1)= dc_norm(1,i+1)
2527             uzder(3,3,1)= 0.0d0
2528             uzder(1,1,2)= 0.0d0
2529             uzder(2,1,2)= dc_norm(3,i)
2530             uzder(3,1,2)=-dc_norm(2,i)
2531             uzder(1,2,2)=-dc_norm(3,i)
2532             uzder(2,2,2)= 0.0d0
2533             uzder(3,2,2)= dc_norm(1,i)
2534             uzder(1,3,2)= dc_norm(2,i)
2535             uzder(2,3,2)=-dc_norm(1,i)
2536             uzder(3,3,2)= 0.0d0
2537 ! Compute the Y-axis
2538             facy=fac
2539             do k=1,3
2540               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2541             enddo
2542 ! Compute the derivatives of uy
2543             do j=1,3
2544               do k=1,3
2545                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2546                               -dc_norm(k,i)*dc_norm(j,i+1)
2547                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2548               enddo
2549               uyder(j,j,1)=uyder(j,j,1)-costh
2550               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2551             enddo
2552             do j=1,2
2553               do k=1,3
2554                 do l=1,3
2555                   uygrad(l,k,j,i)=uyder(l,k,j)
2556                   uzgrad(l,k,j,i)=uzder(l,k,j)
2557                 enddo
2558               enddo
2559             enddo
2560             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2561             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2562             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2563             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2564           endif
2565       enddo
2566       do i=1,nres-1
2567         vbld_inv_temp(1)=vbld_inv(i+1)
2568         if (i.lt.nres-1) then
2569           vbld_inv_temp(2)=vbld_inv(i+2)
2570           else
2571           vbld_inv_temp(2)=vbld_inv(i)
2572           endif
2573         do j=1,2
2574           do k=1,3
2575             do l=1,3
2576               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2577               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2578             enddo
2579           enddo
2580         enddo
2581       enddo
2582 #if defined(PARVEC) && defined(MPI)
2583       if (nfgtasks1.gt.1) then
2584         time00=MPI_Wtime()
2585 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2586 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2587 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2588         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2589          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2590          FG_COMM1,IERR)
2591         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2592          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2593          FG_COMM1,IERR)
2594         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2595          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2596          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2597         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2598          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2599          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2600         time_gather=time_gather+MPI_Wtime()-time00
2601       endif
2602 !      if (fg_rank.eq.0) then
2603 !        write (iout,*) "Arrays UY and UZ"
2604 !        do i=1,nres-1
2605 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2606 !     &     (uz(k,i),k=1,3)
2607 !        enddo
2608 !      endif
2609 #endif
2610       return
2611       end subroutine vec_and_deriv
2612 !-----------------------------------------------------------------------------
2613       subroutine check_vecgrad
2614 !      implicit real*8 (a-h,o-z)
2615 !      include 'DIMENSIONS'
2616 !      include 'COMMON.IOUNITS'
2617 !      include 'COMMON.GEO'
2618 !      include 'COMMON.VAR'
2619 !      include 'COMMON.LOCAL'
2620 !      include 'COMMON.CHAIN'
2621 !      include 'COMMON.VECTORS'
2622       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2623       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2624       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2625       real(kind=8),dimension(3) :: erij
2626       real(kind=8) :: delta=1.0d-7
2627 !el local variables
2628       integer :: i,j,k,l
2629
2630       call vec_and_deriv
2631 !d      do i=1,nres
2632 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2633 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2634 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2635 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2636 !d     &     (dc_norm(if90,i),if90=1,3)
2637 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2638 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2639 !d          write(iout,'(a)')
2640 !d      enddo
2641       do i=1,nres
2642         do j=1,2
2643           do k=1,3
2644             do l=1,3
2645               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2646               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2647             enddo
2648           enddo
2649         enddo
2650       enddo
2651       call vec_and_deriv
2652       do i=1,nres
2653         do j=1,3
2654           uyt(j,i)=uy(j,i)
2655           uzt(j,i)=uz(j,i)
2656         enddo
2657       enddo
2658       do i=1,nres
2659 !d        write (iout,*) 'i=',i
2660         do k=1,3
2661           erij(k)=dc_norm(k,i)
2662         enddo
2663         do j=1,3
2664           do k=1,3
2665             dc_norm(k,i)=erij(k)
2666           enddo
2667           dc_norm(j,i)=dc_norm(j,i)+delta
2668 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2669 !          do k=1,3
2670 !            dc_norm(k,i)=dc_norm(k,i)/fac
2671 !          enddo
2672 !          write (iout,*) (dc_norm(k,i),k=1,3)
2673 !          write (iout,*) (erij(k),k=1,3)
2674           call vec_and_deriv
2675           do k=1,3
2676             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2677             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2678             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2679             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2680           enddo
2681 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2682 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2683 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2684         enddo
2685         do k=1,3
2686           dc_norm(k,i)=erij(k)
2687         enddo
2688 !d        do k=1,3
2689 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2690 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2691 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2692 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2693 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2694 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2695 !d          write (iout,'(a)')
2696 !d        enddo
2697       enddo
2698       return
2699       end subroutine check_vecgrad
2700 !-----------------------------------------------------------------------------
2701       subroutine set_matrices
2702 !      implicit real*8 (a-h,o-z)
2703 !      include 'DIMENSIONS'
2704 #ifdef MPI
2705       include "mpif.h"
2706 !      include "COMMON.SETUP"
2707       integer :: IERR
2708       integer :: status(MPI_STATUS_SIZE)
2709 #endif
2710 !      include 'COMMON.IOUNITS'
2711 !      include 'COMMON.GEO'
2712 !      include 'COMMON.VAR'
2713 !      include 'COMMON.LOCAL'
2714 !      include 'COMMON.CHAIN'
2715 !      include 'COMMON.DERIV'
2716 !      include 'COMMON.INTERACT'
2717 !      include 'COMMON.CONTACTS'
2718 !      include 'COMMON.TORSION'
2719 !      include 'COMMON.VECTORS'
2720 !      include 'COMMON.FFIELD'
2721       real(kind=8) :: auxvec(2),auxmat(2,2)
2722       integer :: i,iti1,iti,k,l
2723       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2724        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2725 !       print *,"in set matrices"
2726 !
2727 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2728 ! to calculate the el-loc multibody terms of various order.
2729 !
2730 !AL el      mu=0.0d0
2731
2732 #ifdef PARMAT
2733       do i=ivec_start+2,ivec_end+2
2734 #else
2735       do i=3,nres+1
2736 #endif
2737         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2738           if (itype(i-2,1).eq.0) then
2739           iti = nloctyp
2740           else
2741           iti = itype2loc(itype(i-2,1))
2742           endif
2743         else
2744           iti=nloctyp
2745         endif
2746 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2747         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2748           iti1 = itype2loc(itype(i-1,1))
2749         else
2750           iti1=nloctyp
2751         endif
2752 !        print *,i,itype(i-2,1),iti
2753 #ifdef NEWCORR
2754         cost1=dcos(theta(i-1))
2755         sint1=dsin(theta(i-1))
2756         sint1sq=sint1*sint1
2757         sint1cub=sint1sq*sint1
2758         sint1cost1=2*sint1*cost1
2759 !        print *,"cost1",cost1,theta(i-1)
2760 !c        write (iout,*) "bnew1",i,iti
2761 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2762 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2763 !c        write (iout,*) "bnew2",i,iti
2764 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2765 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2766         k=1
2767 !        print *,bnew1(1,k,iti),"bnew1"
2768         do k=1,2
2769           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2770 !          print *,b1k
2771 !          write(*,*) shape(b1)
2772 !          if(.not.allocated(b1)) print *, "WTF?"
2773           b1(k,i-2)=sint1*b1k
2774 !
2775 !             print *,b1(k,i-2)
2776
2777           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2778                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2779 !             print *,gtb1(k,i-2)
2780
2781           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2782           b2(k,i-2)=sint1*b2k
2783 !             print *,b2(k,i-2)
2784
2785           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2786                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2787 !             print *,gtb2(k,i-2)
2788
2789         enddo
2790 !        print *,b1k,b2k
2791         do k=1,2
2792           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2793           cc(1,k,i-2)=sint1sq*aux
2794           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2795                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2796           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2797           dd(1,k,i-2)=sint1sq*aux
2798           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2799                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2800         enddo
2801 !        print *,"after cc"
2802         cc(2,1,i-2)=cc(1,2,i-2)
2803         cc(2,2,i-2)=-cc(1,1,i-2)
2804         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2805         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2806         dd(2,1,i-2)=dd(1,2,i-2)
2807         dd(2,2,i-2)=-dd(1,1,i-2)
2808         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2809         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2810 !        print *,"after dd"
2811
2812         do k=1,2
2813           do l=1,2
2814             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2815             EE(l,k,i-2)=sint1sq*aux
2816             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2817           enddo
2818         enddo
2819         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2820         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2821         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2822         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2823         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2824         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2825         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2826 !        print *,"after ee"
2827
2828 !c        b1tilde(1,i-2)=b1(1,i-2)
2829 !c        b1tilde(2,i-2)=-b1(2,i-2)
2830 !c        b2tilde(1,i-2)=b2(1,i-2)
2831 !c        b2tilde(2,i-2)=-b2(2,i-2)
2832 #ifdef DEBUG
2833         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2834         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2835         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2836         write (iout,*) 'theta=', theta(i-1)
2837 #endif
2838 #else
2839         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2840           iti = itype2loc(itype(i-2,1))
2841         else
2842           iti=nloctyp
2843         endif
2844 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2845 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2846         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2847           iti1 = itype2loc(itype(i-1,1))
2848         else
2849           iti1=nloctyp
2850         endif
2851         b1(1,i-2)=b(3,iti)
2852         b1(2,i-2)=b(5,iti)
2853         b2(1,i-2)=b(2,iti)
2854         b2(2,i-2)=b(4,iti)
2855         do k=1,2
2856           do l=1,2
2857            CC(k,l,i-2)=ccold(k,l,iti)
2858            DD(k,l,i-2)=ddold(k,l,iti)
2859            EE(k,l,i-2)=eeold(k,l,iti)
2860           enddo
2861         enddo
2862 #endif
2863         b1tilde(1,i-2)= b1(1,i-2)
2864         b1tilde(2,i-2)=-b1(2,i-2)
2865         b2tilde(1,i-2)= b2(1,i-2)
2866         b2tilde(2,i-2)=-b2(2,i-2)
2867 !c
2868         Ctilde(1,1,i-2)= CC(1,1,i-2)
2869         Ctilde(1,2,i-2)= CC(1,2,i-2)
2870         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2871         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2872 !c
2873         Dtilde(1,1,i-2)= DD(1,1,i-2)
2874         Dtilde(1,2,i-2)= DD(1,2,i-2)
2875         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2876         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2877       enddo
2878 #ifdef PARMAT
2879       do i=ivec_start+2,ivec_end+2
2880 #else
2881       do i=3,nres+1
2882 #endif
2883
2884 !      print *,i,"i"
2885         if (i .lt. nres+1) then
2886           sin1=dsin(phi(i))
2887           cos1=dcos(phi(i))
2888           sintab(i-2)=sin1
2889           costab(i-2)=cos1
2890           obrot(1,i-2)=cos1
2891           obrot(2,i-2)=sin1
2892           sin2=dsin(2*phi(i))
2893           cos2=dcos(2*phi(i))
2894           sintab2(i-2)=sin2
2895           costab2(i-2)=cos2
2896           obrot2(1,i-2)=cos2
2897           obrot2(2,i-2)=sin2
2898           Ug(1,1,i-2)=-cos1
2899           Ug(1,2,i-2)=-sin1
2900           Ug(2,1,i-2)=-sin1
2901           Ug(2,2,i-2)= cos1
2902           Ug2(1,1,i-2)=-cos2
2903           Ug2(1,2,i-2)=-sin2
2904           Ug2(2,1,i-2)=-sin2
2905           Ug2(2,2,i-2)= cos2
2906         else
2907           costab(i-2)=1.0d0
2908           sintab(i-2)=0.0d0
2909           obrot(1,i-2)=1.0d0
2910           obrot(2,i-2)=0.0d0
2911           obrot2(1,i-2)=0.0d0
2912           obrot2(2,i-2)=0.0d0
2913           Ug(1,1,i-2)=1.0d0
2914           Ug(1,2,i-2)=0.0d0
2915           Ug(2,1,i-2)=0.0d0
2916           Ug(2,2,i-2)=1.0d0
2917           Ug2(1,1,i-2)=0.0d0
2918           Ug2(1,2,i-2)=0.0d0
2919           Ug2(2,1,i-2)=0.0d0
2920           Ug2(2,2,i-2)=0.0d0
2921         endif
2922         if (i .gt. 3 .and. i .lt. nres+1) then
2923           obrot_der(1,i-2)=-sin1
2924           obrot_der(2,i-2)= cos1
2925           Ugder(1,1,i-2)= sin1
2926           Ugder(1,2,i-2)=-cos1
2927           Ugder(2,1,i-2)=-cos1
2928           Ugder(2,2,i-2)=-sin1
2929           dwacos2=cos2+cos2
2930           dwasin2=sin2+sin2
2931           obrot2_der(1,i-2)=-dwasin2
2932           obrot2_der(2,i-2)= dwacos2
2933           Ug2der(1,1,i-2)= dwasin2
2934           Ug2der(1,2,i-2)=-dwacos2
2935           Ug2der(2,1,i-2)=-dwacos2
2936           Ug2der(2,2,i-2)=-dwasin2
2937         else
2938           obrot_der(1,i-2)=0.0d0
2939           obrot_der(2,i-2)=0.0d0
2940           Ugder(1,1,i-2)=0.0d0
2941           Ugder(1,2,i-2)=0.0d0
2942           Ugder(2,1,i-2)=0.0d0
2943           Ugder(2,2,i-2)=0.0d0
2944           obrot2_der(1,i-2)=0.0d0
2945           obrot2_der(2,i-2)=0.0d0
2946           Ug2der(1,1,i-2)=0.0d0
2947           Ug2der(1,2,i-2)=0.0d0
2948           Ug2der(2,1,i-2)=0.0d0
2949           Ug2der(2,2,i-2)=0.0d0
2950         endif
2951 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2952         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2953            if (itype(i-2,1).eq.0) then
2954           iti=ntortyp+1
2955            else
2956           iti = itype2loc(itype(i-2,1))
2957            endif
2958         else
2959           iti=nloctyp
2960         endif
2961 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2962         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2963            if (itype(i-1,1).eq.0) then
2964           iti1=nloctyp
2965            else
2966           iti1 = itype2loc(itype(i-1,1))
2967            endif
2968         else
2969           iti1=nloctyp
2970         endif
2971 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2972 !d        write (iout,*) '*******i',i,' iti1',iti
2973 !        write (iout,*) 'b1',b1(:,iti)
2974 !        write (iout,*) 'b2',b2(:,i-2)
2975 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2976 !        if (i .gt. iatel_s+2) then
2977         if (i .gt. nnt+2) then
2978           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2979 #ifdef NEWCORR
2980           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2981 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2982 #endif
2983
2984           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2985           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2986           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2987           then
2988           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2989           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2990           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2991           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2992           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2993           endif
2994         else
2995           do k=1,2
2996             Ub2(k,i-2)=0.0d0
2997             Ctobr(k,i-2)=0.0d0
2998             Dtobr2(k,i-2)=0.0d0
2999             do l=1,2
3000               EUg(l,k,i-2)=0.0d0
3001               CUg(l,k,i-2)=0.0d0
3002               DUg(l,k,i-2)=0.0d0
3003               DtUg2(l,k,i-2)=0.0d0
3004             enddo
3005           enddo
3006         endif
3007         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3008         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3009         do k=1,2
3010           muder(k,i-2)=Ub2der(k,i-2)
3011         enddo
3012 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3013         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3014           if (itype(i-1,1).eq.0) then
3015            iti1=ntortyp+1
3016           elseif (itype(i-1,1).le.ntyp) then
3017             iti1 = itype2loc(itype(i-1,1))
3018           else
3019             iti1=nloctyp
3020           endif
3021         else
3022           iti1=nloctyp
3023         endif
3024         do k=1,2
3025           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3026         enddo
3027         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3028         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3029         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3030 !d        write (iout,*) 'mu1',mu1(:,i-2)
3031 !d        write (iout,*) 'mu2',mu2(:,i-2)
3032         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3033         then
3034         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3035         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3036         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3037         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3038         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3039 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3040         call matvec2(DD(1,1,i-2),b1tilde(1,iti1),auxvec(1))
3041         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3042         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3043         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3044         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3045         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3046         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3047         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3048         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3049         endif
3050       enddo
3051 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3052 ! The order of matrices is from left to right.
3053       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3054       then
3055 !      do i=max0(ivec_start,2),ivec_end
3056       do i=2,nres-1
3057         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3058         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3059         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3060         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3061         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3062         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3063         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3064         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3065       enddo
3066       endif
3067 #if defined(MPI) && defined(PARMAT)
3068 #ifdef DEBUG
3069 !      if (fg_rank.eq.0) then
3070         write (iout,*) "Arrays UG and UGDER before GATHER"
3071         do i=1,nres-1
3072           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3073            ((ug(l,k,i),l=1,2),k=1,2),&
3074            ((ugder(l,k,i),l=1,2),k=1,2)
3075         enddo
3076         write (iout,*) "Arrays UG2 and UG2DER"
3077         do i=1,nres-1
3078           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3079            ((ug2(l,k,i),l=1,2),k=1,2),&
3080            ((ug2der(l,k,i),l=1,2),k=1,2)
3081         enddo
3082         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3083         do i=1,nres-1
3084           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3085            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3086            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3087         enddo
3088         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3089         do i=1,nres-1
3090           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3091            costab(i),sintab(i),costab2(i),sintab2(i)
3092         enddo
3093         write (iout,*) "Array MUDER"
3094         do i=1,nres-1
3095           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3096         enddo
3097 !      endif
3098 #endif
3099       if (nfgtasks.gt.1) then
3100         time00=MPI_Wtime()
3101 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3102 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3103 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3104 #ifdef MATGATHER
3105         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3106          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3107          FG_COMM1,IERR)
3108         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3109          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3110          FG_COMM1,IERR)
3111         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3112          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3113          FG_COMM1,IERR)
3114         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3115          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3116          FG_COMM1,IERR)
3117         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3118          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3119          FG_COMM1,IERR)
3120         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3121          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3122          FG_COMM1,IERR)
3123         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3124          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3125          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3126         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3127          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3128          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3129         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3130          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3131          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3132         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3133          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3134          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3135         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3136         then
3137         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3138          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3139          FG_COMM1,IERR)
3140         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3141          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3142          FG_COMM1,IERR)
3143         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3144          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3145          FG_COMM1,IERR)
3146        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3147          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3148          FG_COMM1,IERR)
3149         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3150          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3151          FG_COMM1,IERR)
3152         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3153          ivec_count(fg_rank1),&
3154          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3155          FG_COMM1,IERR)
3156         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3157          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3158          FG_COMM1,IERR)
3159         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3160          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3161          FG_COMM1,IERR)
3162         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3163          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3164          FG_COMM1,IERR)
3165         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3166          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3167          FG_COMM1,IERR)
3168         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3172          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3173          FG_COMM1,IERR)
3174         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3175          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3176          FG_COMM1,IERR)
3177         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3178          ivec_count(fg_rank1),&
3179          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3180          FG_COMM1,IERR)
3181         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3182          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3183          FG_COMM1,IERR)
3184        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3189          FG_COMM1,IERR)
3190        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3194          ivec_count(fg_rank1),&
3195          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3196          FG_COMM1,IERR)
3197         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3198          ivec_count(fg_rank1),&
3199          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3200          FG_COMM1,IERR)
3201         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3202          ivec_count(fg_rank1),&
3203          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3204          MPI_MAT2,FG_COMM1,IERR)
3205         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3206          ivec_count(fg_rank1),&
3207          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3208          MPI_MAT2,FG_COMM1,IERR)
3209         endif
3210 #else
3211 ! Passes matrix info through the ring
3212       isend=fg_rank1
3213       irecv=fg_rank1-1
3214       if (irecv.lt.0) irecv=nfgtasks1-1
3215       iprev=irecv
3216       inext=fg_rank1+1
3217       if (inext.ge.nfgtasks1) inext=0
3218       do i=1,nfgtasks1-1
3219 !        write (iout,*) "isend",isend," irecv",irecv
3220 !        call flush(iout)
3221         lensend=lentyp(isend)
3222         lenrecv=lentyp(irecv)
3223 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3224 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3225 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3226 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3227 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3228 !        write (iout,*) "Gather ROTAT1"
3229 !        call flush(iout)
3230 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3231 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3232 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3233 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3234 !        write (iout,*) "Gather ROTAT2"
3235 !        call flush(iout)
3236         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3237          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3238          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3239          iprev,4400+irecv,FG_COMM,status,IERR)
3240 !        write (iout,*) "Gather ROTAT_OLD"
3241 !        call flush(iout)
3242         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3243          MPI_PRECOMP11(lensend),inext,5500+isend,&
3244          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3245          iprev,5500+irecv,FG_COMM,status,IERR)
3246 !        write (iout,*) "Gather PRECOMP11"
3247 !        call flush(iout)
3248         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3249          MPI_PRECOMP12(lensend),inext,6600+isend,&
3250          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3251          iprev,6600+irecv,FG_COMM,status,IERR)
3252 !        write (iout,*) "Gather PRECOMP12"
3253 !        call flush(iout)
3254         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3255         then
3256         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3257          MPI_ROTAT2(lensend),inext,7700+isend,&
3258          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3259          iprev,7700+irecv,FG_COMM,status,IERR)
3260 !        write (iout,*) "Gather PRECOMP21"
3261 !        call flush(iout)
3262         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3263          MPI_PRECOMP22(lensend),inext,8800+isend,&
3264          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3265          iprev,8800+irecv,FG_COMM,status,IERR)
3266 !        write (iout,*) "Gather PRECOMP22"
3267 !        call flush(iout)
3268         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3269          MPI_PRECOMP23(lensend),inext,9900+isend,&
3270          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3271          MPI_PRECOMP23(lenrecv),&
3272          iprev,9900+irecv,FG_COMM,status,IERR)
3273 !        write (iout,*) "Gather PRECOMP23"
3274 !        call flush(iout)
3275         endif
3276         isend=irecv
3277         irecv=irecv-1
3278         if (irecv.lt.0) irecv=nfgtasks1-1
3279       enddo
3280 #endif
3281         time_gather=time_gather+MPI_Wtime()-time00
3282       endif
3283 #ifdef DEBUG
3284 !      if (fg_rank.eq.0) then
3285         write (iout,*) "Arrays UG and UGDER"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3288            ((ug(l,k,i),l=1,2),k=1,2),&
3289            ((ugder(l,k,i),l=1,2),k=1,2)
3290         enddo
3291         write (iout,*) "Arrays UG2 and UG2DER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3294            ((ug2(l,k,i),l=1,2),k=1,2),&
3295            ((ug2der(l,k,i),l=1,2),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3300            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3301            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3302         enddo
3303         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3304         do i=1,nres-1
3305           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3306            costab(i),sintab(i),costab2(i),sintab2(i)
3307         enddo
3308         write (iout,*) "Array MUDER"
3309         do i=1,nres-1
3310           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3311         enddo
3312 !      endif
3313 #endif
3314 #endif
3315 !d      do i=1,nres
3316 !d        iti = itortyp(itype(i,1))
3317 !d        write (iout,*) i
3318 !d        do j=1,2
3319 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3320 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3321 !d        enddo
3322 !d      enddo
3323       return
3324       end subroutine set_matrices
3325 !-----------------------------------------------------------------------------
3326       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3327 !
3328 ! This subroutine calculates the average interaction energy and its gradient
3329 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3330 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3331 ! The potential depends both on the distance of peptide-group centers and on
3332 ! the orientation of the CA-CA virtual bonds.
3333 !
3334       use comm_locel
3335 !      implicit real*8 (a-h,o-z)
3336 #ifdef MPI
3337       include 'mpif.h'
3338 #endif
3339 !      include 'DIMENSIONS'
3340 !      include 'COMMON.CONTROL'
3341 !      include 'COMMON.SETUP'
3342 !      include 'COMMON.IOUNITS'
3343 !      include 'COMMON.GEO'
3344 !      include 'COMMON.VAR'
3345 !      include 'COMMON.LOCAL'
3346 !      include 'COMMON.CHAIN'
3347 !      include 'COMMON.DERIV'
3348 !      include 'COMMON.INTERACT'
3349 !      include 'COMMON.CONTACTS'
3350 !      include 'COMMON.TORSION'
3351 !      include 'COMMON.VECTORS'
3352 !      include 'COMMON.FFIELD'
3353 !      include 'COMMON.TIME1'
3354       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3355       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3356       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3357 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3358       real(kind=8),dimension(4) :: muij
3359 !el      integer :: num_conti,j1,j2
3360 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3361 !el        dz_normi,xmedi,ymedi,zmedi
3362
3363 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3364 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3365 !el          num_conti,j1,j2
3366
3367 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3368 #ifdef MOMENT
3369       real(kind=8) :: scal_el=1.0d0
3370 #else
3371       real(kind=8) :: scal_el=0.5d0
3372 #endif
3373 ! 12/13/98
3374 ! 13-go grudnia roku pamietnego...
3375       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3376                                              0.0d0,1.0d0,0.0d0,&
3377                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3378 !el local variables
3379       integer :: i,k,j
3380       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3381       real(kind=8) :: fac,t_eelecij,fracinbuf
3382
3383
3384 !d      write(iout,*) 'In EELEC'
3385 !        print *,"IN EELEC"
3386 !d      do i=1,nloctyp
3387 !d        write(iout,*) 'Type',i
3388 !d        write(iout,*) 'B1',B1(:,i)
3389 !d        write(iout,*) 'B2',B2(:,i)
3390 !d        write(iout,*) 'CC',CC(:,:,i)
3391 !d        write(iout,*) 'DD',DD(:,:,i)
3392 !d        write(iout,*) 'EE',EE(:,:,i)
3393 !d      enddo
3394 !d      call check_vecgrad
3395 !d      stop
3396 !      ees=0.0d0  !AS
3397 !      evdw1=0.0d0
3398 !      eel_loc=0.0d0
3399 !      eello_turn3=0.0d0
3400 !      eello_turn4=0.0d0
3401       t_eelecij=0.0d0
3402       ees=0.0D0
3403       evdw1=0.0D0
3404       eel_loc=0.0d0
3405       eello_turn3=0.0d0
3406       eello_turn4=0.0d0
3407 !
3408
3409       if (icheckgrad.eq.1) then
3410 !el
3411 !        do i=0,2*nres+2
3412 !          dc_norm(1,i)=0.0d0
3413 !          dc_norm(2,i)=0.0d0
3414 !          dc_norm(3,i)=0.0d0
3415 !        enddo
3416         do i=1,nres-1
3417           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3418           do k=1,3
3419             dc_norm(k,i)=dc(k,i)*fac
3420           enddo
3421 !          write (iout,*) 'i',i,' fac',fac
3422         enddo
3423       endif
3424 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3425 !        wturn6
3426       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3427           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3428           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3429 !        call vec_and_deriv
3430 #ifdef TIMING
3431         time01=MPI_Wtime()
3432 #endif
3433 !        print *, "before set matrices"
3434         call set_matrices
3435 !        print *, "after set matrices"
3436
3437 #ifdef TIMING
3438         time_mat=time_mat+MPI_Wtime()-time01
3439 #endif
3440       endif
3441 !       print *, "after set matrices"
3442 !d      do i=1,nres-1
3443 !d        write (iout,*) 'i=',i
3444 !d        do k=1,3
3445 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3446 !d        enddo
3447 !d        do k=1,3
3448 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3449 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3450 !d        enddo
3451 !d      enddo
3452       t_eelecij=0.0d0
3453       ees=0.0D0
3454       evdw1=0.0D0
3455       eel_loc=0.0d0
3456       eello_turn3=0.0d0
3457       eello_turn4=0.0d0
3458 !el      ind=0
3459       do i=1,nres
3460         num_cont_hb(i)=0
3461       enddo
3462 !d      print '(a)','Enter EELEC'
3463 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3464 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3465 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3466       do i=1,nres
3467         gel_loc_loc(i)=0.0d0
3468         gcorr_loc(i)=0.0d0
3469       enddo
3470 !
3471 !
3472 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3473 !
3474 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3475 !
3476
3477
3478 !        print *,"before iturn3 loop"
3479       do i=iturn3_start,iturn3_end
3480         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3481         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3482         dxi=dc(1,i)
3483         dyi=dc(2,i)
3484         dzi=dc(3,i)
3485         dx_normi=dc_norm(1,i)
3486         dy_normi=dc_norm(2,i)
3487         dz_normi=dc_norm(3,i)
3488         xmedi=c(1,i)+0.5d0*dxi
3489         ymedi=c(2,i)+0.5d0*dyi
3490         zmedi=c(3,i)+0.5d0*dzi
3491           xmedi=dmod(xmedi,boxxsize)
3492           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3493           ymedi=dmod(ymedi,boxysize)
3494           if (ymedi.lt.0) ymedi=ymedi+boxysize
3495           zmedi=dmod(zmedi,boxzsize)
3496           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3497         num_conti=0
3498        if ((zmedi.gt.bordlipbot) &
3499         .and.(zmedi.lt.bordliptop)) then
3500 !C the energy transfer exist
3501         if (zmedi.lt.buflipbot) then
3502 !C what fraction I am in
3503          fracinbuf=1.0d0- &
3504                ((zmedi-bordlipbot)/lipbufthick)
3505 !C lipbufthick is thickenes of lipid buffore
3506          sslipi=sscalelip(fracinbuf)
3507          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3508         elseif (zmedi.gt.bufliptop) then
3509          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3510          sslipi=sscalelip(fracinbuf)
3511          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3512         else
3513          sslipi=1.0d0
3514          ssgradlipi=0.0
3515         endif
3516        else
3517          sslipi=0.0d0
3518          ssgradlipi=0.0
3519        endif
3520 !       print *,i,sslipi,ssgradlipi
3521        call eelecij(i,i+2,ees,evdw1,eel_loc)
3522         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3523         num_cont_hb(i)=num_conti
3524       enddo
3525       do i=iturn4_start,iturn4_end
3526         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3527           .or. itype(i+3,1).eq.ntyp1 &
3528           .or. itype(i+4,1).eq.ntyp1) cycle
3529 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3530         dxi=dc(1,i)
3531         dyi=dc(2,i)
3532         dzi=dc(3,i)
3533         dx_normi=dc_norm(1,i)
3534         dy_normi=dc_norm(2,i)
3535         dz_normi=dc_norm(3,i)
3536         xmedi=c(1,i)+0.5d0*dxi
3537         ymedi=c(2,i)+0.5d0*dyi
3538         zmedi=c(3,i)+0.5d0*dzi
3539           xmedi=dmod(xmedi,boxxsize)
3540           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3541           ymedi=dmod(ymedi,boxysize)
3542           if (ymedi.lt.0) ymedi=ymedi+boxysize
3543           zmedi=dmod(zmedi,boxzsize)
3544           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3545        if ((zmedi.gt.bordlipbot)  &
3546        .and.(zmedi.lt.bordliptop)) then
3547 !C the energy transfer exist
3548         if (zmedi.lt.buflipbot) then
3549 !C what fraction I am in
3550          fracinbuf=1.0d0- &
3551              ((zmedi-bordlipbot)/lipbufthick)
3552 !C lipbufthick is thickenes of lipid buffore
3553          sslipi=sscalelip(fracinbuf)
3554          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3555         elseif (zmedi.gt.bufliptop) then
3556          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3557          sslipi=sscalelip(fracinbuf)
3558          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3559         else
3560          sslipi=1.0d0
3561          ssgradlipi=0.0
3562         endif
3563        else
3564          sslipi=0.0d0
3565          ssgradlipi=0.0
3566        endif
3567
3568         num_conti=num_cont_hb(i)
3569         call eelecij(i,i+3,ees,evdw1,eel_loc)
3570         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3571          call eturn4(i,eello_turn4)
3572 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3573         num_cont_hb(i)=num_conti
3574       enddo   ! i
3575 !
3576 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3577 !
3578 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3579       do i=iatel_s,iatel_e
3580         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3581         dxi=dc(1,i)
3582         dyi=dc(2,i)
3583         dzi=dc(3,i)
3584         dx_normi=dc_norm(1,i)
3585         dy_normi=dc_norm(2,i)
3586         dz_normi=dc_norm(3,i)
3587         xmedi=c(1,i)+0.5d0*dxi
3588         ymedi=c(2,i)+0.5d0*dyi
3589         zmedi=c(3,i)+0.5d0*dzi
3590           xmedi=dmod(xmedi,boxxsize)
3591           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3592           ymedi=dmod(ymedi,boxysize)
3593           if (ymedi.lt.0) ymedi=ymedi+boxysize
3594           zmedi=dmod(zmedi,boxzsize)
3595           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3596        if ((zmedi.gt.bordlipbot)  &
3597         .and.(zmedi.lt.bordliptop)) then
3598 !C the energy transfer exist
3599         if (zmedi.lt.buflipbot) then
3600 !C what fraction I am in
3601          fracinbuf=1.0d0- &
3602              ((zmedi-bordlipbot)/lipbufthick)
3603 !C lipbufthick is thickenes of lipid buffore
3604          sslipi=sscalelip(fracinbuf)
3605          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3606         elseif (zmedi.gt.bufliptop) then
3607          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3608          sslipi=sscalelip(fracinbuf)
3609          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3610         else
3611          sslipi=1.0d0
3612          ssgradlipi=0.0
3613         endif
3614        else
3615          sslipi=0.0d0
3616          ssgradlipi=0.0
3617        endif
3618
3619 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3620         num_conti=num_cont_hb(i)
3621         do j=ielstart(i),ielend(i)
3622 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3623           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3624           call eelecij(i,j,ees,evdw1,eel_loc)
3625         enddo ! j
3626         num_cont_hb(i)=num_conti
3627       enddo   ! i
3628 !      write (iout,*) "Number of loop steps in EELEC:",ind
3629 !d      do i=1,nres
3630 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3631 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3632 !d      enddo
3633 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3634 !cc      eel_loc=eel_loc+eello_turn3
3635 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3636       return
3637       end subroutine eelec
3638 !-----------------------------------------------------------------------------
3639       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3640
3641       use comm_locel
3642 !      implicit real*8 (a-h,o-z)
3643 !      include 'DIMENSIONS'
3644 #ifdef MPI
3645       include "mpif.h"
3646 #endif
3647 !      include 'COMMON.CONTROL'
3648 !      include 'COMMON.IOUNITS'
3649 !      include 'COMMON.GEO'
3650 !      include 'COMMON.VAR'
3651 !      include 'COMMON.LOCAL'
3652 !      include 'COMMON.CHAIN'
3653 !      include 'COMMON.DERIV'
3654 !      include 'COMMON.INTERACT'
3655 !      include 'COMMON.CONTACTS'
3656 !      include 'COMMON.TORSION'
3657 !      include 'COMMON.VECTORS'
3658 !      include 'COMMON.FFIELD'
3659 !      include 'COMMON.TIME1'
3660       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3661       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3662       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3663 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3664       real(kind=8),dimension(4) :: muij
3665       real(kind=8) :: geel_loc_ij,geel_loc_ji
3666       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3667                     dist_temp, dist_init,rlocshield,fracinbuf
3668       integer xshift,yshift,zshift,ilist,iresshield
3669 !el      integer :: num_conti,j1,j2
3670 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3671 !el        dz_normi,xmedi,ymedi,zmedi
3672
3673 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3674 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3675 !el          num_conti,j1,j2
3676
3677 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3678 #ifdef MOMENT
3679       real(kind=8) :: scal_el=1.0d0
3680 #else
3681       real(kind=8) :: scal_el=0.5d0
3682 #endif
3683 ! 12/13/98
3684 ! 13-go grudnia roku pamietnego...
3685       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3686                                              0.0d0,1.0d0,0.0d0,&
3687                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3688 !      integer :: maxconts=nres/4
3689 !el local variables
3690       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3691       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3692       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3693       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3694                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3695                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3696                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3697                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3698                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3699                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3700                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3701 !      maxconts=nres/4
3702 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3703 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3704
3705 !          time00=MPI_Wtime()
3706 !d      write (iout,*) "eelecij",i,j
3707 !          ind=ind+1
3708           iteli=itel(i)
3709           itelj=itel(j)
3710           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3711           aaa=app(iteli,itelj)
3712           bbb=bpp(iteli,itelj)
3713           ael6i=ael6(iteli,itelj)
3714           ael3i=ael3(iteli,itelj)
3715           dxj=dc(1,j)
3716           dyj=dc(2,j)
3717           dzj=dc(3,j)
3718           dx_normj=dc_norm(1,j)
3719           dy_normj=dc_norm(2,j)
3720           dz_normj=dc_norm(3,j)
3721 !          xj=c(1,j)+0.5D0*dxj-xmedi
3722 !          yj=c(2,j)+0.5D0*dyj-ymedi
3723 !          zj=c(3,j)+0.5D0*dzj-zmedi
3724           xj=c(1,j)+0.5D0*dxj
3725           yj=c(2,j)+0.5D0*dyj
3726           zj=c(3,j)+0.5D0*dzj
3727           xj=mod(xj,boxxsize)
3728           if (xj.lt.0) xj=xj+boxxsize
3729           yj=mod(yj,boxysize)
3730           if (yj.lt.0) yj=yj+boxysize
3731           zj=mod(zj,boxzsize)
3732           if (zj.lt.0) zj=zj+boxzsize
3733        if ((zj.gt.bordlipbot)  &
3734        .and.(zj.lt.bordliptop)) then
3735 !C the energy transfer exist
3736         if (zj.lt.buflipbot) then
3737 !C what fraction I am in
3738          fracinbuf=1.0d0-     &
3739              ((zj-bordlipbot)/lipbufthick)
3740 !C lipbufthick is thickenes of lipid buffore
3741          sslipj=sscalelip(fracinbuf)
3742          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3743         elseif (zj.gt.bufliptop) then
3744          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3745          sslipj=sscalelip(fracinbuf)
3746          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3747         else
3748          sslipj=1.0d0
3749          ssgradlipj=0.0
3750         endif
3751        else
3752          sslipj=0.0d0
3753          ssgradlipj=0.0
3754        endif
3755
3756       isubchap=0
3757       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3758       xj_safe=xj
3759       yj_safe=yj
3760       zj_safe=zj
3761       do xshift=-1,1
3762       do yshift=-1,1
3763       do zshift=-1,1
3764           xj=xj_safe+xshift*boxxsize
3765           yj=yj_safe+yshift*boxysize
3766           zj=zj_safe+zshift*boxzsize
3767           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3768           if(dist_temp.lt.dist_init) then
3769             dist_init=dist_temp
3770             xj_temp=xj
3771             yj_temp=yj
3772             zj_temp=zj
3773             isubchap=1
3774           endif
3775        enddo
3776        enddo
3777        enddo
3778        if (isubchap.eq.1) then
3779 !C          print *,i,j
3780           xj=xj_temp-xmedi
3781           yj=yj_temp-ymedi
3782           zj=zj_temp-zmedi
3783        else
3784           xj=xj_safe-xmedi
3785           yj=yj_safe-ymedi
3786           zj=zj_safe-zmedi
3787        endif
3788
3789           rij=xj*xj+yj*yj+zj*zj
3790           rrmij=1.0D0/rij
3791           rij=dsqrt(rij)
3792 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3793             sss_ele_cut=sscale_ele(rij)
3794             sss_ele_grad=sscagrad_ele(rij)
3795 !             sss_ele_cut=1.0d0
3796 !             sss_ele_grad=0.0d0
3797 !            print *,sss_ele_cut,sss_ele_grad,&
3798 !            (rij),r_cut_ele,rlamb_ele
3799 !            if (sss_ele_cut.le.0.0) go to 128
3800
3801           rmij=1.0D0/rij
3802           r3ij=rrmij*rmij
3803           r6ij=r3ij*r3ij
3804           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3805           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3806           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3807           fac=cosa-3.0D0*cosb*cosg
3808           ev1=aaa*r6ij*r6ij
3809 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3810           if (j.eq.i+2) ev1=scal_el*ev1
3811           ev2=bbb*r6ij
3812           fac3=ael6i*r6ij
3813           fac4=ael3i*r3ij
3814           evdwij=ev1+ev2
3815           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3816           el2=fac4*fac
3817 !          eesij=el1+el2
3818           if (shield_mode.gt.0) then
3819 !C          fac_shield(i)=0.4
3820 !C          fac_shield(j)=0.6
3821           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3822           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3823           eesij=(el1+el2)
3824           ees=ees+eesij*sss_ele_cut
3825 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3826 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3827           else
3828           fac_shield(i)=1.0
3829           fac_shield(j)=1.0
3830           eesij=(el1+el2)
3831           ees=ees+eesij   &
3832             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3833 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3834           endif
3835
3836 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3837           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3838 !          ees=ees+eesij*sss_ele_cut
3839           evdw1=evdw1+evdwij*sss_ele_cut  &
3840            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3841 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3842 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3843 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3844 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3845
3846           if (energy_dec) then
3847 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3848 !                  'evdw1',i,j,evdwij,&
3849 !                  iteli,itelj,aaa,evdw1
3850               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3851               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3852           endif
3853 !
3854 ! Calculate contributions to the Cartesian gradient.
3855 !
3856 #ifdef SPLITELE
3857           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3858               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3859           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3860              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3861           fac1=fac
3862           erij(1)=xj*rmij
3863           erij(2)=yj*rmij
3864           erij(3)=zj*rmij
3865 !
3866 ! Radial derivatives. First process both termini of the fragment (i,j)
3867 !
3868           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3869           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3870           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3871            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3872           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3873             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3874
3875           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3876           (shield_mode.gt.0)) then
3877 !C          print *,i,j
3878           do ilist=1,ishield_list(i)
3879            iresshield=shield_list(ilist,i)
3880            do k=1,3
3881            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3882            *2.0*sss_ele_cut
3883            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3884                    rlocshield &
3885             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3886             *sss_ele_cut
3887             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3888            enddo
3889           enddo
3890           do ilist=1,ishield_list(j)
3891            iresshield=shield_list(ilist,j)
3892            do k=1,3
3893            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3894           *2.0*sss_ele_cut
3895            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3896                    rlocshield &
3897            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3898            *sss_ele_cut
3899            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3900            enddo
3901           enddo
3902           do k=1,3
3903             gshieldc(k,i)=gshieldc(k,i)+ &
3904                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3905            *sss_ele_cut
3906
3907             gshieldc(k,j)=gshieldc(k,j)+ &
3908                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3909            *sss_ele_cut
3910
3911             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3912                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3913            *sss_ele_cut
3914
3915             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3916                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3917            *sss_ele_cut
3918
3919            enddo
3920            endif
3921
3922
3923 !          do k=1,3
3924 !            ghalf=0.5D0*ggg(k)
3925 !            gelc(k,i)=gelc(k,i)+ghalf
3926 !            gelc(k,j)=gelc(k,j)+ghalf
3927 !          enddo
3928 ! 9/28/08 AL Gradient compotents will be summed only at the end
3929           do k=1,3
3930             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3931             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3932           enddo
3933             gelc_long(3,j)=gelc_long(3,j)+  &
3934           ssgradlipj*eesij/2.0d0*lipscale**2&
3935            *sss_ele_cut
3936
3937             gelc_long(3,i)=gelc_long(3,i)+  &
3938           ssgradlipi*eesij/2.0d0*lipscale**2&
3939            *sss_ele_cut
3940
3941
3942 !
3943 ! Loop over residues i+1 thru j-1.
3944 !
3945 !grad          do k=i+1,j-1
3946 !grad            do l=1,3
3947 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3948 !grad            enddo
3949 !grad          enddo
3950           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3951            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3952           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3953            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3954           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3955            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3956
3957 !          do k=1,3
3958 !            ghalf=0.5D0*ggg(k)
3959 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3960 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3961 !          enddo
3962 ! 9/28/08 AL Gradient compotents will be summed only at the end
3963           do k=1,3
3964             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3965             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3966           enddo
3967
3968 !C Lipidic part for scaling weight
3969            gvdwpp(3,j)=gvdwpp(3,j)+ &
3970           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3971            gvdwpp(3,i)=gvdwpp(3,i)+ &
3972           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3973 !! Loop over residues i+1 thru j-1.
3974 !
3975 !grad          do k=i+1,j-1
3976 !grad            do l=1,3
3977 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3978 !grad            enddo
3979 !grad          enddo
3980 #else
3981           facvdw=(ev1+evdwij)*sss_ele_cut &
3982            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3983
3984           facel=(el1+eesij)*sss_ele_cut
3985           fac1=fac
3986           fac=-3*rrmij*(facvdw+facvdw+facel)
3987           erij(1)=xj*rmij
3988           erij(2)=yj*rmij
3989           erij(3)=zj*rmij
3990 !
3991 ! Radial derivatives. First process both termini of the fragment (i,j)
3992 !
3993           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3994           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3995           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3996 !          do k=1,3
3997 !            ghalf=0.5D0*ggg(k)
3998 !            gelc(k,i)=gelc(k,i)+ghalf
3999 !            gelc(k,j)=gelc(k,j)+ghalf
4000 !          enddo
4001 ! 9/28/08 AL Gradient compotents will be summed only at the end
4002           do k=1,3
4003             gelc_long(k,j)=gelc(k,j)+ggg(k)
4004             gelc_long(k,i)=gelc(k,i)-ggg(k)
4005           enddo
4006 !
4007 ! Loop over residues i+1 thru j-1.
4008 !
4009 !grad          do k=i+1,j-1
4010 !grad            do l=1,3
4011 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4012 !grad            enddo
4013 !grad          enddo
4014 ! 9/28/08 AL Gradient compotents will be summed only at the end
4015           ggg(1)=facvdw*xj &
4016            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4017           ggg(2)=facvdw*yj &
4018            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4019           ggg(3)=facvdw*zj &
4020            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4021
4022           do k=1,3
4023             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4024             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4025           enddo
4026            gvdwpp(3,j)=gvdwpp(3,j)+ &
4027           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4028            gvdwpp(3,i)=gvdwpp(3,i)+ &
4029           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4030
4031 #endif
4032 !
4033 ! Angular part
4034 !
4035           ecosa=2.0D0*fac3*fac1+fac4
4036           fac4=-3.0D0*fac4
4037           fac3=-6.0D0*fac3
4038           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4039           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4040           do k=1,3
4041             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4042             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4043           enddo
4044 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4045 !d   &          (dcosg(k),k=1,3)
4046           do k=1,3
4047             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4048              *fac_shield(i)**2*fac_shield(j)**2 &
4049              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4050
4051           enddo
4052 !          do k=1,3
4053 !            ghalf=0.5D0*ggg(k)
4054 !            gelc(k,i)=gelc(k,i)+ghalf
4055 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4056 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4057 !            gelc(k,j)=gelc(k,j)+ghalf
4058 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4059 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4060 !          enddo
4061 !grad          do k=i+1,j-1
4062 !grad            do l=1,3
4063 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4064 !grad            enddo
4065 !grad          enddo
4066           do k=1,3
4067             gelc(k,i)=gelc(k,i) &
4068                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4069                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4070                      *sss_ele_cut &
4071                      *fac_shield(i)**2*fac_shield(j)**2 &
4072                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4073
4074             gelc(k,j)=gelc(k,j) &
4075                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4076                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4077                      *sss_ele_cut  &
4078                      *fac_shield(i)**2*fac_shield(j)**2  &
4079                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4080
4081             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4082             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4083           enddo
4084
4085           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4086               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4087               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4088 !
4089 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4090 !   energy of a peptide unit is assumed in the form of a second-order
4091 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4092 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4093 !   are computed for EVERY pair of non-contiguous peptide groups.
4094 !
4095           if (j.lt.nres-1) then
4096             j1=j+1
4097             j2=j-1
4098           else
4099             j1=j-1
4100             j2=j-2
4101           endif
4102           kkk=0
4103           do k=1,2
4104             do l=1,2
4105               kkk=kkk+1
4106               muij(kkk)=mu(k,i)*mu(l,j)
4107 #ifdef NEWCORR
4108              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4109 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4110              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4111              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4112 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4113              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4114 #endif
4115
4116             enddo
4117           enddo
4118 !d         write (iout,*) 'EELEC: i',i,' j',j
4119 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4120 !d          write(iout,*) 'muij',muij
4121           ury=scalar(uy(1,i),erij)
4122           urz=scalar(uz(1,i),erij)
4123           vry=scalar(uy(1,j),erij)
4124           vrz=scalar(uz(1,j),erij)
4125           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4126           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4127           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4128           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4129           fac=dsqrt(-ael6i)*r3ij
4130           a22=a22*fac
4131           a23=a23*fac
4132           a32=a32*fac
4133           a33=a33*fac
4134 !d          write (iout,'(4i5,4f10.5)')
4135 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4136 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4137 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4138 !d     &      uy(:,j),uz(:,j)
4139 !d          write (iout,'(4f10.5)')
4140 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4141 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4142 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4143 !d           write (iout,'(9f10.5/)')
4144 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4145 ! Derivatives of the elements of A in virtual-bond vectors
4146           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4147           do k=1,3
4148             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4149             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4150             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4151             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4152             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4153             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4154             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4155             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4156             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4157             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4158             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4159             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4160           enddo
4161 ! Compute radial contributions to the gradient
4162           facr=-3.0d0*rrmij
4163           a22der=a22*facr
4164           a23der=a23*facr
4165           a32der=a32*facr
4166           a33der=a33*facr
4167           agg(1,1)=a22der*xj
4168           agg(2,1)=a22der*yj
4169           agg(3,1)=a22der*zj
4170           agg(1,2)=a23der*xj
4171           agg(2,2)=a23der*yj
4172           agg(3,2)=a23der*zj
4173           agg(1,3)=a32der*xj
4174           agg(2,3)=a32der*yj
4175           agg(3,3)=a32der*zj
4176           agg(1,4)=a33der*xj
4177           agg(2,4)=a33der*yj
4178           agg(3,4)=a33der*zj
4179 ! Add the contributions coming from er
4180           fac3=-3.0d0*fac
4181           do k=1,3
4182             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4183             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4184             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4185             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4186           enddo
4187           do k=1,3
4188 ! Derivatives in DC(i)
4189 !grad            ghalf1=0.5d0*agg(k,1)
4190 !grad            ghalf2=0.5d0*agg(k,2)
4191 !grad            ghalf3=0.5d0*agg(k,3)
4192 !grad            ghalf4=0.5d0*agg(k,4)
4193             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4194             -3.0d0*uryg(k,2)*vry)!+ghalf1
4195             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4196             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4197             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4198             -3.0d0*urzg(k,2)*vry)!+ghalf3
4199             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4200             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4201 ! Derivatives in DC(i+1)
4202             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4203             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4204             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4205             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4206             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4207             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4208             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4209             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4210 ! Derivatives in DC(j)
4211             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4212             -3.0d0*vryg(k,2)*ury)!+ghalf1
4213             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4214             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4215             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4216             -3.0d0*vryg(k,2)*urz)!+ghalf3
4217             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4218             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4219 ! Derivatives in DC(j+1) or DC(nres-1)
4220             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4221             -3.0d0*vryg(k,3)*ury)
4222             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4223             -3.0d0*vrzg(k,3)*ury)
4224             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4225             -3.0d0*vryg(k,3)*urz)
4226             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4227             -3.0d0*vrzg(k,3)*urz)
4228 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4229 !grad              do l=1,4
4230 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4231 !grad              enddo
4232 !grad            endif
4233           enddo
4234           acipa(1,1)=a22
4235           acipa(1,2)=a23
4236           acipa(2,1)=a32
4237           acipa(2,2)=a33
4238           a22=-a22
4239           a23=-a23
4240           do l=1,2
4241             do k=1,3
4242               agg(k,l)=-agg(k,l)
4243               aggi(k,l)=-aggi(k,l)
4244               aggi1(k,l)=-aggi1(k,l)
4245               aggj(k,l)=-aggj(k,l)
4246               aggj1(k,l)=-aggj1(k,l)
4247             enddo
4248           enddo
4249           if (j.lt.nres-1) then
4250             a22=-a22
4251             a32=-a32
4252             do l=1,3,2
4253               do k=1,3
4254                 agg(k,l)=-agg(k,l)
4255                 aggi(k,l)=-aggi(k,l)
4256                 aggi1(k,l)=-aggi1(k,l)
4257                 aggj(k,l)=-aggj(k,l)
4258                 aggj1(k,l)=-aggj1(k,l)
4259               enddo
4260             enddo
4261           else
4262             a22=-a22
4263             a23=-a23
4264             a32=-a32
4265             a33=-a33
4266             do l=1,4
4267               do k=1,3
4268                 agg(k,l)=-agg(k,l)
4269                 aggi(k,l)=-aggi(k,l)
4270                 aggi1(k,l)=-aggi1(k,l)
4271                 aggj(k,l)=-aggj(k,l)
4272                 aggj1(k,l)=-aggj1(k,l)
4273               enddo
4274             enddo
4275           endif
4276           ENDIF ! WCORR
4277           IF (wel_loc.gt.0.0d0) THEN
4278 ! Contribution to the local-electrostatic energy coming from the i-j pair
4279           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4280            +a33*muij(4)
4281           if (shield_mode.eq.0) then
4282            fac_shield(i)=1.0
4283            fac_shield(j)=1.0
4284           endif
4285           eel_loc_ij=eel_loc_ij &
4286          *fac_shield(i)*fac_shield(j) &
4287          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4288 !C Now derivative over eel_loc
4289           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4290          (shield_mode.gt.0)) then
4291 !C          print *,i,j
4292
4293           do ilist=1,ishield_list(i)
4294            iresshield=shield_list(ilist,i)
4295            do k=1,3
4296            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4297                                                 /fac_shield(i)&
4298            *sss_ele_cut
4299            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4300                    rlocshield  &
4301           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4302           *sss_ele_cut
4303
4304             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4305            +rlocshield
4306            enddo
4307           enddo
4308           do ilist=1,ishield_list(j)
4309            iresshield=shield_list(ilist,j)
4310            do k=1,3
4311            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4312                                             /fac_shield(j)   &
4313             *sss_ele_cut
4314            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4315                    rlocshield  &
4316       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4317        *sss_ele_cut
4318
4319            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4320                   +rlocshield
4321
4322            enddo
4323           enddo
4324
4325           do k=1,3
4326             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4327                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4328                     *sss_ele_cut
4329             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4330                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4331                     *sss_ele_cut
4332             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4333                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4334                     *sss_ele_cut
4335             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4336                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4337                     *sss_ele_cut
4338
4339            enddo
4340            endif
4341
4342 #ifdef NEWCORR
4343          geel_loc_ij=(a22*gmuij1(1)&
4344           +a23*gmuij1(2)&
4345           +a32*gmuij1(3)&
4346           +a33*gmuij1(4))&
4347          *fac_shield(i)*fac_shield(j)&
4348                     *sss_ele_cut
4349
4350 !c         write(iout,*) "derivative over thatai"
4351 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4352 !c     &   a33*gmuij1(4)
4353          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4354            geel_loc_ij*wel_loc
4355 !c         write(iout,*) "derivative over thatai-1"
4356 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4357 !c     &   a33*gmuij2(4)
4358          geel_loc_ij=&
4359           a22*gmuij2(1)&
4360           +a23*gmuij2(2)&
4361           +a32*gmuij2(3)&
4362           +a33*gmuij2(4)
4363          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4364            geel_loc_ij*wel_loc&
4365          *fac_shield(i)*fac_shield(j)&
4366                     *sss_ele_cut
4367
4368
4369 !c  Derivative over j residue
4370          geel_loc_ji=a22*gmuji1(1)&
4371           +a23*gmuji1(2)&
4372           +a32*gmuji1(3)&
4373           +a33*gmuji1(4)
4374 !c         write(iout,*) "derivative over thataj"
4375 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4376 !c     &   a33*gmuji1(4)
4377
4378         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4379            geel_loc_ji*wel_loc&
4380          *fac_shield(i)*fac_shield(j)&
4381                     *sss_ele_cut
4382
4383
4384          geel_loc_ji=&
4385           +a22*gmuji2(1)&
4386           +a23*gmuji2(2)&
4387           +a32*gmuji2(3)&
4388           +a33*gmuji2(4)
4389 !c         write(iout,*) "derivative over thataj-1"
4390 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4391 !c     &   a33*gmuji2(4)
4392          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4393            geel_loc_ji*wel_loc&
4394          *fac_shield(i)*fac_shield(j)&
4395                     *sss_ele_cut
4396 #endif
4397
4398 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4399 !           eel_loc_ij=0.0
4400 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4401 !                  'eelloc',i,j,eel_loc_ij
4402           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4403                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4404 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4405
4406 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4407 !          if (energy_dec) write (iout,*) "muij",muij
4408 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4409
4410           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4411 ! Partial derivatives in virtual-bond dihedral angles gamma
4412           if (i.gt.1) &
4413           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4414                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4415                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4416                  *sss_ele_cut  &
4417           *fac_shield(i)*fac_shield(j) &
4418           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4419
4420           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4421                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4422                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4423                  *sss_ele_cut &
4424           *fac_shield(i)*fac_shield(j) &
4425           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4426 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4427 !          do l=1,3
4428 !            ggg(1)=(agg(1,1)*muij(1)+ &
4429 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4430 !            *sss_ele_cut &
4431 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4432 !            ggg(2)=(agg(2,1)*muij(1)+ &
4433 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4434 !            *sss_ele_cut &
4435 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4436 !            ggg(3)=(agg(3,1)*muij(1)+ &
4437 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4438 !            *sss_ele_cut &
4439 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4440            xtemp(1)=xj
4441            xtemp(2)=yj
4442            xtemp(3)=zj
4443
4444            do l=1,3
4445             ggg(l)=(agg(l,1)*muij(1)+ &
4446                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4447             *sss_ele_cut &
4448           *fac_shield(i)*fac_shield(j) &
4449           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4450              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4451
4452
4453             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4454             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4455 !grad            ghalf=0.5d0*ggg(l)
4456 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4457 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4458           enddo
4459             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4460           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4461           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4462
4463             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4464           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4465           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4466
4467 !grad          do k=i+1,j2
4468 !grad            do l=1,3
4469 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4470 !grad            enddo
4471 !grad          enddo
4472 ! Remaining derivatives of eello
4473           do l=1,3
4474             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4475                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4476             *sss_ele_cut &
4477           *fac_shield(i)*fac_shield(j) &
4478           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4479
4480 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4481             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4482                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4483             +aggi1(l,4)*muij(4))&
4484             *sss_ele_cut &
4485           *fac_shield(i)*fac_shield(j) &
4486           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4487
4488 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4489             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4490                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4491             *sss_ele_cut &
4492           *fac_shield(i)*fac_shield(j) &
4493           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4494
4495 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4496             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4497                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4498             +aggj1(l,4)*muij(4))&
4499             *sss_ele_cut &
4500           *fac_shield(i)*fac_shield(j) &
4501          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4502
4503 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4504           enddo
4505           ENDIF
4506 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4507 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4508           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4509              .and. num_conti.le.maxconts) then
4510 !            write (iout,*) i,j," entered corr"
4511 !
4512 ! Calculate the contact function. The ith column of the array JCONT will
4513 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4514 ! greater than I). The arrays FACONT and GACONT will contain the values of
4515 ! the contact function and its derivative.
4516 !           r0ij=1.02D0*rpp(iteli,itelj)
4517 !           r0ij=1.11D0*rpp(iteli,itelj)
4518             r0ij=2.20D0*rpp(iteli,itelj)
4519 !           r0ij=1.55D0*rpp(iteli,itelj)
4520             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4521 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4522             if (fcont.gt.0.0D0) then
4523               num_conti=num_conti+1
4524               if (num_conti.gt.maxconts) then
4525 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4526 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4527                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4528                                ' will skip next contacts for this conf.', num_conti
4529               else
4530                 jcont_hb(num_conti,i)=j
4531 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4532 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4533                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4534                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4535 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4536 !  terms.
4537                 d_cont(num_conti,i)=rij
4538 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4539 !     --- Electrostatic-interaction matrix ---
4540                 a_chuj(1,1,num_conti,i)=a22
4541                 a_chuj(1,2,num_conti,i)=a23
4542                 a_chuj(2,1,num_conti,i)=a32
4543                 a_chuj(2,2,num_conti,i)=a33
4544 !     --- Gradient of rij
4545                 do kkk=1,3
4546                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4547                 enddo
4548                 kkll=0
4549                 do k=1,2
4550                   do l=1,2
4551                     kkll=kkll+1
4552                     do m=1,3
4553                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4554                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4555                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4556                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4557                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4558                     enddo
4559                   enddo
4560                 enddo
4561                 ENDIF
4562                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4563 ! Calculate contact energies
4564                 cosa4=4.0D0*cosa
4565                 wij=cosa-3.0D0*cosb*cosg
4566                 cosbg1=cosb+cosg
4567                 cosbg2=cosb-cosg
4568 !               fac3=dsqrt(-ael6i)/r0ij**3
4569                 fac3=dsqrt(-ael6i)*r3ij
4570 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4571                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4572                 if (ees0tmp.gt.0) then
4573                   ees0pij=dsqrt(ees0tmp)
4574                 else
4575                   ees0pij=0
4576                 endif
4577                 if (shield_mode.eq.0) then
4578                 fac_shield(i)=1.0d0
4579                 fac_shield(j)=1.0d0
4580                 else
4581                 ees0plist(num_conti,i)=j
4582                 endif
4583 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4584                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4585                 if (ees0tmp.gt.0) then
4586                   ees0mij=dsqrt(ees0tmp)
4587                 else
4588                   ees0mij=0
4589                 endif
4590 !               ees0mij=0.0D0
4591                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4592                      *sss_ele_cut &
4593                      *fac_shield(i)*fac_shield(j)
4594
4595                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4596                      *sss_ele_cut &
4597                      *fac_shield(i)*fac_shield(j)
4598
4599 ! Diagnostics. Comment out or remove after debugging!
4600 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4601 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4602 !               ees0m(num_conti,i)=0.0D0
4603 ! End diagnostics.
4604 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4605 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4606 ! Angular derivatives of the contact function
4607                 ees0pij1=fac3/ees0pij
4608                 ees0mij1=fac3/ees0mij
4609                 fac3p=-3.0D0*fac3*rrmij
4610                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4611                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4612 !               ees0mij1=0.0D0
4613                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4614                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4615                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4616                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4617                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4618                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4619                 ecosap=ecosa1+ecosa2
4620                 ecosbp=ecosb1+ecosb2
4621                 ecosgp=ecosg1+ecosg2
4622                 ecosam=ecosa1-ecosa2
4623                 ecosbm=ecosb1-ecosb2
4624                 ecosgm=ecosg1-ecosg2
4625 ! Diagnostics
4626 !               ecosap=ecosa1
4627 !               ecosbp=ecosb1
4628 !               ecosgp=ecosg1
4629 !               ecosam=0.0D0
4630 !               ecosbm=0.0D0
4631 !               ecosgm=0.0D0
4632 ! End diagnostics
4633                 facont_hb(num_conti,i)=fcont
4634                 fprimcont=fprimcont/rij
4635 !d              facont_hb(num_conti,i)=1.0D0
4636 ! Following line is for diagnostics.
4637 !d              fprimcont=0.0D0
4638                 do k=1,3
4639                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4640                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4641                 enddo
4642                 do k=1,3
4643                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4644                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4645                 enddo
4646                 gggp(1)=gggp(1)+ees0pijp*xj &
4647                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4648                 gggp(2)=gggp(2)+ees0pijp*yj &
4649                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4650                 gggp(3)=gggp(3)+ees0pijp*zj &
4651                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4652
4653                 gggm(1)=gggm(1)+ees0mijp*xj &
4654                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4655
4656                 gggm(2)=gggm(2)+ees0mijp*yj &
4657                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4658
4659                 gggm(3)=gggm(3)+ees0mijp*zj &
4660                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4661
4662 ! Derivatives due to the contact function
4663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4666                 do k=1,3
4667 !
4668 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4669 !          following the change of gradient-summation algorithm.
4670 !
4671 !grad                  ghalfp=0.5D0*gggp(k)
4672 !grad                  ghalfm=0.5D0*gggm(k)
4673                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4674                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4675                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4676                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4677
4678                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4679                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4680                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4681                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4682
4683                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4684                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4685
4686                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4687                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4688                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4689                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4690
4691                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4692                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4693                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4694                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4695
4696                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4697                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4698
4699                 enddo
4700 ! Diagnostics. Comment out or remove after debugging!
4701 !diag           do k=1,3
4702 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4703 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4704 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4705 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4706 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4707 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4708 !diag           enddo
4709               ENDIF ! wcorr
4710               endif  ! num_conti.le.maxconts
4711             endif  ! fcont.gt.0
4712           endif    ! j.gt.i+1
4713           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4714             do k=1,4
4715               do l=1,3
4716                 ghalf=0.5d0*agg(l,k)
4717                 aggi(l,k)=aggi(l,k)+ghalf
4718                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4719                 aggj(l,k)=aggj(l,k)+ghalf
4720               enddo
4721             enddo
4722             if (j.eq.nres-1 .and. i.lt.j-2) then
4723               do k=1,4
4724                 do l=1,3
4725                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4726                 enddo
4727               enddo
4728             endif
4729           endif
4730  128  continue
4731 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4732       return
4733       end subroutine eelecij
4734 !-----------------------------------------------------------------------------
4735       subroutine eturn3(i,eello_turn3)
4736 ! Third- and fourth-order contributions from turns
4737
4738       use comm_locel
4739 !      implicit real*8 (a-h,o-z)
4740 !      include 'DIMENSIONS'
4741 !      include 'COMMON.IOUNITS'
4742 !      include 'COMMON.GEO'
4743 !      include 'COMMON.VAR'
4744 !      include 'COMMON.LOCAL'
4745 !      include 'COMMON.CHAIN'
4746 !      include 'COMMON.DERIV'
4747 !      include 'COMMON.INTERACT'
4748 !      include 'COMMON.CONTACTS'
4749 !      include 'COMMON.TORSION'
4750 !      include 'COMMON.VECTORS'
4751 !      include 'COMMON.FFIELD'
4752 !      include 'COMMON.CONTROL'
4753       real(kind=8),dimension(3) :: ggg
4754       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4755         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4756        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4757
4758       real(kind=8),dimension(2) :: auxvec,auxvec1
4759 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4760       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4761 !el      integer :: num_conti,j1,j2
4762 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4763 !el        dz_normi,xmedi,ymedi,zmedi
4764
4765 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4766 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4767 !el         num_conti,j1,j2
4768 !el local variables
4769       integer :: i,j,l,k,ilist,iresshield
4770       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4771
4772       j=i+2
4773 !      write (iout,*) "eturn3",i,j,j1,j2
4774           zj=(c(3,j)+c(3,j+1))/2.0d0
4775           zj=mod(zj,boxzsize)
4776           if (zj.lt.0) zj=zj+boxzsize
4777           if ((zj.lt.0)) write (*,*) "CHUJ"
4778        if ((zj.gt.bordlipbot)  &
4779         .and.(zj.lt.bordliptop)) then
4780 !C the energy transfer exist
4781         if (zj.lt.buflipbot) then
4782 !C what fraction I am in
4783          fracinbuf=1.0d0-     &
4784              ((zj-bordlipbot)/lipbufthick)
4785 !C lipbufthick is thickenes of lipid buffore
4786          sslipj=sscalelip(fracinbuf)
4787          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4788         elseif (zj.gt.bufliptop) then
4789          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4790          sslipj=sscalelip(fracinbuf)
4791          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4792         else
4793          sslipj=1.0d0
4794          ssgradlipj=0.0
4795         endif
4796        else
4797          sslipj=0.0d0
4798          ssgradlipj=0.0
4799        endif
4800
4801       a_temp(1,1)=a22
4802       a_temp(1,2)=a23
4803       a_temp(2,1)=a32
4804       a_temp(2,2)=a33
4805 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4806 !
4807 !               Third-order contributions
4808 !
4809 !                 (i+2)o----(i+3)
4810 !                      | |
4811 !                      | |
4812 !                 (i+1)o----i
4813 !
4814 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4815 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4816         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4817         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4818         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4819         call transpose2(auxmat(1,1),auxmat1(1,1))
4820         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4821         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4822         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4823         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4824         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4825
4826         if (shield_mode.eq.0) then
4827         fac_shield(i)=1.0d0
4828         fac_shield(j)=1.0d0
4829         endif
4830
4831         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4832          *fac_shield(i)*fac_shield(j)  &
4833          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4834         eello_t3= &
4835         0.5d0*(pizda(1,1)+pizda(2,2)) &
4836         *fac_shield(i)*fac_shield(j)
4837
4838         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4839                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4840 !C#ifdef NEWCORR
4841 !C Derivatives in theta
4842         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4843        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4844         *fac_shield(i)*fac_shield(j)
4845         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4846        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4847         *fac_shield(i)*fac_shield(j)
4848 !C#endif
4849
4850
4851
4852           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4853        (shield_mode.gt.0)) then
4854 !C          print *,i,j
4855
4856           do ilist=1,ishield_list(i)
4857            iresshield=shield_list(ilist,i)
4858            do k=1,3
4859            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4860            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4861                    rlocshield &
4862            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4863             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4864              +rlocshield
4865            enddo
4866           enddo
4867           do ilist=1,ishield_list(j)
4868            iresshield=shield_list(ilist,j)
4869            do k=1,3
4870            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4871            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4872                    rlocshield &
4873            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4874            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4875                   +rlocshield
4876
4877            enddo
4878           enddo
4879
4880           do k=1,3
4881             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4882                    grad_shield(k,i)*eello_t3/fac_shield(i)
4883             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4884                    grad_shield(k,j)*eello_t3/fac_shield(j)
4885             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4886                    grad_shield(k,i)*eello_t3/fac_shield(i)
4887             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4888                    grad_shield(k,j)*eello_t3/fac_shield(j)
4889            enddo
4890            endif
4891
4892 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4893 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4894 !d     &    ' eello_turn3_num',4*eello_turn3_num
4895 ! Derivatives in gamma(i)
4896         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4897         call transpose2(auxmat2(1,1),auxmat3(1,1))
4898         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4899         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4900           *fac_shield(i)*fac_shield(j)        &
4901           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4902 ! Derivatives in gamma(i+1)
4903         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4904         call transpose2(auxmat2(1,1),auxmat3(1,1))
4905         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4906         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4907           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4908           *fac_shield(i)*fac_shield(j)        &
4909           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4910
4911 ! Cartesian derivatives
4912         do l=1,3
4913 !            ghalf1=0.5d0*agg(l,1)
4914 !            ghalf2=0.5d0*agg(l,2)
4915 !            ghalf3=0.5d0*agg(l,3)
4916 !            ghalf4=0.5d0*agg(l,4)
4917           a_temp(1,1)=aggi(l,1)!+ghalf1
4918           a_temp(1,2)=aggi(l,2)!+ghalf2
4919           a_temp(2,1)=aggi(l,3)!+ghalf3
4920           a_temp(2,2)=aggi(l,4)!+ghalf4
4921           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4922           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4923             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4924           *fac_shield(i)*fac_shield(j)      &
4925           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4926
4927           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4928           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4929           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4930           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4931           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4932           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4933             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4934           *fac_shield(i)*fac_shield(j)        &
4935           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4936
4937           a_temp(1,1)=aggj(l,1)!+ghalf1
4938           a_temp(1,2)=aggj(l,2)!+ghalf2
4939           a_temp(2,1)=aggj(l,3)!+ghalf3
4940           a_temp(2,2)=aggj(l,4)!+ghalf4
4941           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4942           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4943             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4944           *fac_shield(i)*fac_shield(j)      &
4945           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4946
4947           a_temp(1,1)=aggj1(l,1)
4948           a_temp(1,2)=aggj1(l,2)
4949           a_temp(2,1)=aggj1(l,3)
4950           a_temp(2,2)=aggj1(l,4)
4951           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4952           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4953             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4954           *fac_shield(i)*fac_shield(j)        &
4955           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4956         enddo
4957          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4958           ssgradlipi*eello_t3/4.0d0*lipscale
4959          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4960           ssgradlipj*eello_t3/4.0d0*lipscale
4961          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4962           ssgradlipi*eello_t3/4.0d0*lipscale
4963          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4964           ssgradlipj*eello_t3/4.0d0*lipscale
4965
4966       return
4967       end subroutine eturn3
4968 !-----------------------------------------------------------------------------
4969       subroutine eturn4(i,eello_turn4)
4970 ! Third- and fourth-order contributions from turns
4971
4972       use comm_locel
4973 !      implicit real*8 (a-h,o-z)
4974 !      include 'DIMENSIONS'
4975 !      include 'COMMON.IOUNITS'
4976 !      include 'COMMON.GEO'
4977 !      include 'COMMON.VAR'
4978 !      include 'COMMON.LOCAL'
4979 !      include 'COMMON.CHAIN'
4980 !      include 'COMMON.DERIV'
4981 !      include 'COMMON.INTERACT'
4982 !      include 'COMMON.CONTACTS'
4983 !      include 'COMMON.TORSION'
4984 !      include 'COMMON.VECTORS'
4985 !      include 'COMMON.FFIELD'
4986 !      include 'COMMON.CONTROL'
4987       real(kind=8),dimension(3) :: ggg
4988       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4989         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4990         gte1t,gte2t,gte3t,&
4991         gte1a,gtae3,gtae3e2, ae3gte2,&
4992         gtEpizda1,gtEpizda2,gtEpizda3
4993
4994       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4995        auxgEvec3,auxgvec
4996
4997 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4998       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4999 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5000 !el        dz_normi,xmedi,ymedi,zmedi
5001 !el      integer :: num_conti,j1,j2
5002 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5003 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5004 !el          num_conti,j1,j2
5005 !el local variables
5006       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5007       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5008          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5009
5010       j=i+3
5011 !      if (j.ne.20) return
5012 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5013 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5014 !
5015 !               Fourth-order contributions
5016 !
5017 !                 (i+3)o----(i+4)
5018 !                     /  |
5019 !               (i+2)o   |
5020 !                     \  |
5021 !                 (i+1)o----i
5022 !
5023 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5024 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5025 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5026           zj=(c(3,j)+c(3,j+1))/2.0d0
5027           zj=mod(zj,boxzsize)
5028           if (zj.lt.0) zj=zj+boxzsize
5029        if ((zj.gt.bordlipbot)  &
5030         .and.(zj.lt.bordliptop)) then
5031 !C the energy transfer exist
5032         if (zj.lt.buflipbot) then
5033 !C what fraction I am in
5034          fracinbuf=1.0d0-     &
5035              ((zj-bordlipbot)/lipbufthick)
5036 !C lipbufthick is thickenes of lipid buffore
5037          sslipj=sscalelip(fracinbuf)
5038          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5039         elseif (zj.gt.bufliptop) then
5040          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5041          sslipj=sscalelip(fracinbuf)
5042          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5043         else
5044          sslipj=1.0d0
5045          ssgradlipj=0.0
5046         endif
5047        else
5048          sslipj=0.0d0
5049          ssgradlipj=0.0
5050        endif
5051
5052         a_temp(1,1)=a22
5053         a_temp(1,2)=a23
5054         a_temp(2,1)=a32
5055         a_temp(2,2)=a33
5056         iti1=itortyp(itype(i+1,1))
5057         iti2=itortyp(itype(i+2,1))
5058         iti3=itortyp(itype(i+3,1))
5059 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5060         call transpose2(EUg(1,1,i+1),e1t(1,1))
5061         call transpose2(Eug(1,1,i+2),e2t(1,1))
5062         call transpose2(Eug(1,1,i+3),e3t(1,1))
5063 !C Ematrix derivative in theta
5064         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5065         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5066         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5067
5068         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5069         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5070         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5071         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5072 !c       auxalary matrix of E i+1
5073         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5074         s1=scalar2(b1(1,iti2),auxvec(1))
5075 !c derivative of theta i+2 with constant i+3
5076         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5077 !c derivative of theta i+2 with constant i+2
5078         gs32=scalar2(b1(1,i+2),auxgvec(1))
5079 !c derivative of E matix in theta of i+1
5080         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5081
5082         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5083         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5084         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5085 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5086         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5087 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5088         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5089         s2=scalar2(b1(1,iti1),auxvec(1))
5090 !c derivative of theta i+1 with constant i+3
5091         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5092 !c derivative of theta i+2 with constant i+1
5093         gs21=scalar2(b1(1,i+1),auxgvec(1))
5094 !c derivative of theta i+3 with constant i+1
5095         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5096
5097         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5098         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5099 !c ae3gte2 is derivative over i+2
5100         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5101
5102         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5103         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5104 !c i+2
5105         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5106 !c i+3
5107         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5108
5109         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5110         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5111         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5112         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5113         if (shield_mode.eq.0) then
5114         fac_shield(i)=1.0
5115         fac_shield(j)=1.0
5116         endif
5117
5118         eello_turn4=eello_turn4-(s1+s2+s3) &
5119         *fac_shield(i)*fac_shield(j)       &
5120         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5121         eello_t4=-(s1+s2+s3)  &
5122           *fac_shield(i)*fac_shield(j)
5123 !C Now derivative over shield:
5124           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5125          (shield_mode.gt.0)) then
5126 !C          print *,i,j
5127
5128           do ilist=1,ishield_list(i)
5129            iresshield=shield_list(ilist,i)
5130            do k=1,3
5131            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5132 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5133            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5134                    rlocshield &
5135             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5136             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5137            +rlocshield
5138            enddo
5139           enddo
5140           do ilist=1,ishield_list(j)
5141            iresshield=shield_list(ilist,j)
5142            do k=1,3
5143 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5144            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5145            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5146                    rlocshield  &
5147            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5148            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5149                   +rlocshield
5150 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5151
5152            enddo
5153           enddo
5154           do k=1,3
5155             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5156                    grad_shield(k,i)*eello_t4/fac_shield(i)
5157             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5158                    grad_shield(k,j)*eello_t4/fac_shield(j)
5159             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5160                    grad_shield(k,i)*eello_t4/fac_shield(i)
5161             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5162                    grad_shield(k,j)*eello_t4/fac_shield(j)
5163 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5164            enddo
5165            endif
5166 #ifdef NEWCORR
5167         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5168                        -(gs13+gsE13+gsEE1)*wturn4&
5169        *fac_shield(i)*fac_shield(j)
5170         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5171                          -(gs23+gs21+gsEE2)*wturn4&
5172        *fac_shield(i)*fac_shield(j)
5173
5174         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5175                          -(gs32+gsE31+gsEE3)*wturn4&
5176        *fac_shield(i)*fac_shield(j)
5177
5178 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5179 !c     &   gs2
5180 #endif
5181         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5182            'eturn4',i,j,-(s1+s2+s3)
5183 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5184 !d     &    ' eello_turn4_num',8*eello_turn4_num
5185 ! Derivatives in gamma(i)
5186         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5187         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5188         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5189         s1=scalar2(b1(1,iti2),auxvec(1))
5190         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5191         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5192         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5193        *fac_shield(i)*fac_shield(j)  &
5194        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5195
5196 ! Derivatives in gamma(i+1)
5197         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5198         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5199         s2=scalar2(b1(1,iti1),auxvec(1))
5200         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5201         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5202         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5203         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5204        *fac_shield(i)*fac_shield(j)  &
5205        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5206
5207 ! Derivatives in gamma(i+2)
5208         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5209         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5210         s1=scalar2(b1(1,iti2),auxvec(1))
5211         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5212         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5213         s2=scalar2(b1(1,iti1),auxvec(1))
5214         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5215         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5216         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5217         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5218        *fac_shield(i)*fac_shield(j)  &
5219        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5220
5221 ! Cartesian derivatives
5222 ! Derivatives of this turn contributions in DC(i+2)
5223         if (j.lt.nres-1) then
5224           do l=1,3
5225             a_temp(1,1)=agg(l,1)
5226             a_temp(1,2)=agg(l,2)
5227             a_temp(2,1)=agg(l,3)
5228             a_temp(2,2)=agg(l,4)
5229             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5230             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5231             s1=scalar2(b1(1,iti2),auxvec(1))
5232             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5233             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5234             s2=scalar2(b1(1,iti1),auxvec(1))
5235             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5236             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5237             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5238             ggg(l)=-(s1+s2+s3)
5239             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5240        *fac_shield(i)*fac_shield(j)  &
5241        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5242
5243           enddo
5244         endif
5245 ! Remaining derivatives of this turn contribution
5246         do l=1,3
5247           a_temp(1,1)=aggi(l,1)
5248           a_temp(1,2)=aggi(l,2)
5249           a_temp(2,1)=aggi(l,3)
5250           a_temp(2,2)=aggi(l,4)
5251           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5252           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5253           s1=scalar2(b1(1,iti2),auxvec(1))
5254           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5255           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5256           s2=scalar2(b1(1,iti1),auxvec(1))
5257           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5258           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5259           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5260           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5261          *fac_shield(i)*fac_shield(j)  &
5262          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5263
5264
5265           a_temp(1,1)=aggi1(l,1)
5266           a_temp(1,2)=aggi1(l,2)
5267           a_temp(2,1)=aggi1(l,3)
5268           a_temp(2,2)=aggi1(l,4)
5269           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5270           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5271           s1=scalar2(b1(1,iti2),auxvec(1))
5272           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5273           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5274           s2=scalar2(b1(1,iti1),auxvec(1))
5275           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5276           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5277           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5278           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5279          *fac_shield(i)*fac_shield(j)  &
5280          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5281
5282
5283           a_temp(1,1)=aggj(l,1)
5284           a_temp(1,2)=aggj(l,2)
5285           a_temp(2,1)=aggj(l,3)
5286           a_temp(2,2)=aggj(l,4)
5287           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5288           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5289           s1=scalar2(b1(1,iti2),auxvec(1))
5290           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5291           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5292           s2=scalar2(b1(1,iti1),auxvec(1))
5293           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5294           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5295           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5296 !        if (j.lt.nres-1) then
5297           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5298          *fac_shield(i)*fac_shield(j)  &
5299          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5300 !        endif
5301
5302           a_temp(1,1)=aggj1(l,1)
5303           a_temp(1,2)=aggj1(l,2)
5304           a_temp(2,1)=aggj1(l,3)
5305           a_temp(2,2)=aggj1(l,4)
5306           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5307           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5308           s1=scalar2(b1(1,iti2),auxvec(1))
5309           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5310           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5311           s2=scalar2(b1(1,iti1),auxvec(1))
5312           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5313           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5314           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5315 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5316 !        if (j.lt.nres-1) then
5317 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5318           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5319          *fac_shield(i)*fac_shield(j)  &
5320          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5321 !            if (shield_mode.gt.0) then
5322 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5323 !            else
5324 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5325 !            endif
5326 !         endif
5327         enddo
5328          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5329           ssgradlipi*eello_t4/4.0d0*lipscale
5330          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5331           ssgradlipj*eello_t4/4.0d0*lipscale
5332          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5333           ssgradlipi*eello_t4/4.0d0*lipscale
5334          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5335           ssgradlipj*eello_t4/4.0d0*lipscale
5336
5337       return
5338       end subroutine eturn4
5339 !-----------------------------------------------------------------------------
5340       subroutine unormderiv(u,ugrad,unorm,ungrad)
5341 ! This subroutine computes the derivatives of a normalized vector u, given
5342 ! the derivatives computed without normalization conditions, ugrad. Returns
5343 ! ungrad.
5344 !      implicit none
5345       real(kind=8),dimension(3) :: u,vec
5346       real(kind=8),dimension(3,3) ::ugrad,ungrad
5347       real(kind=8) :: unorm      !,scalar
5348       integer :: i,j
5349 !      write (2,*) 'ugrad',ugrad
5350 !      write (2,*) 'u',u
5351       do i=1,3
5352         vec(i)=scalar(ugrad(1,i),u(1))
5353       enddo
5354 !      write (2,*) 'vec',vec
5355       do i=1,3
5356         do j=1,3
5357           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5358         enddo
5359       enddo
5360 !      write (2,*) 'ungrad',ungrad
5361       return
5362       end subroutine unormderiv
5363 !-----------------------------------------------------------------------------
5364       subroutine escp_soft_sphere(evdw2,evdw2_14)
5365 !
5366 ! This subroutine calculates the excluded-volume interaction energy between
5367 ! peptide-group centers and side chains and its gradient in virtual-bond and
5368 ! side-chain vectors.
5369 !
5370 !      implicit real*8 (a-h,o-z)
5371 !      include 'DIMENSIONS'
5372 !      include 'COMMON.GEO'
5373 !      include 'COMMON.VAR'
5374 !      include 'COMMON.LOCAL'
5375 !      include 'COMMON.CHAIN'
5376 !      include 'COMMON.DERIV'
5377 !      include 'COMMON.INTERACT'
5378 !      include 'COMMON.FFIELD'
5379 !      include 'COMMON.IOUNITS'
5380 !      include 'COMMON.CONTROL'
5381       real(kind=8),dimension(3) :: ggg
5382 !el local variables
5383       integer :: i,iint,j,k,iteli,itypj
5384       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5385                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5386
5387       evdw2=0.0D0
5388       evdw2_14=0.0d0
5389       r0_scp=4.5d0
5390 !d    print '(a)','Enter ESCP'
5391 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5392       do i=iatscp_s,iatscp_e
5393         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5394         iteli=itel(i)
5395         xi=0.5D0*(c(1,i)+c(1,i+1))
5396         yi=0.5D0*(c(2,i)+c(2,i+1))
5397         zi=0.5D0*(c(3,i)+c(3,i+1))
5398
5399         do iint=1,nscp_gr(i)
5400
5401         do j=iscpstart(i,iint),iscpend(i,iint)
5402           if (itype(j,1).eq.ntyp1) cycle
5403           itypj=iabs(itype(j,1))
5404 ! Uncomment following three lines for SC-p interactions
5405 !         xj=c(1,nres+j)-xi
5406 !         yj=c(2,nres+j)-yi
5407 !         zj=c(3,nres+j)-zi
5408 ! Uncomment following three lines for Ca-p interactions
5409           xj=c(1,j)-xi
5410           yj=c(2,j)-yi
5411           zj=c(3,j)-zi
5412           rij=xj*xj+yj*yj+zj*zj
5413           r0ij=r0_scp
5414           r0ijsq=r0ij*r0ij
5415           if (rij.lt.r0ijsq) then
5416             evdwij=0.25d0*(rij-r0ijsq)**2
5417             fac=rij-r0ijsq
5418           else
5419             evdwij=0.0d0
5420             fac=0.0d0
5421           endif
5422           evdw2=evdw2+evdwij
5423 !
5424 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5425 !
5426           ggg(1)=xj*fac
5427           ggg(2)=yj*fac
5428           ggg(3)=zj*fac
5429 !grad          if (j.lt.i) then
5430 !d          write (iout,*) 'j<i'
5431 ! Uncomment following three lines for SC-p interactions
5432 !           do k=1,3
5433 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5434 !           enddo
5435 !grad          else
5436 !d          write (iout,*) 'j>i'
5437 !grad            do k=1,3
5438 !grad              ggg(k)=-ggg(k)
5439 ! Uncomment following line for SC-p interactions
5440 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5441 !grad            enddo
5442 !grad          endif
5443 !grad          do k=1,3
5444 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5445 !grad          enddo
5446 !grad          kstart=min0(i+1,j)
5447 !grad          kend=max0(i-1,j-1)
5448 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5449 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5450 !grad          do k=kstart,kend
5451 !grad            do l=1,3
5452 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5453 !grad            enddo
5454 !grad          enddo
5455           do k=1,3
5456             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5457             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5458           enddo
5459         enddo
5460
5461         enddo ! iint
5462       enddo ! i
5463       return
5464       end subroutine escp_soft_sphere
5465 !-----------------------------------------------------------------------------
5466       subroutine escp(evdw2,evdw2_14)
5467 !
5468 ! This subroutine calculates the excluded-volume interaction energy between
5469 ! peptide-group centers and side chains and its gradient in virtual-bond and
5470 ! side-chain vectors.
5471 !
5472 !      implicit real*8 (a-h,o-z)
5473 !      include 'DIMENSIONS'
5474 !      include 'COMMON.GEO'
5475 !      include 'COMMON.VAR'
5476 !      include 'COMMON.LOCAL'
5477 !      include 'COMMON.CHAIN'
5478 !      include 'COMMON.DERIV'
5479 !      include 'COMMON.INTERACT'
5480 !      include 'COMMON.FFIELD'
5481 !      include 'COMMON.IOUNITS'
5482 !      include 'COMMON.CONTROL'
5483       real(kind=8),dimension(3) :: ggg
5484 !el local variables
5485       integer :: i,iint,j,k,iteli,itypj,subchap
5486       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5487                    e1,e2,evdwij,rij
5488       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5489                     dist_temp, dist_init
5490       integer xshift,yshift,zshift
5491
5492       evdw2=0.0D0
5493       evdw2_14=0.0d0
5494 !d    print '(a)','Enter ESCP'
5495 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5496       do i=iatscp_s,iatscp_e
5497         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5498         iteli=itel(i)
5499         xi=0.5D0*(c(1,i)+c(1,i+1))
5500         yi=0.5D0*(c(2,i)+c(2,i+1))
5501         zi=0.5D0*(c(3,i)+c(3,i+1))
5502           xi=mod(xi,boxxsize)
5503           if (xi.lt.0) xi=xi+boxxsize
5504           yi=mod(yi,boxysize)
5505           if (yi.lt.0) yi=yi+boxysize
5506           zi=mod(zi,boxzsize)
5507           if (zi.lt.0) zi=zi+boxzsize
5508
5509         do iint=1,nscp_gr(i)
5510
5511         do j=iscpstart(i,iint),iscpend(i,iint)
5512           itypj=iabs(itype(j,1))
5513           if (itypj.eq.ntyp1) cycle
5514 ! Uncomment following three lines for SC-p interactions
5515 !         xj=c(1,nres+j)-xi
5516 !         yj=c(2,nres+j)-yi
5517 !         zj=c(3,nres+j)-zi
5518 ! Uncomment following three lines for Ca-p interactions
5519 !          xj=c(1,j)-xi
5520 !          yj=c(2,j)-yi
5521 !          zj=c(3,j)-zi
5522           xj=c(1,j)
5523           yj=c(2,j)
5524           zj=c(3,j)
5525           xj=mod(xj,boxxsize)
5526           if (xj.lt.0) xj=xj+boxxsize
5527           yj=mod(yj,boxysize)
5528           if (yj.lt.0) yj=yj+boxysize
5529           zj=mod(zj,boxzsize)
5530           if (zj.lt.0) zj=zj+boxzsize
5531       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5532       xj_safe=xj
5533       yj_safe=yj
5534       zj_safe=zj
5535       subchap=0
5536       do xshift=-1,1
5537       do yshift=-1,1
5538       do zshift=-1,1
5539           xj=xj_safe+xshift*boxxsize
5540           yj=yj_safe+yshift*boxysize
5541           zj=zj_safe+zshift*boxzsize
5542           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5543           if(dist_temp.lt.dist_init) then
5544             dist_init=dist_temp
5545             xj_temp=xj
5546             yj_temp=yj
5547             zj_temp=zj
5548             subchap=1
5549           endif
5550        enddo
5551        enddo
5552        enddo
5553        if (subchap.eq.1) then
5554           xj=xj_temp-xi
5555           yj=yj_temp-yi
5556           zj=zj_temp-zi
5557        else
5558           xj=xj_safe-xi
5559           yj=yj_safe-yi
5560           zj=zj_safe-zi
5561        endif
5562
5563           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5564           rij=dsqrt(1.0d0/rrij)
5565             sss_ele_cut=sscale_ele(rij)
5566             sss_ele_grad=sscagrad_ele(rij)
5567 !            print *,sss_ele_cut,sss_ele_grad,&
5568 !            (rij),r_cut_ele,rlamb_ele
5569             if (sss_ele_cut.le.0.0) cycle
5570           fac=rrij**expon2
5571           e1=fac*fac*aad(itypj,iteli)
5572           e2=fac*bad(itypj,iteli)
5573           if (iabs(j-i) .le. 2) then
5574             e1=scal14*e1
5575             e2=scal14*e2
5576             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5577           endif
5578           evdwij=e1+e2
5579           evdw2=evdw2+evdwij*sss_ele_cut
5580 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5581 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5582           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5583              'evdw2',i,j,evdwij
5584 !
5585 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5586 !
5587           fac=-(evdwij+e1)*rrij*sss_ele_cut
5588           fac=fac+evdwij*sss_ele_grad/rij/expon
5589           ggg(1)=xj*fac
5590           ggg(2)=yj*fac
5591           ggg(3)=zj*fac
5592 !grad          if (j.lt.i) then
5593 !d          write (iout,*) 'j<i'
5594 ! Uncomment following three lines for SC-p interactions
5595 !           do k=1,3
5596 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5597 !           enddo
5598 !grad          else
5599 !d          write (iout,*) 'j>i'
5600 !grad            do k=1,3
5601 !grad              ggg(k)=-ggg(k)
5602 ! Uncomment following line for SC-p interactions
5603 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5604 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5605 !grad            enddo
5606 !grad          endif
5607 !grad          do k=1,3
5608 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5609 !grad          enddo
5610 !grad          kstart=min0(i+1,j)
5611 !grad          kend=max0(i-1,j-1)
5612 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5613 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5614 !grad          do k=kstart,kend
5615 !grad            do l=1,3
5616 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5617 !grad            enddo
5618 !grad          enddo
5619           do k=1,3
5620             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5621             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5622           enddo
5623         enddo
5624
5625         enddo ! iint
5626       enddo ! i
5627       do i=1,nct
5628         do j=1,3
5629           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5630           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5631           gradx_scp(j,i)=expon*gradx_scp(j,i)
5632         enddo
5633       enddo
5634 !******************************************************************************
5635 !
5636 !                              N O T E !!!
5637 !
5638 ! To save time the factor EXPON has been extracted from ALL components
5639 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5640 ! use!
5641 !
5642 !******************************************************************************
5643       return
5644       end subroutine escp
5645 !-----------------------------------------------------------------------------
5646       subroutine edis(ehpb)
5647 !
5648 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5649 !
5650 !      implicit real*8 (a-h,o-z)
5651 !      include 'DIMENSIONS'
5652 !      include 'COMMON.SBRIDGE'
5653 !      include 'COMMON.CHAIN'
5654 !      include 'COMMON.DERIV'
5655 !      include 'COMMON.VAR'
5656 !      include 'COMMON.INTERACT'
5657 !      include 'COMMON.IOUNITS'
5658       real(kind=8),dimension(3) :: ggg
5659 !el local variables
5660       integer :: i,j,ii,jj,iii,jjj,k
5661       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5662
5663       ehpb=0.0D0
5664 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5665 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5666       if (link_end.eq.0) return
5667       do i=link_start,link_end
5668 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5669 ! CA-CA distance used in regularization of structure.
5670         ii=ihpb(i)
5671         jj=jhpb(i)
5672 ! iii and jjj point to the residues for which the distance is assigned.
5673         if (ii.gt.nres) then
5674           iii=ii-nres
5675           jjj=jj-nres
5676         else
5677           iii=ii
5678           jjj=jj
5679         endif
5680 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5681 !     &    dhpb(i),dhpb1(i),forcon(i)
5682 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5683 !    distance and angle dependent SS bond potential.
5684 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5685 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5686         if (.not.dyn_ss .and. i.le.nss) then
5687 ! 15/02/13 CC dynamic SSbond - additional check
5688          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5689         iabs(itype(jjj,1)).eq.1) then
5690           call ssbond_ene(iii,jjj,eij)
5691           ehpb=ehpb+2*eij
5692 !d          write (iout,*) "eij",eij
5693          endif
5694         else if (ii.gt.nres .and. jj.gt.nres) then
5695 !c Restraints from contact prediction
5696           dd=dist(ii,jj)
5697           if (constr_dist.eq.11) then
5698             ehpb=ehpb+fordepth(i)**4.0d0 &
5699                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5700             fac=fordepth(i)**4.0d0 &
5701                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5702           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5703             ehpb,fordepth(i),dd
5704            else
5705           if (dhpb1(i).gt.0.0d0) then
5706             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5707             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5708 !c            write (iout,*) "beta nmr",
5709 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5710           else
5711             dd=dist(ii,jj)
5712             rdis=dd-dhpb(i)
5713 !C Get the force constant corresponding to this distance.
5714             waga=forcon(i)
5715 !C Calculate the contribution to energy.
5716             ehpb=ehpb+waga*rdis*rdis
5717 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5718 !C
5719 !C Evaluate gradient.
5720 !C
5721             fac=waga*rdis/dd
5722           endif
5723           endif
5724           do j=1,3
5725             ggg(j)=fac*(c(j,jj)-c(j,ii))
5726           enddo
5727           do j=1,3
5728             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5729             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5730           enddo
5731           do k=1,3
5732             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5733             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5734           enddo
5735         else
5736           dd=dist(ii,jj)
5737           if (constr_dist.eq.11) then
5738             ehpb=ehpb+fordepth(i)**4.0d0 &
5739                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5740             fac=fordepth(i)**4.0d0 &
5741                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5742           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5743          ehpb,fordepth(i),dd
5744            else
5745           if (dhpb1(i).gt.0.0d0) then
5746             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5747             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5748 !c            write (iout,*) "alph nmr",
5749 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5750           else
5751             rdis=dd-dhpb(i)
5752 !C Get the force constant corresponding to this distance.
5753             waga=forcon(i)
5754 !C Calculate the contribution to energy.
5755             ehpb=ehpb+waga*rdis*rdis
5756 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5757 !C
5758 !C Evaluate gradient.
5759 !C
5760             fac=waga*rdis/dd
5761           endif
5762           endif
5763
5764             do j=1,3
5765               ggg(j)=fac*(c(j,jj)-c(j,ii))
5766             enddo
5767 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5768 !C If this is a SC-SC distance, we need to calculate the contributions to the
5769 !C Cartesian gradient in the SC vectors (ghpbx).
5770           if (iii.lt.ii) then
5771           do j=1,3
5772             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5773             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5774           enddo
5775           endif
5776 !cgrad        do j=iii,jjj-1
5777 !cgrad          do k=1,3
5778 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5779 !cgrad          enddo
5780 !cgrad        enddo
5781           do k=1,3
5782             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5783             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5784           enddo
5785         endif
5786       enddo
5787       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5788
5789       return
5790       end subroutine edis
5791 !-----------------------------------------------------------------------------
5792       subroutine ssbond_ene(i,j,eij)
5793 !
5794 ! Calculate the distance and angle dependent SS-bond potential energy
5795 ! using a free-energy function derived based on RHF/6-31G** ab initio
5796 ! calculations of diethyl disulfide.
5797 !
5798 ! A. Liwo and U. Kozlowska, 11/24/03
5799 !
5800 !      implicit real*8 (a-h,o-z)
5801 !      include 'DIMENSIONS'
5802 !      include 'COMMON.SBRIDGE'
5803 !      include 'COMMON.CHAIN'
5804 !      include 'COMMON.DERIV'
5805 !      include 'COMMON.LOCAL'
5806 !      include 'COMMON.INTERACT'
5807 !      include 'COMMON.VAR'
5808 !      include 'COMMON.IOUNITS'
5809       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5810 !el local variables
5811       integer :: i,j,itypi,itypj,k
5812       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5813                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5814                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5815                    cosphi,ggk
5816
5817       itypi=iabs(itype(i,1))
5818       xi=c(1,nres+i)
5819       yi=c(2,nres+i)
5820       zi=c(3,nres+i)
5821       dxi=dc_norm(1,nres+i)
5822       dyi=dc_norm(2,nres+i)
5823       dzi=dc_norm(3,nres+i)
5824 !      dsci_inv=dsc_inv(itypi)
5825       dsci_inv=vbld_inv(nres+i)
5826       itypj=iabs(itype(j,1))
5827 !      dscj_inv=dsc_inv(itypj)
5828       dscj_inv=vbld_inv(nres+j)
5829       xj=c(1,nres+j)-xi
5830       yj=c(2,nres+j)-yi
5831       zj=c(3,nres+j)-zi
5832       dxj=dc_norm(1,nres+j)
5833       dyj=dc_norm(2,nres+j)
5834       dzj=dc_norm(3,nres+j)
5835       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5836       rij=dsqrt(rrij)
5837       erij(1)=xj*rij
5838       erij(2)=yj*rij
5839       erij(3)=zj*rij
5840       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5841       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5842       om12=dxi*dxj+dyi*dyj+dzi*dzj
5843       do k=1,3
5844         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5845         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5846       enddo
5847       rij=1.0d0/rij
5848       deltad=rij-d0cm
5849       deltat1=1.0d0-om1
5850       deltat2=1.0d0+om2
5851       deltat12=om2-om1+2.0d0
5852       cosphi=om12-om1*om2
5853       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5854         +akct*deltad*deltat12 &
5855         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5856 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5857 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5858 !     &  " deltat12",deltat12," eij",eij
5859       ed=2*akcm*deltad+akct*deltat12
5860       pom1=akct*deltad
5861       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5862       eom1=-2*akth*deltat1-pom1-om2*pom2
5863       eom2= 2*akth*deltat2+pom1-om1*pom2
5864       eom12=pom2
5865       do k=1,3
5866         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5867         ghpbx(k,i)=ghpbx(k,i)-ggk &
5868                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5869                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5870         ghpbx(k,j)=ghpbx(k,j)+ggk &
5871                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5872                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5873         ghpbc(k,i)=ghpbc(k,i)-ggk
5874         ghpbc(k,j)=ghpbc(k,j)+ggk
5875       enddo
5876 !
5877 ! Calculate the components of the gradient in DC and X
5878 !
5879 !grad      do k=i,j-1
5880 !grad        do l=1,3
5881 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5882 !grad        enddo
5883 !grad      enddo
5884       return
5885       end subroutine ssbond_ene
5886 !-----------------------------------------------------------------------------
5887       subroutine ebond(estr)
5888 !
5889 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5890 !
5891 !      implicit real*8 (a-h,o-z)
5892 !      include 'DIMENSIONS'
5893 !      include 'COMMON.LOCAL'
5894 !      include 'COMMON.GEO'
5895 !      include 'COMMON.INTERACT'
5896 !      include 'COMMON.DERIV'
5897 !      include 'COMMON.VAR'
5898 !      include 'COMMON.CHAIN'
5899 !      include 'COMMON.IOUNITS'
5900 !      include 'COMMON.NAMES'
5901 !      include 'COMMON.FFIELD'
5902 !      include 'COMMON.CONTROL'
5903 !      include 'COMMON.SETUP'
5904       real(kind=8),dimension(3) :: u,ud
5905 !el local variables
5906       integer :: i,j,iti,nbi,k
5907       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5908                    uprod1,uprod2
5909
5910       estr=0.0d0
5911       estr1=0.0d0
5912 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5913 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5914
5915       do i=ibondp_start,ibondp_end
5916         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5917         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5918 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5919 !C          do j=1,3
5920 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5921 !C            *dc(j,i-1)/vbld(i)
5922 !C          enddo
5923 !C          if (energy_dec) write(iout,*) &
5924 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5925         diff = vbld(i)-vbldpDUM
5926         else
5927         diff = vbld(i)-vbldp0
5928         endif
5929         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5930            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5931         estr=estr+diff*diff
5932         do j=1,3
5933           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5934         enddo
5935 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5936 !        endif
5937       enddo
5938       estr=0.5d0*AKP*estr+estr1
5939 !      print *,"estr_bb",estr,AKP
5940 !
5941 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5942 !
5943       do i=ibond_start,ibond_end
5944         iti=iabs(itype(i,1))
5945         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5946         if (iti.ne.10 .and. iti.ne.ntyp1) then
5947           nbi=nbondterm(iti)
5948           if (nbi.eq.1) then
5949             diff=vbld(i+nres)-vbldsc0(1,iti)
5950             if (energy_dec) write (iout,*) &
5951             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5952             AKSC(1,iti),AKSC(1,iti)*diff*diff
5953             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5954 !            print *,"estr_sc",estr
5955             do j=1,3
5956               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5957             enddo
5958           else
5959             do j=1,nbi
5960               diff=vbld(i+nres)-vbldsc0(j,iti)
5961               ud(j)=aksc(j,iti)*diff
5962               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5963             enddo
5964             uprod=u(1)
5965             do j=2,nbi
5966               uprod=uprod*u(j)
5967             enddo
5968             usum=0.0d0
5969             usumsqder=0.0d0
5970             do j=1,nbi
5971               uprod1=1.0d0
5972               uprod2=1.0d0
5973               do k=1,nbi
5974                 if (k.ne.j) then
5975                   uprod1=uprod1*u(k)
5976                   uprod2=uprod2*u(k)*u(k)
5977                 endif
5978               enddo
5979               usum=usum+uprod1
5980               usumsqder=usumsqder+ud(j)*uprod2
5981             enddo
5982             estr=estr+uprod/usum
5983 !            print *,"estr_sc",estr,i
5984
5985              if (energy_dec) write (iout,*) &
5986             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5987             AKSC(1,iti),uprod/usum
5988             do j=1,3
5989              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5990             enddo
5991           endif
5992         endif
5993       enddo
5994       return
5995       end subroutine ebond
5996 #ifdef CRYST_THETA
5997 !-----------------------------------------------------------------------------
5998       subroutine ebend(etheta)
5999 !
6000 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6001 ! angles gamma and its derivatives in consecutive thetas and gammas.
6002 !
6003       use comm_calcthet
6004 !      implicit real*8 (a-h,o-z)
6005 !      include 'DIMENSIONS'
6006 !      include 'COMMON.LOCAL'
6007 !      include 'COMMON.GEO'
6008 !      include 'COMMON.INTERACT'
6009 !      include 'COMMON.DERIV'
6010 !      include 'COMMON.VAR'
6011 !      include 'COMMON.CHAIN'
6012 !      include 'COMMON.IOUNITS'
6013 !      include 'COMMON.NAMES'
6014 !      include 'COMMON.FFIELD'
6015 !      include 'COMMON.CONTROL'
6016 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6017 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6018 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6019 !el      integer :: it
6020 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6021 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6022 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6023 !el local variables
6024       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6025        ichir21,ichir22
6026       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6027        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6028        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6029       real(kind=8),dimension(2) :: y,z
6030
6031       delta=0.02d0*pi
6032 !      time11=dexp(-2*time)
6033 !      time12=1.0d0
6034       etheta=0.0D0
6035 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6036       do i=ithet_start,ithet_end
6037         if (itype(i-1,1).eq.ntyp1) cycle
6038 ! Zero the energy function and its derivative at 0 or pi.
6039         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6040         it=itype(i-1,1)
6041         ichir1=isign(1,itype(i-2,1))
6042         ichir2=isign(1,itype(i,1))
6043          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6044          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6045          if (itype(i-1,1).eq.10) then
6046           itype1=isign(10,itype(i-2,1))
6047           ichir11=isign(1,itype(i-2,1))
6048           ichir12=isign(1,itype(i-2,1))
6049           itype2=isign(10,itype(i,1))
6050           ichir21=isign(1,itype(i,1))
6051           ichir22=isign(1,itype(i,1))
6052          endif
6053
6054         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6055 #ifdef OSF
6056           phii=phi(i)
6057           if (phii.ne.phii) phii=150.0
6058 #else
6059           phii=phi(i)
6060 #endif
6061           y(1)=dcos(phii)
6062           y(2)=dsin(phii)
6063         else
6064           y(1)=0.0D0
6065           y(2)=0.0D0
6066         endif
6067         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6068 #ifdef OSF
6069           phii1=phi(i+1)
6070           if (phii1.ne.phii1) phii1=150.0
6071           phii1=pinorm(phii1)
6072           z(1)=cos(phii1)
6073 #else
6074           phii1=phi(i+1)
6075           z(1)=dcos(phii1)
6076 #endif
6077           z(2)=dsin(phii1)
6078         else
6079           z(1)=0.0D0
6080           z(2)=0.0D0
6081         endif
6082 ! Calculate the "mean" value of theta from the part of the distribution
6083 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6084 ! In following comments this theta will be referred to as t_c.
6085         thet_pred_mean=0.0d0
6086         do k=1,2
6087             athetk=athet(k,it,ichir1,ichir2)
6088             bthetk=bthet(k,it,ichir1,ichir2)
6089           if (it.eq.10) then
6090              athetk=athet(k,itype1,ichir11,ichir12)
6091              bthetk=bthet(k,itype2,ichir21,ichir22)
6092           endif
6093          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6094         enddo
6095         dthett=thet_pred_mean*ssd
6096         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6097 ! Derivatives of the "mean" values in gamma1 and gamma2.
6098         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6099                +athet(2,it,ichir1,ichir2)*y(1))*ss
6100         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6101                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6102          if (it.eq.10) then
6103         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6104              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6105         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6106                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6107          endif
6108         if (theta(i).gt.pi-delta) then
6109           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6110                E_tc0)
6111           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6112           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6113           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6114               E_theta)
6115           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6116               E_tc)
6117         else if (theta(i).lt.delta) then
6118           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6119           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6120           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6121               E_theta)
6122           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6123           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6124               E_tc)
6125         else
6126           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6127               E_theta,E_tc)
6128         endif
6129         etheta=etheta+ethetai
6130         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6131             'ebend',i,ethetai
6132         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6133         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6134         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6135       enddo
6136 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6137
6138 ! Ufff.... We've done all this!!!
6139       return
6140       end subroutine ebend
6141 !-----------------------------------------------------------------------------
6142       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6143
6144       use comm_calcthet
6145 !      implicit real*8 (a-h,o-z)
6146 !      include 'DIMENSIONS'
6147 !      include 'COMMON.LOCAL'
6148 !      include 'COMMON.IOUNITS'
6149 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6150 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6151 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6152       integer :: i,j,k
6153       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6154 !el      integer :: it
6155 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6156 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6157 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6158 !el local variables
6159       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6160        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6161
6162 ! Calculate the contributions to both Gaussian lobes.
6163 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6164 ! The "polynomial part" of the "standard deviation" of this part of
6165 ! the distribution.
6166         sig=polthet(3,it)
6167         do j=2,0,-1
6168           sig=sig*thet_pred_mean+polthet(j,it)
6169         enddo
6170 ! Derivative of the "interior part" of the "standard deviation of the"
6171 ! gamma-dependent Gaussian lobe in t_c.
6172         sigtc=3*polthet(3,it)
6173         do j=2,1,-1
6174           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6175         enddo
6176         sigtc=sig*sigtc
6177 ! Set the parameters of both Gaussian lobes of the distribution.
6178 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6179         fac=sig*sig+sigc0(it)
6180         sigcsq=fac+fac
6181         sigc=1.0D0/sigcsq
6182 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6183         sigsqtc=-4.0D0*sigcsq*sigtc
6184 !       print *,i,sig,sigtc,sigsqtc
6185 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6186         sigtc=-sigtc/(fac*fac)
6187 ! Following variable is sigma(t_c)**(-2)
6188         sigcsq=sigcsq*sigcsq
6189         sig0i=sig0(it)
6190         sig0inv=1.0D0/sig0i**2
6191         delthec=thetai-thet_pred_mean
6192         delthe0=thetai-theta0i
6193         term1=-0.5D0*sigcsq*delthec*delthec
6194         term2=-0.5D0*sig0inv*delthe0*delthe0
6195 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6196 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6197 ! to the energy (this being the log of the distribution) at the end of energy
6198 ! term evaluation for this virtual-bond angle.
6199         if (term1.gt.term2) then
6200           termm=term1
6201           term2=dexp(term2-termm)
6202           term1=1.0d0
6203         else
6204           termm=term2
6205           term1=dexp(term1-termm)
6206           term2=1.0d0
6207         endif
6208 ! The ratio between the gamma-independent and gamma-dependent lobes of
6209 ! the distribution is a Gaussian function of thet_pred_mean too.
6210         diffak=gthet(2,it)-thet_pred_mean
6211         ratak=diffak/gthet(3,it)**2
6212         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6213 ! Let's differentiate it in thet_pred_mean NOW.
6214         aktc=ak*ratak
6215 ! Now put together the distribution terms to make complete distribution.
6216         termexp=term1+ak*term2
6217         termpre=sigc+ak*sig0i
6218 ! Contribution of the bending energy from this theta is just the -log of
6219 ! the sum of the contributions from the two lobes and the pre-exponential
6220 ! factor. Simple enough, isn't it?
6221         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6222 ! NOW the derivatives!!!
6223 ! 6/6/97 Take into account the deformation.
6224         E_theta=(delthec*sigcsq*term1 &
6225              +ak*delthe0*sig0inv*term2)/termexp
6226         E_tc=((sigtc+aktc*sig0i)/termpre &
6227             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6228              aktc*term2)/termexp)
6229       return
6230       end subroutine theteng
6231 #else
6232 !-----------------------------------------------------------------------------
6233       subroutine ebend(etheta)
6234 !
6235 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6236 ! angles gamma and its derivatives in consecutive thetas and gammas.
6237 ! ab initio-derived potentials from
6238 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6239 !
6240 !      implicit real*8 (a-h,o-z)
6241 !      include 'DIMENSIONS'
6242 !      include 'COMMON.LOCAL'
6243 !      include 'COMMON.GEO'
6244 !      include 'COMMON.INTERACT'
6245 !      include 'COMMON.DERIV'
6246 !      include 'COMMON.VAR'
6247 !      include 'COMMON.CHAIN'
6248 !      include 'COMMON.IOUNITS'
6249 !      include 'COMMON.NAMES'
6250 !      include 'COMMON.FFIELD'
6251 !      include 'COMMON.CONTROL'
6252       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6253       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6254       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6255       logical :: lprn=.false., lprn1=.false.
6256 !el local variables
6257       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6258       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6259       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6260 ! local variables for constrains
6261       real(kind=8) :: difi,thetiii
6262        integer itheta
6263 !      write(iout,*) "in ebend",ithet_start,ithet_end
6264       call flush(iout)
6265       etheta=0.0D0
6266       do i=ithet_start,ithet_end
6267         if (itype(i-1,1).eq.ntyp1) cycle
6268         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6269         if (iabs(itype(i+1,1)).eq.20) iblock=2
6270         if (iabs(itype(i+1,1)).ne.20) iblock=1
6271         dethetai=0.0d0
6272         dephii=0.0d0
6273         dephii1=0.0d0
6274         theti2=0.5d0*theta(i)
6275         ityp2=ithetyp((itype(i-1,1)))
6276         do k=1,nntheterm
6277           coskt(k)=dcos(k*theti2)
6278           sinkt(k)=dsin(k*theti2)
6279         enddo
6280         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6281 #ifdef OSF
6282           phii=phi(i)
6283           if (phii.ne.phii) phii=150.0
6284 #else
6285           phii=phi(i)
6286 #endif
6287           ityp1=ithetyp((itype(i-2,1)))
6288 ! propagation of chirality for glycine type
6289           do k=1,nsingle
6290             cosph1(k)=dcos(k*phii)
6291             sinph1(k)=dsin(k*phii)
6292           enddo
6293         else
6294           phii=0.0d0
6295           ityp1=ithetyp(itype(i-2,1))
6296           do k=1,nsingle
6297             cosph1(k)=0.0d0
6298             sinph1(k)=0.0d0
6299           enddo
6300         endif
6301         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6302 #ifdef OSF
6303           phii1=phi(i+1)
6304           if (phii1.ne.phii1) phii1=150.0
6305           phii1=pinorm(phii1)
6306 #else
6307           phii1=phi(i+1)
6308 #endif
6309           ityp3=ithetyp((itype(i,1)))
6310           do k=1,nsingle
6311             cosph2(k)=dcos(k*phii1)
6312             sinph2(k)=dsin(k*phii1)
6313           enddo
6314         else
6315           phii1=0.0d0
6316           ityp3=ithetyp(itype(i,1))
6317           do k=1,nsingle
6318             cosph2(k)=0.0d0
6319             sinph2(k)=0.0d0
6320           enddo
6321         endif
6322         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6323         do k=1,ndouble
6324           do l=1,k-1
6325             ccl=cosph1(l)*cosph2(k-l)
6326             ssl=sinph1(l)*sinph2(k-l)
6327             scl=sinph1(l)*cosph2(k-l)
6328             csl=cosph1(l)*sinph2(k-l)
6329             cosph1ph2(l,k)=ccl-ssl
6330             cosph1ph2(k,l)=ccl+ssl
6331             sinph1ph2(l,k)=scl+csl
6332             sinph1ph2(k,l)=scl-csl
6333           enddo
6334         enddo
6335         if (lprn) then
6336         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6337           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6338         write (iout,*) "coskt and sinkt"
6339         do k=1,nntheterm
6340           write (iout,*) k,coskt(k),sinkt(k)
6341         enddo
6342         endif
6343         do k=1,ntheterm
6344           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6345           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6346             *coskt(k)
6347           if (lprn) &
6348           write (iout,*) "k",k,&
6349            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6350            " ethetai",ethetai
6351         enddo
6352         if (lprn) then
6353         write (iout,*) "cosph and sinph"
6354         do k=1,nsingle
6355           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6356         enddo
6357         write (iout,*) "cosph1ph2 and sinph2ph2"
6358         do k=2,ndouble
6359           do l=1,k-1
6360             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6361                sinph1ph2(l,k),sinph1ph2(k,l)
6362           enddo
6363         enddo
6364         write(iout,*) "ethetai",ethetai
6365         endif
6366         do m=1,ntheterm2
6367           do k=1,nsingle
6368             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6369                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6370                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6371                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6372             ethetai=ethetai+sinkt(m)*aux
6373             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6374             dephii=dephii+k*sinkt(m)* &
6375                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6376                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6377             dephii1=dephii1+k*sinkt(m)* &
6378                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6379                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6380             if (lprn) &
6381             write (iout,*) "m",m," k",k," bbthet", &
6382                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6383                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6384                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6385                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6386           enddo
6387         enddo
6388         if (lprn) &
6389         write(iout,*) "ethetai",ethetai
6390         do m=1,ntheterm3
6391           do k=2,ndouble
6392             do l=1,k-1
6393               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6394                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6395                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6396                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6397               ethetai=ethetai+sinkt(m)*aux
6398               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6399               dephii=dephii+l*sinkt(m)* &
6400                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6401                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6402                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6403                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6404               dephii1=dephii1+(k-l)*sinkt(m)* &
6405                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6406                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6407                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6408                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6409               if (lprn) then
6410               write (iout,*) "m",m," k",k," l",l," ffthet",&
6411                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6412                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6413                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6414                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6415                   " ethetai",ethetai
6416               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6417                   cosph1ph2(k,l)*sinkt(m),&
6418                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6419               endif
6420             enddo
6421           enddo
6422         enddo
6423 10      continue
6424 !        lprn1=.true.
6425         if (lprn1) &
6426           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6427          i,theta(i)*rad2deg,phii*rad2deg,&
6428          phii1*rad2deg,ethetai
6429 !        lprn1=.false.
6430         etheta=etheta+ethetai
6431         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6432                                     'ebend',i,ethetai
6433         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6434         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6435         gloc(nphi+i-2,icg)=wang*dethetai
6436       enddo
6437 !-----------thete constrains
6438 !      if (tor_mode.ne.2) then
6439
6440       return
6441       end subroutine ebend
6442 #endif
6443 #ifdef CRYST_SC
6444 !-----------------------------------------------------------------------------
6445       subroutine esc(escloc)
6446 ! Calculate the local energy of a side chain and its derivatives in the
6447 ! corresponding virtual-bond valence angles THETA and the spherical angles
6448 ! ALPHA and OMEGA.
6449 !
6450       use comm_sccalc
6451 !      implicit real*8 (a-h,o-z)
6452 !      include 'DIMENSIONS'
6453 !      include 'COMMON.GEO'
6454 !      include 'COMMON.LOCAL'
6455 !      include 'COMMON.VAR'
6456 !      include 'COMMON.INTERACT'
6457 !      include 'COMMON.DERIV'
6458 !      include 'COMMON.CHAIN'
6459 !      include 'COMMON.IOUNITS'
6460 !      include 'COMMON.NAMES'
6461 !      include 'COMMON.FFIELD'
6462 !      include 'COMMON.CONTROL'
6463       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6464          ddersc0,ddummy,xtemp,temp
6465 !el      real(kind=8) :: time11,time12,time112,theti
6466       real(kind=8) :: escloc,delta
6467 !el      integer :: it,nlobit
6468 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6469 !el local variables
6470       integer :: i,k
6471       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6472        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6473       delta=0.02d0*pi
6474       escloc=0.0D0
6475 !     write (iout,'(a)') 'ESC'
6476       do i=loc_start,loc_end
6477         it=itype(i,1)
6478         if (it.eq.ntyp1) cycle
6479         if (it.eq.10) goto 1
6480         nlobit=nlob(iabs(it))
6481 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6482 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6483         theti=theta(i+1)-pipol
6484         x(1)=dtan(theti)
6485         x(2)=alph(i)
6486         x(3)=omeg(i)
6487
6488         if (x(2).gt.pi-delta) then
6489           xtemp(1)=x(1)
6490           xtemp(2)=pi-delta
6491           xtemp(3)=x(3)
6492           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6493           xtemp(2)=pi
6494           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6495           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6496               escloci,dersc(2))
6497           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6498               ddersc0(1),dersc(1))
6499           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6500               ddersc0(3),dersc(3))
6501           xtemp(2)=pi-delta
6502           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6503           xtemp(2)=pi
6504           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6505           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6506                   dersc0(2),esclocbi,dersc02)
6507           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6508                   dersc12,dersc01)
6509           call splinthet(x(2),0.5d0*delta,ss,ssd)
6510           dersc0(1)=dersc01
6511           dersc0(2)=dersc02
6512           dersc0(3)=0.0d0
6513           do k=1,3
6514             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6515           enddo
6516           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6517 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6518 !    &             esclocbi,ss,ssd
6519           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6520 !         escloci=esclocbi
6521 !         write (iout,*) escloci
6522         else if (x(2).lt.delta) then
6523           xtemp(1)=x(1)
6524           xtemp(2)=delta
6525           xtemp(3)=x(3)
6526           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6527           xtemp(2)=0.0d0
6528           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6529           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6530               escloci,dersc(2))
6531           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6532               ddersc0(1),dersc(1))
6533           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6534               ddersc0(3),dersc(3))
6535           xtemp(2)=delta
6536           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6537           xtemp(2)=0.0d0
6538           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6539           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6540                   dersc0(2),esclocbi,dersc02)
6541           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6542                   dersc12,dersc01)
6543           dersc0(1)=dersc01
6544           dersc0(2)=dersc02
6545           dersc0(3)=0.0d0
6546           call splinthet(x(2),0.5d0*delta,ss,ssd)
6547           do k=1,3
6548             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6549           enddo
6550           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6551 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6552 !    &             esclocbi,ss,ssd
6553           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6554 !         write (iout,*) escloci
6555         else
6556           call enesc(x,escloci,dersc,ddummy,.false.)
6557         endif
6558
6559         escloc=escloc+escloci
6560         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6561            'escloc',i,escloci
6562 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6563
6564         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6565          wscloc*dersc(1)
6566         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6567         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6568     1   continue
6569       enddo
6570       return
6571       end subroutine esc
6572 !-----------------------------------------------------------------------------
6573       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6574
6575       use comm_sccalc
6576 !      implicit real*8 (a-h,o-z)
6577 !      include 'DIMENSIONS'
6578 !      include 'COMMON.GEO'
6579 !      include 'COMMON.LOCAL'
6580 !      include 'COMMON.IOUNITS'
6581 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6582       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6583       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6584       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6585       real(kind=8) :: escloci
6586       logical :: mixed
6587 !el local variables
6588       integer :: j,iii,l,k !el,it,nlobit
6589       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6590 !el       time11,time12,time112
6591 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6592         escloc_i=0.0D0
6593         do j=1,3
6594           dersc(j)=0.0D0
6595           if (mixed) ddersc(j)=0.0d0
6596         enddo
6597         x3=x(3)
6598
6599 ! Because of periodicity of the dependence of the SC energy in omega we have
6600 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6601 ! To avoid underflows, first compute & store the exponents.
6602
6603         do iii=-1,1
6604
6605           x(3)=x3+iii*dwapi
6606
6607           do j=1,nlobit
6608             do k=1,3
6609               z(k)=x(k)-censc(k,j,it)
6610             enddo
6611             do k=1,3
6612               Axk=0.0D0
6613               do l=1,3
6614                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6615               enddo
6616               Ax(k,j,iii)=Axk
6617             enddo
6618             expfac=0.0D0
6619             do k=1,3
6620               expfac=expfac+Ax(k,j,iii)*z(k)
6621             enddo
6622             contr(j,iii)=expfac
6623           enddo ! j
6624
6625         enddo ! iii
6626
6627         x(3)=x3
6628 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6629 ! subsequent NaNs and INFs in energy calculation.
6630 ! Find the largest exponent
6631         emin=contr(1,-1)
6632         do iii=-1,1
6633           do j=1,nlobit
6634             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6635           enddo
6636         enddo
6637         emin=0.5D0*emin
6638 !d      print *,'it=',it,' emin=',emin
6639
6640 ! Compute the contribution to SC energy and derivatives
6641         do iii=-1,1
6642
6643           do j=1,nlobit
6644 #ifdef OSF
6645             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6646             if(adexp.ne.adexp) adexp=1.0
6647             expfac=dexp(adexp)
6648 #else
6649             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6650 #endif
6651 !d          print *,'j=',j,' expfac=',expfac
6652             escloc_i=escloc_i+expfac
6653             do k=1,3
6654               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6655             enddo
6656             if (mixed) then
6657               do k=1,3,2
6658                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6659                   +gaussc(k,2,j,it))*expfac
6660               enddo
6661             endif
6662           enddo
6663
6664         enddo ! iii
6665
6666         dersc(1)=dersc(1)/cos(theti)**2
6667         ddersc(1)=ddersc(1)/cos(theti)**2
6668         ddersc(3)=ddersc(3)
6669
6670         escloci=-(dlog(escloc_i)-emin)
6671         do j=1,3
6672           dersc(j)=dersc(j)/escloc_i
6673         enddo
6674         if (mixed) then
6675           do j=1,3,2
6676             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6677           enddo
6678         endif
6679       return
6680       end subroutine enesc
6681 !-----------------------------------------------------------------------------
6682       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6683
6684       use comm_sccalc
6685 !      implicit real*8 (a-h,o-z)
6686 !      include 'DIMENSIONS'
6687 !      include 'COMMON.GEO'
6688 !      include 'COMMON.LOCAL'
6689 !      include 'COMMON.IOUNITS'
6690 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6691       real(kind=8),dimension(3) :: x,z,dersc
6692       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6693       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6694       real(kind=8) :: escloci,dersc12,emin
6695       logical :: mixed
6696 !el local varables
6697       integer :: j,k,l !el,it,nlobit
6698       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6699
6700       escloc_i=0.0D0
6701
6702       do j=1,3
6703         dersc(j)=0.0D0
6704       enddo
6705
6706       do j=1,nlobit
6707         do k=1,2
6708           z(k)=x(k)-censc(k,j,it)
6709         enddo
6710         z(3)=dwapi
6711         do k=1,3
6712           Axk=0.0D0
6713           do l=1,3
6714             Axk=Axk+gaussc(l,k,j,it)*z(l)
6715           enddo
6716           Ax(k,j)=Axk
6717         enddo
6718         expfac=0.0D0
6719         do k=1,3
6720           expfac=expfac+Ax(k,j)*z(k)
6721         enddo
6722         contr(j)=expfac
6723       enddo ! j
6724
6725 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6726 ! subsequent NaNs and INFs in energy calculation.
6727 ! Find the largest exponent
6728       emin=contr(1)
6729       do j=1,nlobit
6730         if (emin.gt.contr(j)) emin=contr(j)
6731       enddo
6732       emin=0.5D0*emin
6733
6734 ! Compute the contribution to SC energy and derivatives
6735
6736       dersc12=0.0d0
6737       do j=1,nlobit
6738         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6739         escloc_i=escloc_i+expfac
6740         do k=1,2
6741           dersc(k)=dersc(k)+Ax(k,j)*expfac
6742         enddo
6743         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6744                   +gaussc(1,2,j,it))*expfac
6745         dersc(3)=0.0d0
6746       enddo
6747
6748       dersc(1)=dersc(1)/cos(theti)**2
6749       dersc12=dersc12/cos(theti)**2
6750       escloci=-(dlog(escloc_i)-emin)
6751       do j=1,2
6752         dersc(j)=dersc(j)/escloc_i
6753       enddo
6754       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6755       return
6756       end subroutine enesc_bound
6757 #else
6758 !-----------------------------------------------------------------------------
6759       subroutine esc(escloc)
6760 ! Calculate the local energy of a side chain and its derivatives in the
6761 ! corresponding virtual-bond valence angles THETA and the spherical angles
6762 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6763 ! added by Urszula Kozlowska. 07/11/2007
6764 !
6765       use comm_sccalc
6766 !      implicit real*8 (a-h,o-z)
6767 !      include 'DIMENSIONS'
6768 !      include 'COMMON.GEO'
6769 !      include 'COMMON.LOCAL'
6770 !      include 'COMMON.VAR'
6771 !      include 'COMMON.SCROT'
6772 !      include 'COMMON.INTERACT'
6773 !      include 'COMMON.DERIV'
6774 !      include 'COMMON.CHAIN'
6775 !      include 'COMMON.IOUNITS'
6776 !      include 'COMMON.NAMES'
6777 !      include 'COMMON.FFIELD'
6778 !      include 'COMMON.CONTROL'
6779 !      include 'COMMON.VECTORS'
6780       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6781       real(kind=8),dimension(65) :: x
6782       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6783          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6784       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6785       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6786          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6787 !el local variables
6788       integer :: i,j,k !el,it,nlobit
6789       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6790 !el      real(kind=8) :: time11,time12,time112,theti
6791 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6792       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6793                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6794                    sumene1x,sumene2x,sumene3x,sumene4x,&
6795                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6796                    cosfac2xx,sinfac2yy
6797 #ifdef DEBUG
6798       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6799                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6800                    de_dt_num
6801 #endif
6802 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6803
6804       delta=0.02d0*pi
6805       escloc=0.0D0
6806       do i=loc_start,loc_end
6807         if (itype(i,1).eq.ntyp1) cycle
6808         costtab(i+1) =dcos(theta(i+1))
6809         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6810         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6811         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6812         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6813         cosfac=dsqrt(cosfac2)
6814         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6815         sinfac=dsqrt(sinfac2)
6816         it=iabs(itype(i,1))
6817         if (it.eq.10) goto 1
6818 !
6819 !  Compute the axes of tghe local cartesian coordinates system; store in
6820 !   x_prime, y_prime and z_prime
6821 !
6822         do j=1,3
6823           x_prime(j) = 0.00
6824           y_prime(j) = 0.00
6825           z_prime(j) = 0.00
6826         enddo
6827 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6828 !     &   dc_norm(3,i+nres)
6829         do j = 1,3
6830           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6831           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6832         enddo
6833         do j = 1,3
6834           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6835         enddo
6836 !       write (2,*) "i",i
6837 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6838 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6839 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6840 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6841 !      & " xy",scalar(x_prime(1),y_prime(1)),
6842 !      & " xz",scalar(x_prime(1),z_prime(1)),
6843 !      & " yy",scalar(y_prime(1),y_prime(1)),
6844 !      & " yz",scalar(y_prime(1),z_prime(1)),
6845 !      & " zz",scalar(z_prime(1),z_prime(1))
6846 !
6847 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6848 ! to local coordinate system. Store in xx, yy, zz.
6849 !
6850         xx=0.0d0
6851         yy=0.0d0
6852         zz=0.0d0
6853         do j = 1,3
6854           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6855           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6856           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6857         enddo
6858
6859         xxtab(i)=xx
6860         yytab(i)=yy
6861         zztab(i)=zz
6862 !
6863 ! Compute the energy of the ith side cbain
6864 !
6865 !        write (2,*) "xx",xx," yy",yy," zz",zz
6866         it=iabs(itype(i,1))
6867         do j = 1,65
6868           x(j) = sc_parmin(j,it)
6869         enddo
6870 #ifdef CHECK_COORD
6871 !c diagnostics - remove later
6872         xx1 = dcos(alph(2))
6873         yy1 = dsin(alph(2))*dcos(omeg(2))
6874         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6875         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6876           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6877           xx1,yy1,zz1
6878 !,"  --- ", xx_w,yy_w,zz_w
6879 ! end diagnostics
6880 #endif
6881         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6882          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6883          + x(10)*yy*zz
6884         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6885          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6886          + x(20)*yy*zz
6887         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6888          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6889          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6890          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6891          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6892          +x(40)*xx*yy*zz
6893         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6894          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6895          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6896          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6897          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6898          +x(60)*xx*yy*zz
6899         dsc_i   = 0.743d0+x(61)
6900         dp2_i   = 1.9d0+x(62)
6901         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6902                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6903         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6904                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6905         s1=(1+x(63))/(0.1d0 + dscp1)
6906         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6907         s2=(1+x(65))/(0.1d0 + dscp2)
6908         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6909         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6910       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6911 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6912 !     &   sumene4,
6913 !     &   dscp1,dscp2,sumene
6914 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6915         escloc = escloc + sumene
6916 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6917 !     & ,zz,xx,yy
6918 !#define DEBUG
6919 #ifdef DEBUG
6920 !
6921 ! This section to check the numerical derivatives of the energy of ith side
6922 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6923 ! #define DEBUG in the code to turn it on.
6924 !
6925         write (2,*) "sumene               =",sumene
6926         aincr=1.0d-7
6927         xxsave=xx
6928         xx=xx+aincr
6929         write (2,*) xx,yy,zz
6930         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6931         de_dxx_num=(sumenep-sumene)/aincr
6932         xx=xxsave
6933         write (2,*) "xx+ sumene from enesc=",sumenep
6934         yysave=yy
6935         yy=yy+aincr
6936         write (2,*) xx,yy,zz
6937         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6938         de_dyy_num=(sumenep-sumene)/aincr
6939         yy=yysave
6940         write (2,*) "yy+ sumene from enesc=",sumenep
6941         zzsave=zz
6942         zz=zz+aincr
6943         write (2,*) xx,yy,zz
6944         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6945         de_dzz_num=(sumenep-sumene)/aincr
6946         zz=zzsave
6947         write (2,*) "zz+ sumene from enesc=",sumenep
6948         costsave=cost2tab(i+1)
6949         sintsave=sint2tab(i+1)
6950         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6951         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6952         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6953         de_dt_num=(sumenep-sumene)/aincr
6954         write (2,*) " t+ sumene from enesc=",sumenep
6955         cost2tab(i+1)=costsave
6956         sint2tab(i+1)=sintsave
6957 ! End of diagnostics section.
6958 #endif
6959 !
6960 ! Compute the gradient of esc
6961 !
6962 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6963         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6964         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6965         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6966         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6967         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6968         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6969         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6970         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6971         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6972            *(pom_s1/dscp1+pom_s16*dscp1**4)
6973         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6974            *(pom_s2/dscp2+pom_s26*dscp2**4)
6975         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6976         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6977         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6978         +x(40)*yy*zz
6979         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6980         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6981         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6982         +x(60)*yy*zz
6983         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6984               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6985               +(pom1+pom2)*pom_dx
6986 #ifdef DEBUG
6987         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6988 #endif
6989 !
6990         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6991         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6992         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6993         +x(40)*xx*zz
6994         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6995         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6996         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6997         +x(59)*zz**2 +x(60)*xx*zz
6998         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6999               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7000               +(pom1-pom2)*pom_dy
7001 #ifdef DEBUG
7002         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7003 #endif
7004 !
7005         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7006         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7007         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7008         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7009         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7010         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7011         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7012         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7013 #ifdef DEBUG
7014         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7015 #endif
7016 !
7017         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7018         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7019         +pom1*pom_dt1+pom2*pom_dt2
7020 #ifdef DEBUG
7021         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7022 #endif
7023 !
7024 !
7025        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7026        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7027        cosfac2xx=cosfac2*xx
7028        sinfac2yy=sinfac2*yy
7029        do k = 1,3
7030          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7031             vbld_inv(i+1)
7032          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7033             vbld_inv(i)
7034          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7035          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7036 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7037 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7038 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7039 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7040          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7041          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7042          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7043          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7044          dZZ_Ci1(k)=0.0d0
7045          dZZ_Ci(k)=0.0d0
7046          do j=1,3
7047            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7048            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7049            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7050            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7051          enddo
7052
7053          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7054          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7055          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7056          (z_prime(k)-zz*dC_norm(k,i+nres))
7057 !
7058          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7059          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7060        enddo
7061
7062        do k=1,3
7063          dXX_Ctab(k,i)=dXX_Ci(k)
7064          dXX_C1tab(k,i)=dXX_Ci1(k)
7065          dYY_Ctab(k,i)=dYY_Ci(k)
7066          dYY_C1tab(k,i)=dYY_Ci1(k)
7067          dZZ_Ctab(k,i)=dZZ_Ci(k)
7068          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7069          dXX_XYZtab(k,i)=dXX_XYZ(k)
7070          dYY_XYZtab(k,i)=dYY_XYZ(k)
7071          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7072        enddo
7073
7074        do k = 1,3
7075 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7076 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7077 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7078 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7079 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7080 !     &    dt_dci(k)
7081 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7082 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7083          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7084           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7085          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7086           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7087          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7088           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7089        enddo
7090 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7091 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7092
7093 ! to check gradient call subroutine check_grad
7094
7095     1 continue
7096       enddo
7097       return
7098       end subroutine esc
7099 !-----------------------------------------------------------------------------
7100       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7101 !      implicit none
7102       real(kind=8),dimension(65) :: x
7103       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7104         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7105
7106       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7107         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7108         + x(10)*yy*zz
7109       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7110         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7111         + x(20)*yy*zz
7112       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7113         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7114         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7115         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7116         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7117         +x(40)*xx*yy*zz
7118       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7119         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7120         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7121         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7122         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7123         +x(60)*xx*yy*zz
7124       dsc_i   = 0.743d0+x(61)
7125       dp2_i   = 1.9d0+x(62)
7126       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7127                 *(xx*cost2+yy*sint2))
7128       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7129                 *(xx*cost2-yy*sint2))
7130       s1=(1+x(63))/(0.1d0 + dscp1)
7131       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7132       s2=(1+x(65))/(0.1d0 + dscp2)
7133       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7134       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7135        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7136       enesc=sumene
7137       return
7138       end function enesc
7139 #endif
7140 !-----------------------------------------------------------------------------
7141       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7142 !
7143 ! This procedure calculates two-body contact function g(rij) and its derivative:
7144 !
7145 !           eps0ij                                     !       x < -1
7146 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7147 !            0                                         !       x > 1
7148 !
7149 ! where x=(rij-r0ij)/delta
7150 !
7151 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7152 !
7153 !      implicit none
7154       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7155       real(kind=8) :: x,x2,x4,delta
7156 !     delta=0.02D0*r0ij
7157 !      delta=0.2D0*r0ij
7158       x=(rij-r0ij)/delta
7159       if (x.lt.-1.0D0) then
7160         fcont=eps0ij
7161         fprimcont=0.0D0
7162       else if (x.le.1.0D0) then
7163         x2=x*x
7164         x4=x2*x2
7165         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7166         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7167       else
7168         fcont=0.0D0
7169         fprimcont=0.0D0
7170       endif
7171       return
7172       end subroutine gcont
7173 !-----------------------------------------------------------------------------
7174       subroutine splinthet(theti,delta,ss,ssder)
7175 !      implicit real*8 (a-h,o-z)
7176 !      include 'DIMENSIONS'
7177 !      include 'COMMON.VAR'
7178 !      include 'COMMON.GEO'
7179       real(kind=8) :: theti,delta,ss,ssder
7180       real(kind=8) :: thetup,thetlow
7181       thetup=pi-delta
7182       thetlow=delta
7183       if (theti.gt.pipol) then
7184         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7185       else
7186         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7187         ssder=-ssder
7188       endif
7189       return
7190       end subroutine splinthet
7191 !-----------------------------------------------------------------------------
7192       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7193 !      implicit none
7194       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7195       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7196       a1=fprim0*delta/(f1-f0)
7197       a2=3.0d0-2.0d0*a1
7198       a3=a1-2.0d0
7199       ksi=(x-x0)/delta
7200       ksi2=ksi*ksi
7201       ksi3=ksi2*ksi
7202       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7203       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7204       return
7205       end subroutine spline1
7206 !-----------------------------------------------------------------------------
7207       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7208 !      implicit none
7209       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7210       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7211       ksi=(x-x0)/delta
7212       ksi2=ksi*ksi
7213       ksi3=ksi2*ksi
7214       a1=fprim0x*delta
7215       a2=3*(f1x-f0x)-2*fprim0x*delta
7216       a3=fprim0x*delta-2*(f1x-f0x)
7217       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7218       return
7219       end subroutine spline2
7220 !-----------------------------------------------------------------------------
7221 #ifdef CRYST_TOR
7222 !-----------------------------------------------------------------------------
7223       subroutine etor(etors,edihcnstr)
7224 !      implicit real*8 (a-h,o-z)
7225 !      include 'DIMENSIONS'
7226 !      include 'COMMON.VAR'
7227 !      include 'COMMON.GEO'
7228 !      include 'COMMON.LOCAL'
7229 !      include 'COMMON.TORSION'
7230 !      include 'COMMON.INTERACT'
7231 !      include 'COMMON.DERIV'
7232 !      include 'COMMON.CHAIN'
7233 !      include 'COMMON.NAMES'
7234 !      include 'COMMON.IOUNITS'
7235 !      include 'COMMON.FFIELD'
7236 !      include 'COMMON.TORCNSTR'
7237 !      include 'COMMON.CONTROL'
7238       real(kind=8) :: etors,edihcnstr
7239       logical :: lprn
7240 !el local variables
7241       integer :: i,j,
7242       real(kind=8) :: phii,fac,etors_ii
7243
7244 ! Set lprn=.true. for debugging
7245       lprn=.false.
7246 !      lprn=.true.
7247       etors=0.0D0
7248       do i=iphi_start,iphi_end
7249       etors_ii=0.0D0
7250         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7251             .or. itype(i,1).eq.ntyp1) cycle
7252         itori=itortyp(itype(i-2,1))
7253         itori1=itortyp(itype(i-1,1))
7254         phii=phi(i)
7255         gloci=0.0D0
7256 ! Proline-Proline pair is a special case...
7257         if (itori.eq.3 .and. itori1.eq.3) then
7258           if (phii.gt.-dwapi3) then
7259             cosphi=dcos(3*phii)
7260             fac=1.0D0/(1.0D0-cosphi)
7261             etorsi=v1(1,3,3)*fac
7262             etorsi=etorsi+etorsi
7263             etors=etors+etorsi-v1(1,3,3)
7264             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7265             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7266           endif
7267           do j=1,3
7268             v1ij=v1(j+1,itori,itori1)
7269             v2ij=v2(j+1,itori,itori1)
7270             cosphi=dcos(j*phii)
7271             sinphi=dsin(j*phii)
7272             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7273             if (energy_dec) etors_ii=etors_ii+ &
7274                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7275             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7276           enddo
7277         else
7278           do j=1,nterm_old
7279             v1ij=v1(j,itori,itori1)
7280             v2ij=v2(j,itori,itori1)
7281             cosphi=dcos(j*phii)
7282             sinphi=dsin(j*phii)
7283             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7284             if (energy_dec) etors_ii=etors_ii+ &
7285                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7286             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7287           enddo
7288         endif
7289         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7290              'etor',i,etors_ii
7291         if (lprn) &
7292         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7293         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7294         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7295         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7296 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7297       enddo
7298 ! 6/20/98 - dihedral angle constraints
7299       edihcnstr=0.0d0
7300       do i=1,ndih_constr
7301         itori=idih_constr(i)
7302         phii=phi(itori)
7303         difi=phii-phi0(i)
7304         if (difi.gt.drange(i)) then
7305           difi=difi-drange(i)
7306           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7307           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7308         else if (difi.lt.-drange(i)) then
7309           difi=difi+drange(i)
7310           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7311           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7312         endif
7313 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7314 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7315       enddo
7316 !      write (iout,*) 'edihcnstr',edihcnstr
7317       return
7318       end subroutine etor
7319 !-----------------------------------------------------------------------------
7320       subroutine etor_d(etors_d)
7321       real(kind=8) :: etors_d
7322       etors_d=0.0d0
7323       return
7324       end subroutine etor_d
7325 #else
7326 !-----------------------------------------------------------------------------
7327       subroutine etor(etors)
7328 !      implicit real*8 (a-h,o-z)
7329 !      include 'DIMENSIONS'
7330 !      include 'COMMON.VAR'
7331 !      include 'COMMON.GEO'
7332 !      include 'COMMON.LOCAL'
7333 !      include 'COMMON.TORSION'
7334 !      include 'COMMON.INTERACT'
7335 !      include 'COMMON.DERIV'
7336 !      include 'COMMON.CHAIN'
7337 !      include 'COMMON.NAMES'
7338 !      include 'COMMON.IOUNITS'
7339 !      include 'COMMON.FFIELD'
7340 !      include 'COMMON.TORCNSTR'
7341 !      include 'COMMON.CONTROL'
7342       real(kind=8) :: etors,edihcnstr
7343       logical :: lprn
7344 !el local variables
7345       integer :: i,j,iblock,itori,itori1
7346       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7347                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7348 ! Set lprn=.true. for debugging
7349       lprn=.false.
7350 !     lprn=.true.
7351       etors=0.0D0
7352       do i=iphi_start,iphi_end
7353         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7354              .or. itype(i-3,1).eq.ntyp1 &
7355              .or. itype(i,1).eq.ntyp1) cycle
7356         etors_ii=0.0D0
7357          if (iabs(itype(i,1)).eq.20) then
7358          iblock=2
7359          else
7360          iblock=1
7361          endif
7362         itori=itortyp(itype(i-2,1))
7363         itori1=itortyp(itype(i-1,1))
7364         phii=phi(i)
7365         gloci=0.0D0
7366 ! Regular cosine and sine terms
7367         do j=1,nterm(itori,itori1,iblock)
7368           v1ij=v1(j,itori,itori1,iblock)
7369           v2ij=v2(j,itori,itori1,iblock)
7370           cosphi=dcos(j*phii)
7371           sinphi=dsin(j*phii)
7372           etors=etors+v1ij*cosphi+v2ij*sinphi
7373           if (energy_dec) etors_ii=etors_ii+ &
7374                      v1ij*cosphi+v2ij*sinphi
7375           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7376         enddo
7377 ! Lorentz terms
7378 !                         v1
7379 !  E = SUM ----------------------------------- - v1
7380 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7381 !
7382         cosphi=dcos(0.5d0*phii)
7383         sinphi=dsin(0.5d0*phii)
7384         do j=1,nlor(itori,itori1,iblock)
7385           vl1ij=vlor1(j,itori,itori1)
7386           vl2ij=vlor2(j,itori,itori1)
7387           vl3ij=vlor3(j,itori,itori1)
7388           pom=vl2ij*cosphi+vl3ij*sinphi
7389           pom1=1.0d0/(pom*pom+1.0d0)
7390           etors=etors+vl1ij*pom1
7391           if (energy_dec) etors_ii=etors_ii+ &
7392                      vl1ij*pom1
7393           pom=-pom*pom1*pom1
7394           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7395         enddo
7396 ! Subtract the constant term
7397         etors=etors-v0(itori,itori1,iblock)
7398           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7399                'etor',i,etors_ii-v0(itori,itori1,iblock)
7400         if (lprn) &
7401         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7402         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7403         (v1(j,itori,itori1,iblock),j=1,6),&
7404         (v2(j,itori,itori1,iblock),j=1,6)
7405         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7406 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7407       enddo
7408 ! 6/20/98 - dihedral angle constraints
7409       return
7410       end subroutine etor
7411 !C The rigorous attempt to derive energy function
7412 !-------------------------------------------------------------------------------------------
7413       subroutine etor_kcc(etors)
7414       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7415       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7416        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7417        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7418        gradvalst2,etori
7419       logical lprn
7420       integer :: i,j,itori,itori1,nval,k,l
7421
7422       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7423       etors=0.0D0
7424       do i=iphi_start,iphi_end
7425 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7426 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7427 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7428 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7429         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7430            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7431         itori=itortyp(itype(i-2,1))
7432         itori1=itortyp(itype(i-1,1))
7433         phii=phi(i)
7434         glocig=0.0D0
7435         glocit1=0.0d0
7436         glocit2=0.0d0
7437 !C to avoid multiple devision by 2
7438 !c        theti22=0.5d0*theta(i)
7439 !C theta 12 is the theta_1 /2
7440 !C theta 22 is theta_2 /2
7441 !c        theti12=0.5d0*theta(i-1)
7442 !C and appropriate sinus function
7443         sinthet1=dsin(theta(i-1))
7444         sinthet2=dsin(theta(i))
7445         costhet1=dcos(theta(i-1))
7446         costhet2=dcos(theta(i))
7447 !C to speed up lets store its mutliplication
7448         sint1t2=sinthet2*sinthet1
7449         sint1t2n=1.0d0
7450 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7451 !C +d_n*sin(n*gamma)) *
7452 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7453 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7454         nval=nterm_kcc_Tb(itori,itori1)
7455         c1(0)=0.0d0
7456         c2(0)=0.0d0
7457         c1(1)=1.0d0
7458         c2(1)=1.0d0
7459         do j=2,nval
7460           c1(j)=c1(j-1)*costhet1
7461           c2(j)=c2(j-1)*costhet2
7462         enddo
7463         etori=0.0d0
7464
7465        do j=1,nterm_kcc(itori,itori1)
7466           cosphi=dcos(j*phii)
7467           sinphi=dsin(j*phii)
7468           sint1t2n1=sint1t2n
7469           sint1t2n=sint1t2n*sint1t2
7470           sumvalc=0.0d0
7471           gradvalct1=0.0d0
7472           gradvalct2=0.0d0
7473           do k=1,nval
7474             do l=1,nval
7475               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7476               gradvalct1=gradvalct1+ &
7477                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7478               gradvalct2=gradvalct2+ &
7479                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7480             enddo
7481           enddo
7482           gradvalct1=-gradvalct1*sinthet1
7483           gradvalct2=-gradvalct2*sinthet2
7484           sumvals=0.0d0
7485           gradvalst1=0.0d0
7486           gradvalst2=0.0d0
7487           do k=1,nval
7488             do l=1,nval
7489               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7490               gradvalst1=gradvalst1+ &
7491                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7492               gradvalst2=gradvalst2+ &
7493                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7494             enddo
7495           enddo
7496           gradvalst1=-gradvalst1*sinthet1
7497           gradvalst2=-gradvalst2*sinthet2
7498           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7499           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7500 !C glocig is the gradient local i site in gamma
7501           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7502 !C now gradient over theta_1
7503          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7504         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7505          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7506         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7507         enddo ! j
7508         etors=etors+etori
7509         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7510 !C derivative over theta1
7511         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7512 !C now derivative over theta2
7513         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7514         if (lprn) then
7515          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7516             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7517           write (iout,*) "c1",(c1(k),k=0,nval), &
7518          " c2",(c2(k),k=0,nval)
7519         endif
7520       enddo
7521       return
7522        end  subroutine etor_kcc
7523 !------------------------------------------------------------------------------
7524
7525         subroutine etor_constr(edihcnstr)
7526       real(kind=8) :: etors,edihcnstr
7527       logical :: lprn
7528 !el local variables
7529       integer :: i,j,iblock,itori,itori1
7530       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7531                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7532                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7533
7534       if (raw_psipred) then
7535         do i=idihconstr_start,idihconstr_end
7536           itori=idih_constr(i)
7537           phii=phi(itori)
7538           gaudih_i=vpsipred(1,i)
7539           gauder_i=0.0d0
7540           do j=1,2
7541             s = sdihed(j,i)
7542             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7543             dexpcos_i=dexp(-cos_i*cos_i)
7544             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7545           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7546                  *cos_i*dexpcos_i/s**2
7547           enddo
7548           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7549           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7550           if (energy_dec) &
7551           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7552           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7553           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7554           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7555           -wdihc*dlog(gaudih_i)
7556         enddo
7557       else
7558
7559       do i=idihconstr_start,idihconstr_end
7560         itori=idih_constr(i)
7561         phii=phi(itori)
7562         difi=pinorm(phii-phi0(i))
7563         if (difi.gt.drange(i)) then
7564           difi=difi-drange(i)
7565           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7566           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7567         else if (difi.lt.-drange(i)) then
7568           difi=difi+drange(i)
7569           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7570           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7571         else
7572           difi=0.0
7573         endif
7574       enddo
7575
7576       endif
7577
7578       return
7579
7580       end subroutine etor_constr
7581 !-----------------------------------------------------------------------------
7582       subroutine etor_d(etors_d)
7583 ! 6/23/01 Compute double torsional energy
7584 !      implicit real*8 (a-h,o-z)
7585 !      include 'DIMENSIONS'
7586 !      include 'COMMON.VAR'
7587 !      include 'COMMON.GEO'
7588 !      include 'COMMON.LOCAL'
7589 !      include 'COMMON.TORSION'
7590 !      include 'COMMON.INTERACT'
7591 !      include 'COMMON.DERIV'
7592 !      include 'COMMON.CHAIN'
7593 !      include 'COMMON.NAMES'
7594 !      include 'COMMON.IOUNITS'
7595 !      include 'COMMON.FFIELD'
7596 !      include 'COMMON.TORCNSTR'
7597       real(kind=8) :: etors_d,etors_d_ii
7598       logical :: lprn
7599 !el local variables
7600       integer :: i,j,k,l,itori,itori1,itori2,iblock
7601       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7602                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7603                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7604                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7605 ! Set lprn=.true. for debugging
7606       lprn=.false.
7607 !     lprn=.true.
7608       etors_d=0.0D0
7609 !      write(iout,*) "a tu??"
7610       do i=iphid_start,iphid_end
7611         etors_d_ii=0.0D0
7612         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7613             .or. itype(i-3,1).eq.ntyp1 &
7614             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7615         itori=itortyp(itype(i-2,1))
7616         itori1=itortyp(itype(i-1,1))
7617         itori2=itortyp(itype(i,1))
7618         phii=phi(i)
7619         phii1=phi(i+1)
7620         gloci1=0.0D0
7621         gloci2=0.0D0
7622         iblock=1
7623         if (iabs(itype(i+1,1)).eq.20) iblock=2
7624
7625 ! Regular cosine and sine terms
7626         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7627           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7628           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7629           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7630           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7631           cosphi1=dcos(j*phii)
7632           sinphi1=dsin(j*phii)
7633           cosphi2=dcos(j*phii1)
7634           sinphi2=dsin(j*phii1)
7635           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7636            v2cij*cosphi2+v2sij*sinphi2
7637           if (energy_dec) etors_d_ii=etors_d_ii+ &
7638            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7639           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7640           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7641         enddo
7642         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7643           do l=1,k-1
7644             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7645             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7646             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7647             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7648             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7649             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7650             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7651             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7652             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7653               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7654             if (energy_dec) etors_d_ii=etors_d_ii+ &
7655               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7656               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7657             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7658               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7659             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7660               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7661           enddo
7662         enddo
7663         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7664                             'etor_d',i,etors_d_ii
7665         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7666         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7667       enddo
7668       return
7669       end subroutine etor_d
7670 #endif
7671
7672       subroutine ebend_kcc(etheta)
7673       logical lprn
7674       double precision thybt1(maxang_kcc),etheta
7675       integer :: i,iti,j,ihelp
7676       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7677 !C Set lprn=.true. for debugging
7678       lprn=energy_dec
7679 !c     lprn=.true.
7680 !C      print *,"wchodze kcc"
7681       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7682       etheta=0.0D0
7683       do i=ithet_start,ithet_end
7684 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7685         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7686        .or.itype(i,1).eq.ntyp1) cycle
7687         iti=iabs(itortyp(itype(i-1,1)))
7688         sinthet=dsin(theta(i))
7689         costhet=dcos(theta(i))
7690         do j=1,nbend_kcc_Tb(iti)
7691           thybt1(j)=v1bend_chyb(j,iti)
7692         enddo
7693         sumth1thyb=v1bend_chyb(0,iti)+ &
7694          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7695         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7696          sumth1thyb
7697         ihelp=nbend_kcc_Tb(iti)-1
7698         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7699         etheta=etheta+sumth1thyb
7700 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7701         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7702       enddo
7703       return
7704       end subroutine ebend_kcc
7705 !c------------
7706 !c-------------------------------------------------------------------------------------
7707       subroutine etheta_constr(ethetacnstr)
7708       real (kind=8) :: ethetacnstr,thetiii,difi
7709       integer :: i,itheta
7710       ethetacnstr=0.0d0
7711 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7712       do i=ithetaconstr_start,ithetaconstr_end
7713         itheta=itheta_constr(i)
7714         thetiii=theta(itheta)
7715         difi=pinorm(thetiii-theta_constr0(i))
7716         if (difi.gt.theta_drange(i)) then
7717           difi=difi-theta_drange(i)
7718           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7719           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7720          +for_thet_constr(i)*difi**3
7721         else if (difi.lt.-drange(i)) then
7722           difi=difi+drange(i)
7723           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7724           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7725           +for_thet_constr(i)*difi**3
7726         else
7727           difi=0.0
7728         endif
7729        if (energy_dec) then
7730         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7731          i,itheta,rad2deg*thetiii,&
7732          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7733          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7734          gloc(itheta+nphi-2,icg)
7735         endif
7736       enddo
7737       return
7738       end subroutine etheta_constr
7739
7740 !-----------------------------------------------------------------------------
7741       subroutine eback_sc_corr(esccor)
7742 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7743 !        conformational states; temporarily implemented as differences
7744 !        between UNRES torsional potentials (dependent on three types of
7745 !        residues) and the torsional potentials dependent on all 20 types
7746 !        of residues computed from AM1  energy surfaces of terminally-blocked
7747 !        amino-acid residues.
7748 !      implicit real*8 (a-h,o-z)
7749 !      include 'DIMENSIONS'
7750 !      include 'COMMON.VAR'
7751 !      include 'COMMON.GEO'
7752 !      include 'COMMON.LOCAL'
7753 !      include 'COMMON.TORSION'
7754 !      include 'COMMON.SCCOR'
7755 !      include 'COMMON.INTERACT'
7756 !      include 'COMMON.DERIV'
7757 !      include 'COMMON.CHAIN'
7758 !      include 'COMMON.NAMES'
7759 !      include 'COMMON.IOUNITS'
7760 !      include 'COMMON.FFIELD'
7761 !      include 'COMMON.CONTROL'
7762       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7763                    cosphi,sinphi
7764       logical :: lprn
7765       integer :: i,interty,j,isccori,isccori1,intertyp
7766 ! Set lprn=.true. for debugging
7767       lprn=.false.
7768 !      lprn=.true.
7769 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7770       esccor=0.0D0
7771       do i=itau_start,itau_end
7772         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7773         esccor_ii=0.0D0
7774         isccori=isccortyp(itype(i-2,1))
7775         isccori1=isccortyp(itype(i-1,1))
7776
7777 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7778         phii=phi(i)
7779         do intertyp=1,3 !intertyp
7780          esccor_ii=0.0D0
7781 !c Added 09 May 2012 (Adasko)
7782 !c  Intertyp means interaction type of backbone mainchain correlation:
7783 !   1 = SC...Ca...Ca...Ca
7784 !   2 = Ca...Ca...Ca...SC
7785 !   3 = SC...Ca...Ca...SCi
7786         gloci=0.0D0
7787         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7788             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7789             (itype(i-1,1).eq.ntyp1))) &
7790           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7791            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7792            .or.(itype(i,1).eq.ntyp1))) &
7793           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7794             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7795             (itype(i-3,1).eq.ntyp1)))) cycle
7796         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7797         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7798        cycle
7799        do j=1,nterm_sccor(isccori,isccori1)
7800           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7801           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7802           cosphi=dcos(j*tauangle(intertyp,i))
7803           sinphi=dsin(j*tauangle(intertyp,i))
7804           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7805           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7806           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7807         enddo
7808         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7809                                 'esccor',i,intertyp,esccor_ii
7810 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7811         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7812         if (lprn) &
7813         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7814         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7815         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7816         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7817         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7818        enddo !intertyp
7819       enddo
7820
7821       return
7822       end subroutine eback_sc_corr
7823 !-----------------------------------------------------------------------------
7824       subroutine multibody(ecorr)
7825 ! This subroutine calculates multi-body contributions to energy following
7826 ! the idea of Skolnick et al. If side chains I and J make a contact and
7827 ! at the same time side chains I+1 and J+1 make a contact, an extra
7828 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7829 !      implicit real*8 (a-h,o-z)
7830 !      include 'DIMENSIONS'
7831 !      include 'COMMON.IOUNITS'
7832 !      include 'COMMON.DERIV'
7833 !      include 'COMMON.INTERACT'
7834 !      include 'COMMON.CONTACTS'
7835       real(kind=8),dimension(3) :: gx,gx1
7836       logical :: lprn
7837       real(kind=8) :: ecorr
7838       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7839 ! Set lprn=.true. for debugging
7840       lprn=.false.
7841
7842       if (lprn) then
7843         write (iout,'(a)') 'Contact function values:'
7844         do i=nnt,nct-2
7845           write (iout,'(i2,20(1x,i2,f10.5))') &
7846               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7847         enddo
7848       endif
7849       ecorr=0.0D0
7850
7851 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7852 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7853       do i=nnt,nct
7854         do j=1,3
7855           gradcorr(j,i)=0.0D0
7856           gradxorr(j,i)=0.0D0
7857         enddo
7858       enddo
7859       do i=nnt,nct-2
7860
7861         DO ISHIFT = 3,4
7862
7863         i1=i+ishift
7864         num_conti=num_cont(i)
7865         num_conti1=num_cont(i1)
7866         do jj=1,num_conti
7867           j=jcont(jj,i)
7868           do kk=1,num_conti1
7869             j1=jcont(kk,i1)
7870             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7871 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7872 !d   &                   ' ishift=',ishift
7873 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7874 ! The system gains extra energy.
7875               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7876             endif   ! j1==j+-ishift
7877           enddo     ! kk
7878         enddo       ! jj
7879
7880         ENDDO ! ISHIFT
7881
7882       enddo         ! i
7883       return
7884       end subroutine multibody
7885 !-----------------------------------------------------------------------------
7886       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7887 !      implicit real*8 (a-h,o-z)
7888 !      include 'DIMENSIONS'
7889 !      include 'COMMON.IOUNITS'
7890 !      include 'COMMON.DERIV'
7891 !      include 'COMMON.INTERACT'
7892 !      include 'COMMON.CONTACTS'
7893       real(kind=8),dimension(3) :: gx,gx1
7894       logical :: lprn
7895       integer :: i,j,k,l,jj,kk,m,ll
7896       real(kind=8) :: eij,ekl
7897       lprn=.false.
7898       eij=facont(jj,i)
7899       ekl=facont(kk,k)
7900 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7901 ! Calculate the multi-body contribution to energy.
7902 ! Calculate multi-body contributions to the gradient.
7903 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7904 !d   & k,l,(gacont(m,kk,k),m=1,3)
7905       do m=1,3
7906         gx(m) =ekl*gacont(m,jj,i)
7907         gx1(m)=eij*gacont(m,kk,k)
7908         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7909         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7910         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7911         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7912       enddo
7913       do m=i,j-1
7914         do ll=1,3
7915           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7916         enddo
7917       enddo
7918       do m=k,l-1
7919         do ll=1,3
7920           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7921         enddo
7922       enddo
7923       esccorr=-eij*ekl
7924       return
7925       end function esccorr
7926 !-----------------------------------------------------------------------------
7927       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7928 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7929 !      implicit real*8 (a-h,o-z)
7930 !      include 'DIMENSIONS'
7931 !      include 'COMMON.IOUNITS'
7932 #ifdef MPI
7933       include "mpif.h"
7934 !      integer :: maxconts !max_cont=maxconts  =nres/4
7935       integer,parameter :: max_dim=26
7936       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7937       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7938 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7939 !el      common /przechowalnia/ zapas
7940       integer :: status(MPI_STATUS_SIZE)
7941       integer,dimension((nres/4)*2) :: req !maxconts*2
7942       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7943 #endif
7944 !      include 'COMMON.SETUP'
7945 !      include 'COMMON.FFIELD'
7946 !      include 'COMMON.DERIV'
7947 !      include 'COMMON.INTERACT'
7948 !      include 'COMMON.CONTACTS'
7949 !      include 'COMMON.CONTROL'
7950 !      include 'COMMON.LOCAL'
7951       real(kind=8),dimension(3) :: gx,gx1
7952       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7953       logical :: lprn,ldone
7954 !el local variables
7955       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7956               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7957
7958 ! Set lprn=.true. for debugging
7959       lprn=.false.
7960 #ifdef MPI
7961 !      maxconts=nres/4
7962       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7963       n_corr=0
7964       n_corr1=0
7965       if (nfgtasks.le.1) goto 30
7966       if (lprn) then
7967         write (iout,'(a)') 'Contact function values before RECEIVE:'
7968         do i=nnt,nct-2
7969           write (iout,'(2i3,50(1x,i2,f5.2))') &
7970           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7971           j=1,num_cont_hb(i))
7972         enddo
7973       endif
7974       call flush(iout)
7975       do i=1,ntask_cont_from
7976         ncont_recv(i)=0
7977       enddo
7978       do i=1,ntask_cont_to
7979         ncont_sent(i)=0
7980       enddo
7981 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7982 !     & ntask_cont_to
7983 ! Make the list of contacts to send to send to other procesors
7984 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7985 !      call flush(iout)
7986       do i=iturn3_start,iturn3_end
7987 !        write (iout,*) "make contact list turn3",i," num_cont",
7988 !     &    num_cont_hb(i)
7989         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7990       enddo
7991       do i=iturn4_start,iturn4_end
7992 !        write (iout,*) "make contact list turn4",i," num_cont",
7993 !     &   num_cont_hb(i)
7994         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7995       enddo
7996       do ii=1,nat_sent
7997         i=iat_sent(ii)
7998 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7999 !     &    num_cont_hb(i)
8000         do j=1,num_cont_hb(i)
8001         do k=1,4
8002           jjc=jcont_hb(j,i)
8003           iproc=iint_sent_local(k,jjc,ii)
8004 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8005           if (iproc.gt.0) then
8006             ncont_sent(iproc)=ncont_sent(iproc)+1
8007             nn=ncont_sent(iproc)
8008             zapas(1,nn,iproc)=i
8009             zapas(2,nn,iproc)=jjc
8010             zapas(3,nn,iproc)=facont_hb(j,i)
8011             zapas(4,nn,iproc)=ees0p(j,i)
8012             zapas(5,nn,iproc)=ees0m(j,i)
8013             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8014             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8015             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8016             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8017             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8018             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8019             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8020             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8021             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8022             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8023             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8024             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8025             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8026             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8027             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8028             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8029             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8030             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8031             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8032             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8033             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8034           endif
8035         enddo
8036         enddo
8037       enddo
8038       if (lprn) then
8039       write (iout,*) &
8040         "Numbers of contacts to be sent to other processors",&
8041         (ncont_sent(i),i=1,ntask_cont_to)
8042       write (iout,*) "Contacts sent"
8043       do ii=1,ntask_cont_to
8044         nn=ncont_sent(ii)
8045         iproc=itask_cont_to(ii)
8046         write (iout,*) nn," contacts to processor",iproc,&
8047          " of CONT_TO_COMM group"
8048         do i=1,nn
8049           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8050         enddo
8051       enddo
8052       call flush(iout)
8053       endif
8054       CorrelType=477
8055       CorrelID=fg_rank+1
8056       CorrelType1=478
8057       CorrelID1=nfgtasks+fg_rank+1
8058       ireq=0
8059 ! Receive the numbers of needed contacts from other processors
8060       do ii=1,ntask_cont_from
8061         iproc=itask_cont_from(ii)
8062         ireq=ireq+1
8063         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8064           FG_COMM,req(ireq),IERR)
8065       enddo
8066 !      write (iout,*) "IRECV ended"
8067 !      call flush(iout)
8068 ! Send the number of contacts needed by other processors
8069       do ii=1,ntask_cont_to
8070         iproc=itask_cont_to(ii)
8071         ireq=ireq+1
8072         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8073           FG_COMM,req(ireq),IERR)
8074       enddo
8075 !      write (iout,*) "ISEND ended"
8076 !      write (iout,*) "number of requests (nn)",ireq
8077       call flush(iout)
8078       if (ireq.gt.0) &
8079         call MPI_Waitall(ireq,req,status_array,ierr)
8080 !      write (iout,*)
8081 !     &  "Numbers of contacts to be received from other processors",
8082 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8083 !      call flush(iout)
8084 ! Receive contacts
8085       ireq=0
8086       do ii=1,ntask_cont_from
8087         iproc=itask_cont_from(ii)
8088         nn=ncont_recv(ii)
8089 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8090 !     &   " of CONT_TO_COMM group"
8091         call flush(iout)
8092         if (nn.gt.0) then
8093           ireq=ireq+1
8094           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8095           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8096 !          write (iout,*) "ireq,req",ireq,req(ireq)
8097         endif
8098       enddo
8099 ! Send the contacts to processors that need them
8100       do ii=1,ntask_cont_to
8101         iproc=itask_cont_to(ii)
8102         nn=ncont_sent(ii)
8103 !        write (iout,*) nn," contacts to processor",iproc,
8104 !     &   " of CONT_TO_COMM group"
8105         if (nn.gt.0) then
8106           ireq=ireq+1
8107           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8108             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8109 !          write (iout,*) "ireq,req",ireq,req(ireq)
8110 !          do i=1,nn
8111 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8112 !          enddo
8113         endif
8114       enddo
8115 !      write (iout,*) "number of requests (contacts)",ireq
8116 !      write (iout,*) "req",(req(i),i=1,4)
8117 !      call flush(iout)
8118       if (ireq.gt.0) &
8119        call MPI_Waitall(ireq,req,status_array,ierr)
8120       do iii=1,ntask_cont_from
8121         iproc=itask_cont_from(iii)
8122         nn=ncont_recv(iii)
8123         if (lprn) then
8124         write (iout,*) "Received",nn," contacts from processor",iproc,&
8125          " of CONT_FROM_COMM group"
8126         call flush(iout)
8127         do i=1,nn
8128           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8129         enddo
8130         call flush(iout)
8131         endif
8132         do i=1,nn
8133           ii=zapas_recv(1,i,iii)
8134 ! Flag the received contacts to prevent double-counting
8135           jj=-zapas_recv(2,i,iii)
8136 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8137 !          call flush(iout)
8138           nnn=num_cont_hb(ii)+1
8139           num_cont_hb(ii)=nnn
8140           jcont_hb(nnn,ii)=jj
8141           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8142           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8143           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8144           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8145           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8146           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8147           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8148           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8149           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8150           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8151           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8152           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8153           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8154           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8155           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8156           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8157           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8158           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8159           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8160           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8161           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8162           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8163           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8164           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8165         enddo
8166       enddo
8167       call flush(iout)
8168       if (lprn) then
8169         write (iout,'(a)') 'Contact function values after receive:'
8170         do i=nnt,nct-2
8171           write (iout,'(2i3,50(1x,i3,f5.2))') &
8172           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8173           j=1,num_cont_hb(i))
8174         enddo
8175         call flush(iout)
8176       endif
8177    30 continue
8178 #endif
8179       if (lprn) then
8180         write (iout,'(a)') 'Contact function values:'
8181         do i=nnt,nct-2
8182           write (iout,'(2i3,50(1x,i3,f5.2))') &
8183           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8184           j=1,num_cont_hb(i))
8185         enddo
8186       endif
8187       ecorr=0.0D0
8188
8189 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8190 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8191 ! Remove the loop below after debugging !!!
8192       do i=nnt,nct
8193         do j=1,3
8194           gradcorr(j,i)=0.0D0
8195           gradxorr(j,i)=0.0D0
8196         enddo
8197       enddo
8198 ! Calculate the local-electrostatic correlation terms
8199       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8200         i1=i+1
8201         num_conti=num_cont_hb(i)
8202         num_conti1=num_cont_hb(i+1)
8203         do jj=1,num_conti
8204           j=jcont_hb(jj,i)
8205           jp=iabs(j)
8206           do kk=1,num_conti1
8207             j1=jcont_hb(kk,i1)
8208             jp1=iabs(j1)
8209 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8210 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8211             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8212                 .or. j.lt.0 .and. j1.gt.0) .and. &
8213                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8214 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8215 ! The system gains extra energy.
8216               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8217               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8218                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8219               n_corr=n_corr+1
8220             else if (j1.eq.j) then
8221 ! Contacts I-J and I-(J+1) occur simultaneously.
8222 ! The system loses extra energy.
8223 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8224             endif
8225           enddo ! kk
8226           do kk=1,num_conti
8227             j1=jcont_hb(kk,i)
8228 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8229 !    &         ' jj=',jj,' kk=',kk
8230             if (j1.eq.j+1) then
8231 ! Contacts I-J and (I+1)-J occur simultaneously.
8232 ! The system loses extra energy.
8233 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8234             endif ! j1==j+1
8235           enddo ! kk
8236         enddo ! jj
8237       enddo ! i
8238       return
8239       end subroutine multibody_hb
8240 !-----------------------------------------------------------------------------
8241       subroutine add_hb_contact(ii,jj,itask)
8242 !      implicit real*8 (a-h,o-z)
8243 !      include "DIMENSIONS"
8244 !      include "COMMON.IOUNITS"
8245 !      include "COMMON.CONTACTS"
8246 !      integer,parameter :: maxconts=nres/4
8247       integer,parameter :: max_dim=26
8248       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8249 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8250 !      common /przechowalnia/ zapas
8251       integer :: i,j,ii,jj,iproc,nn,jjc
8252       integer,dimension(4) :: itask
8253 !      write (iout,*) "itask",itask
8254       do i=1,2
8255         iproc=itask(i)
8256         if (iproc.gt.0) then
8257           do j=1,num_cont_hb(ii)
8258             jjc=jcont_hb(j,ii)
8259 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8260             if (jjc.eq.jj) then
8261               ncont_sent(iproc)=ncont_sent(iproc)+1
8262               nn=ncont_sent(iproc)
8263               zapas(1,nn,iproc)=ii
8264               zapas(2,nn,iproc)=jjc
8265               zapas(3,nn,iproc)=facont_hb(j,ii)
8266               zapas(4,nn,iproc)=ees0p(j,ii)
8267               zapas(5,nn,iproc)=ees0m(j,ii)
8268               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8269               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8270               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8271               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8272               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8273               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8274               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8275               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8276               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8277               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8278               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8279               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8280               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8281               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8282               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8283               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8284               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8285               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8286               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8287               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8288               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8289               exit
8290             endif
8291           enddo
8292         endif
8293       enddo
8294       return
8295       end subroutine add_hb_contact
8296 !-----------------------------------------------------------------------------
8297       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8298 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8299 !      implicit real*8 (a-h,o-z)
8300 !      include 'DIMENSIONS'
8301 !      include 'COMMON.IOUNITS'
8302       integer,parameter :: max_dim=70
8303 #ifdef MPI
8304       include "mpif.h"
8305 !      integer :: maxconts !max_cont=maxconts=nres/4
8306       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8307       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8308 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8309 !      common /przechowalnia/ zapas
8310       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8311         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8312         ierr,iii,nnn
8313 #endif
8314 !      include 'COMMON.SETUP'
8315 !      include 'COMMON.FFIELD'
8316 !      include 'COMMON.DERIV'
8317 !      include 'COMMON.LOCAL'
8318 !      include 'COMMON.INTERACT'
8319 !      include 'COMMON.CONTACTS'
8320 !      include 'COMMON.CHAIN'
8321 !      include 'COMMON.CONTROL'
8322       real(kind=8),dimension(3) :: gx,gx1
8323       integer,dimension(nres) :: num_cont_hb_old
8324       logical :: lprn,ldone
8325 !EL      double precision eello4,eello5,eelo6,eello_turn6
8326 !EL      external eello4,eello5,eello6,eello_turn6
8327 !el local variables
8328       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8329               j1,jp1,i1,num_conti1
8330       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8331       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8332
8333 ! Set lprn=.true. for debugging
8334       lprn=.false.
8335       eturn6=0.0d0
8336 #ifdef MPI
8337 !      maxconts=nres/4
8338       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8339       do i=1,nres
8340         num_cont_hb_old(i)=num_cont_hb(i)
8341       enddo
8342       n_corr=0
8343       n_corr1=0
8344       if (nfgtasks.le.1) goto 30
8345       if (lprn) then
8346         write (iout,'(a)') 'Contact function values before RECEIVE:'
8347         do i=nnt,nct-2
8348           write (iout,'(2i3,50(1x,i2,f5.2))') &
8349           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8350           j=1,num_cont_hb(i))
8351         enddo
8352       endif
8353       call flush(iout)
8354       do i=1,ntask_cont_from
8355         ncont_recv(i)=0
8356       enddo
8357       do i=1,ntask_cont_to
8358         ncont_sent(i)=0
8359       enddo
8360 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8361 !     & ntask_cont_to
8362 ! Make the list of contacts to send to send to other procesors
8363       do i=iturn3_start,iturn3_end
8364 !        write (iout,*) "make contact list turn3",i," num_cont",
8365 !     &    num_cont_hb(i)
8366         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8367       enddo
8368       do i=iturn4_start,iturn4_end
8369 !        write (iout,*) "make contact list turn4",i," num_cont",
8370 !     &   num_cont_hb(i)
8371         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8372       enddo
8373       do ii=1,nat_sent
8374         i=iat_sent(ii)
8375 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8376 !     &    num_cont_hb(i)
8377         do j=1,num_cont_hb(i)
8378         do k=1,4
8379           jjc=jcont_hb(j,i)
8380           iproc=iint_sent_local(k,jjc,ii)
8381 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8382           if (iproc.ne.0) then
8383             ncont_sent(iproc)=ncont_sent(iproc)+1
8384             nn=ncont_sent(iproc)
8385             zapas(1,nn,iproc)=i
8386             zapas(2,nn,iproc)=jjc
8387             zapas(3,nn,iproc)=d_cont(j,i)
8388             ind=3
8389             do kk=1,3
8390               ind=ind+1
8391               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8392             enddo
8393             do kk=1,2
8394               do ll=1,2
8395                 ind=ind+1
8396                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8397               enddo
8398             enddo
8399             do jj=1,5
8400               do kk=1,3
8401                 do ll=1,2
8402                   do mm=1,2
8403                     ind=ind+1
8404                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8405                   enddo
8406                 enddo
8407               enddo
8408             enddo
8409           endif
8410         enddo
8411         enddo
8412       enddo
8413       if (lprn) then
8414       write (iout,*) &
8415         "Numbers of contacts to be sent to other processors",&
8416         (ncont_sent(i),i=1,ntask_cont_to)
8417       write (iout,*) "Contacts sent"
8418       do ii=1,ntask_cont_to
8419         nn=ncont_sent(ii)
8420         iproc=itask_cont_to(ii)
8421         write (iout,*) nn," contacts to processor",iproc,&
8422          " of CONT_TO_COMM group"
8423         do i=1,nn
8424           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8425         enddo
8426       enddo
8427       call flush(iout)
8428       endif
8429       CorrelType=477
8430       CorrelID=fg_rank+1
8431       CorrelType1=478
8432       CorrelID1=nfgtasks+fg_rank+1
8433       ireq=0
8434 ! Receive the numbers of needed contacts from other processors
8435       do ii=1,ntask_cont_from
8436         iproc=itask_cont_from(ii)
8437         ireq=ireq+1
8438         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8439           FG_COMM,req(ireq),IERR)
8440       enddo
8441 !      write (iout,*) "IRECV ended"
8442 !      call flush(iout)
8443 ! Send the number of contacts needed by other processors
8444       do ii=1,ntask_cont_to
8445         iproc=itask_cont_to(ii)
8446         ireq=ireq+1
8447         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8448           FG_COMM,req(ireq),IERR)
8449       enddo
8450 !      write (iout,*) "ISEND ended"
8451 !      write (iout,*) "number of requests (nn)",ireq
8452       call flush(iout)
8453       if (ireq.gt.0) &
8454         call MPI_Waitall(ireq,req,status_array,ierr)
8455 !      write (iout,*)
8456 !     &  "Numbers of contacts to be received from other processors",
8457 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8458 !      call flush(iout)
8459 ! Receive contacts
8460       ireq=0
8461       do ii=1,ntask_cont_from
8462         iproc=itask_cont_from(ii)
8463         nn=ncont_recv(ii)
8464 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8465 !     &   " of CONT_TO_COMM group"
8466         call flush(iout)
8467         if (nn.gt.0) then
8468           ireq=ireq+1
8469           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8470           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8471 !          write (iout,*) "ireq,req",ireq,req(ireq)
8472         endif
8473       enddo
8474 ! Send the contacts to processors that need them
8475       do ii=1,ntask_cont_to
8476         iproc=itask_cont_to(ii)
8477         nn=ncont_sent(ii)
8478 !        write (iout,*) nn," contacts to processor",iproc,
8479 !     &   " of CONT_TO_COMM group"
8480         if (nn.gt.0) then
8481           ireq=ireq+1
8482           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8483             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8484 !          write (iout,*) "ireq,req",ireq,req(ireq)
8485 !          do i=1,nn
8486 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8487 !          enddo
8488         endif
8489       enddo
8490 !      write (iout,*) "number of requests (contacts)",ireq
8491 !      write (iout,*) "req",(req(i),i=1,4)
8492 !      call flush(iout)
8493       if (ireq.gt.0) &
8494        call MPI_Waitall(ireq,req,status_array,ierr)
8495       do iii=1,ntask_cont_from
8496         iproc=itask_cont_from(iii)
8497         nn=ncont_recv(iii)
8498         if (lprn) then
8499         write (iout,*) "Received",nn," contacts from processor",iproc,&
8500          " of CONT_FROM_COMM group"
8501         call flush(iout)
8502         do i=1,nn
8503           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8504         enddo
8505         call flush(iout)
8506         endif
8507         do i=1,nn
8508           ii=zapas_recv(1,i,iii)
8509 ! Flag the received contacts to prevent double-counting
8510           jj=-zapas_recv(2,i,iii)
8511 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8512 !          call flush(iout)
8513           nnn=num_cont_hb(ii)+1
8514           num_cont_hb(ii)=nnn
8515           jcont_hb(nnn,ii)=jj
8516           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8517           ind=3
8518           do kk=1,3
8519             ind=ind+1
8520             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8521           enddo
8522           do kk=1,2
8523             do ll=1,2
8524               ind=ind+1
8525               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8526             enddo
8527           enddo
8528           do jj=1,5
8529             do kk=1,3
8530               do ll=1,2
8531                 do mm=1,2
8532                   ind=ind+1
8533                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8534                 enddo
8535               enddo
8536             enddo
8537           enddo
8538         enddo
8539       enddo
8540       call flush(iout)
8541       if (lprn) then
8542         write (iout,'(a)') 'Contact function values after receive:'
8543         do i=nnt,nct-2
8544           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8545           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8546           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8547         enddo
8548         call flush(iout)
8549       endif
8550    30 continue
8551 #endif
8552       if (lprn) then
8553         write (iout,'(a)') 'Contact function values:'
8554         do i=nnt,nct-2
8555           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8556           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8557           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8558         enddo
8559       endif
8560       ecorr=0.0D0
8561       ecorr5=0.0d0
8562       ecorr6=0.0d0
8563
8564 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8565 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8566 ! Remove the loop below after debugging !!!
8567       do i=nnt,nct
8568         do j=1,3
8569           gradcorr(j,i)=0.0D0
8570           gradxorr(j,i)=0.0D0
8571         enddo
8572       enddo
8573 ! Calculate the dipole-dipole interaction energies
8574       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8575       do i=iatel_s,iatel_e+1
8576         num_conti=num_cont_hb(i)
8577         do jj=1,num_conti
8578           j=jcont_hb(jj,i)
8579 #ifdef MOMENT
8580           call dipole(i,j,jj)
8581 #endif
8582         enddo
8583       enddo
8584       endif
8585 ! Calculate the local-electrostatic correlation terms
8586 !                write (iout,*) "gradcorr5 in eello5 before loop"
8587 !                do iii=1,nres
8588 !                  write (iout,'(i5,3f10.5)')
8589 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8590 !                enddo
8591       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8592 !        write (iout,*) "corr loop i",i
8593         i1=i+1
8594         num_conti=num_cont_hb(i)
8595         num_conti1=num_cont_hb(i+1)
8596         do jj=1,num_conti
8597           j=jcont_hb(jj,i)
8598           jp=iabs(j)
8599           do kk=1,num_conti1
8600             j1=jcont_hb(kk,i1)
8601             jp1=iabs(j1)
8602 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8603 !     &         ' jj=',jj,' kk=',kk
8604 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8605             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8606                 .or. j.lt.0 .and. j1.gt.0) .and. &
8607                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8608 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8609 ! The system gains extra energy.
8610               n_corr=n_corr+1
8611               sqd1=dsqrt(d_cont(jj,i))
8612               sqd2=dsqrt(d_cont(kk,i1))
8613               sred_geom = sqd1*sqd2
8614               IF (sred_geom.lt.cutoff_corr) THEN
8615                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8616                   ekont,fprimcont)
8617 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8618 !d     &         ' jj=',jj,' kk=',kk
8619                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8620                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8621                 do l=1,3
8622                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8623                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8624                 enddo
8625                 n_corr1=n_corr1+1
8626 !d               write (iout,*) 'sred_geom=',sred_geom,
8627 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8628 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8629 !d               write (iout,*) "g_contij",g_contij
8630 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8631 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8632                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8633                 if (wcorr4.gt.0.0d0) &
8634                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8635                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8636                        write (iout,'(a6,4i5,0pf7.3)') &
8637                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8638 !                write (iout,*) "gradcorr5 before eello5"
8639 !                do iii=1,nres
8640 !                  write (iout,'(i5,3f10.5)')
8641 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8642 !                enddo
8643                 if (wcorr5.gt.0.0d0) &
8644                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8645 !                write (iout,*) "gradcorr5 after eello5"
8646 !                do iii=1,nres
8647 !                  write (iout,'(i5,3f10.5)')
8648 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8649 !                enddo
8650                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8651                        write (iout,'(a6,4i5,0pf7.3)') &
8652                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8653 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8654 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8655                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8656                      .or. wturn6.eq.0.0d0))then
8657 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8658                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8659                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8660                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8661 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8662 !d     &            'ecorr6=',ecorr6
8663 !d                write (iout,'(4e15.5)') sred_geom,
8664 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8665 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8666 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8667                 else if (wturn6.gt.0.0d0 &
8668                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8669 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8670                   eturn6=eturn6+eello_turn6(i,jj,kk)
8671                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8672                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8673 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8674                 endif
8675               ENDIF
8676 1111          continue
8677             endif
8678           enddo ! kk
8679         enddo ! jj
8680       enddo ! i
8681       do i=1,nres
8682         num_cont_hb(i)=num_cont_hb_old(i)
8683       enddo
8684 !                write (iout,*) "gradcorr5 in eello5"
8685 !                do iii=1,nres
8686 !                  write (iout,'(i5,3f10.5)')
8687 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8688 !                enddo
8689       return
8690       end subroutine multibody_eello
8691 !-----------------------------------------------------------------------------
8692       subroutine add_hb_contact_eello(ii,jj,itask)
8693 !      implicit real*8 (a-h,o-z)
8694 !      include "DIMENSIONS"
8695 !      include "COMMON.IOUNITS"
8696 !      include "COMMON.CONTACTS"
8697 !      integer,parameter :: maxconts=nres/4
8698       integer,parameter :: max_dim=70
8699       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8700 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8701 !      common /przechowalnia/ zapas
8702
8703       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8704       integer,dimension(4) ::itask
8705 !      write (iout,*) "itask",itask
8706       do i=1,2
8707         iproc=itask(i)
8708         if (iproc.gt.0) then
8709           do j=1,num_cont_hb(ii)
8710             jjc=jcont_hb(j,ii)
8711 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8712             if (jjc.eq.jj) then
8713               ncont_sent(iproc)=ncont_sent(iproc)+1
8714               nn=ncont_sent(iproc)
8715               zapas(1,nn,iproc)=ii
8716               zapas(2,nn,iproc)=jjc
8717               zapas(3,nn,iproc)=d_cont(j,ii)
8718               ind=3
8719               do kk=1,3
8720                 ind=ind+1
8721                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8722               enddo
8723               do kk=1,2
8724                 do ll=1,2
8725                   ind=ind+1
8726                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8727                 enddo
8728               enddo
8729               do jj=1,5
8730                 do kk=1,3
8731                   do ll=1,2
8732                     do mm=1,2
8733                       ind=ind+1
8734                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8735                     enddo
8736                   enddo
8737                 enddo
8738               enddo
8739               exit
8740             endif
8741           enddo
8742         endif
8743       enddo
8744       return
8745       end subroutine add_hb_contact_eello
8746 !-----------------------------------------------------------------------------
8747       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8748 !      implicit real*8 (a-h,o-z)
8749 !      include 'DIMENSIONS'
8750 !      include 'COMMON.IOUNITS'
8751 !      include 'COMMON.DERIV'
8752 !      include 'COMMON.INTERACT'
8753 !      include 'COMMON.CONTACTS'
8754       real(kind=8),dimension(3) :: gx,gx1
8755       logical :: lprn
8756 !el local variables
8757       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8758       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8759                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8760                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8761                    rlocshield
8762
8763       lprn=.false.
8764       eij=facont_hb(jj,i)
8765       ekl=facont_hb(kk,k)
8766       ees0pij=ees0p(jj,i)
8767       ees0pkl=ees0p(kk,k)
8768       ees0mij=ees0m(jj,i)
8769       ees0mkl=ees0m(kk,k)
8770       ekont=eij*ekl
8771       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8772 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8773 ! Following 4 lines for diagnostics.
8774 !d    ees0pkl=0.0D0
8775 !d    ees0pij=1.0D0
8776 !d    ees0mkl=0.0D0
8777 !d    ees0mij=1.0D0
8778 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8779 !     & 'Contacts ',i,j,
8780 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8781 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8782 !     & 'gradcorr_long'
8783 ! Calculate the multi-body contribution to energy.
8784 !      ecorr=ecorr+ekont*ees
8785 ! Calculate multi-body contributions to the gradient.
8786       coeffpees0pij=coeffp*ees0pij
8787       coeffmees0mij=coeffm*ees0mij
8788       coeffpees0pkl=coeffp*ees0pkl
8789       coeffmees0mkl=coeffm*ees0mkl
8790       do ll=1,3
8791 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8792         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8793         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8794         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8795         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8796         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8797         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8798 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8799         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8800         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8801         coeffmees0mij*gacontm_hb1(ll,kk,k))
8802         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8803         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8804         coeffmees0mij*gacontm_hb2(ll,kk,k))
8805         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8806            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8807            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8808         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8809         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8810         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8811            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8812            coeffmees0mij*gacontm_hb3(ll,kk,k))
8813         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8814         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8815 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8816       enddo
8817 !      write (iout,*)
8818 !grad      do m=i+1,j-1
8819 !grad        do ll=1,3
8820 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8821 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8822 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8823 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8824 !grad        enddo
8825 !grad      enddo
8826 !grad      do m=k+1,l-1
8827 !grad        do ll=1,3
8828 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8829 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8830 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8831 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8832 !grad        enddo
8833 !grad      enddo
8834 !      write (iout,*) "ehbcorr",ekont*ees
8835       ehbcorr=ekont*ees
8836       if (shield_mode.gt.0) then
8837        j=ees0plist(jj,i)
8838        l=ees0plist(kk,k)
8839 !C        print *,i,j,fac_shield(i),fac_shield(j),
8840 !C     &fac_shield(k),fac_shield(l)
8841         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8842            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8843           do ilist=1,ishield_list(i)
8844            iresshield=shield_list(ilist,i)
8845            do m=1,3
8846            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8847            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8848                    rlocshield  &
8849             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8850             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8851             +rlocshield
8852            enddo
8853           enddo
8854           do ilist=1,ishield_list(j)
8855            iresshield=shield_list(ilist,j)
8856            do m=1,3
8857            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8858            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8859                    rlocshield &
8860             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8861            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8862             +rlocshield
8863            enddo
8864           enddo
8865
8866           do ilist=1,ishield_list(k)
8867            iresshield=shield_list(ilist,k)
8868            do m=1,3
8869            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8870            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8871                    rlocshield &
8872             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8873            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8874             +rlocshield
8875            enddo
8876           enddo
8877           do ilist=1,ishield_list(l)
8878            iresshield=shield_list(ilist,l)
8879            do m=1,3
8880            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8881            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8882                    rlocshield &
8883             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8884            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8885             +rlocshield
8886            enddo
8887           enddo
8888           do m=1,3
8889             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8890                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8891             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8892                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8893             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8894                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8895             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8896                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8897
8898             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8899                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8900             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8901                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8902             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8903                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8904             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8905                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8906
8907            enddo
8908       endif
8909       endif
8910       return
8911       end function ehbcorr
8912 #ifdef MOMENT
8913 !-----------------------------------------------------------------------------
8914       subroutine dipole(i,j,jj)
8915 !      implicit real*8 (a-h,o-z)
8916 !      include 'DIMENSIONS'
8917 !      include 'COMMON.IOUNITS'
8918 !      include 'COMMON.CHAIN'
8919 !      include 'COMMON.FFIELD'
8920 !      include 'COMMON.DERIV'
8921 !      include 'COMMON.INTERACT'
8922 !      include 'COMMON.CONTACTS'
8923 !      include 'COMMON.TORSION'
8924 !      include 'COMMON.VAR'
8925 !      include 'COMMON.GEO'
8926       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8927       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8928       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8929
8930       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8931       allocate(dipderx(3,5,4,maxconts,nres))
8932 !
8933
8934       iti1 = itortyp(itype(i+1,1))
8935       if (j.lt.nres-1) then
8936         itj1 = itype2loc(itype(j+1,1))
8937       else
8938         itj1=nloctyp
8939       endif
8940       do iii=1,2
8941         dipi(iii,1)=Ub2(iii,i)
8942         dipderi(iii)=Ub2der(iii,i)
8943         dipi(iii,2)=b1(iii,iti1)
8944         dipj(iii,1)=Ub2(iii,j)
8945         dipderj(iii)=Ub2der(iii,j)
8946         dipj(iii,2)=b1(iii,itj1)
8947       enddo
8948       kkk=0
8949       do iii=1,2
8950         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8951         do jjj=1,2
8952           kkk=kkk+1
8953           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8954         enddo
8955       enddo
8956       do kkk=1,5
8957         do lll=1,3
8958           mmm=0
8959           do iii=1,2
8960             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8961               auxvec(1))
8962             do jjj=1,2
8963               mmm=mmm+1
8964               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8965             enddo
8966           enddo
8967         enddo
8968       enddo
8969       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8970       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8971       do iii=1,2
8972         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8973       enddo
8974       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8975       do iii=1,2
8976         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8977       enddo
8978       return
8979       end subroutine dipole
8980 #endif
8981 !-----------------------------------------------------------------------------
8982       subroutine calc_eello(i,j,k,l,jj,kk)
8983 !
8984 ! This subroutine computes matrices and vectors needed to calculate
8985 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8986 !
8987       use comm_kut
8988 !      implicit real*8 (a-h,o-z)
8989 !      include 'DIMENSIONS'
8990 !      include 'COMMON.IOUNITS'
8991 !      include 'COMMON.CHAIN'
8992 !      include 'COMMON.DERIV'
8993 !      include 'COMMON.INTERACT'
8994 !      include 'COMMON.CONTACTS'
8995 !      include 'COMMON.TORSION'
8996 !      include 'COMMON.VAR'
8997 !      include 'COMMON.GEO'
8998 !      include 'COMMON.FFIELD'
8999       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9000       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9001       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9002               itj1
9003 !el      logical :: lprn
9004 !el      common /kutas/ lprn
9005 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9006 !d     & ' jj=',jj,' kk=',kk
9007 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9008 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9009 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9010       do iii=1,2
9011         do jjj=1,2
9012           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9013           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9014         enddo
9015       enddo
9016       call transpose2(aa1(1,1),aa1t(1,1))
9017       call transpose2(aa2(1,1),aa2t(1,1))
9018       do kkk=1,5
9019         do lll=1,3
9020           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9021             aa1tder(1,1,lll,kkk))
9022           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9023             aa2tder(1,1,lll,kkk))
9024         enddo
9025       enddo
9026       if (l.eq.j+1) then
9027 ! parallel orientation of the two CA-CA-CA frames.
9028         if (i.gt.1) then
9029           iti=itortyp(itype(i,1))
9030         else
9031           iti=ntortyp+1
9032         endif
9033         itk1=itortyp(itype(k+1,1))
9034         itj=itortyp(itype(j,1))
9035         if (l.lt.nres-1) then
9036           itl1=itortyp(itype(l+1,1))
9037         else
9038           itl1=ntortyp+1
9039         endif
9040 ! A1 kernel(j+1) A2T
9041 !d        do iii=1,2
9042 !d          write (iout,'(3f10.5,5x,3f10.5)')
9043 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9044 !d        enddo
9045         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9046          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9047          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9048 ! Following matrices are needed only for 6-th order cumulants
9049         IF (wcorr6.gt.0.0d0) THEN
9050         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9051          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9052          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9054          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9055          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9056          ADtEAderx(1,1,1,1,1,1))
9057         lprn=.false.
9058         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9059          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9060          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9061          ADtEA1derx(1,1,1,1,1,1))
9062         ENDIF
9063 ! End 6-th order cumulants
9064 !d        lprn=.false.
9065 !d        if (lprn) then
9066 !d        write (2,*) 'In calc_eello6'
9067 !d        do iii=1,2
9068 !d          write (2,*) 'iii=',iii
9069 !d          do kkk=1,5
9070 !d            write (2,*) 'kkk=',kkk
9071 !d            do jjj=1,2
9072 !d              write (2,'(3(2f10.5),5x)')
9073 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9074 !d            enddo
9075 !d          enddo
9076 !d        enddo
9077 !d        endif
9078         call transpose2(EUgder(1,1,k),auxmat(1,1))
9079         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9080         call transpose2(EUg(1,1,k),auxmat(1,1))
9081         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9082         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9083         do iii=1,2
9084           do kkk=1,5
9085             do lll=1,3
9086               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9087                 EAEAderx(1,1,lll,kkk,iii,1))
9088             enddo
9089           enddo
9090         enddo
9091 ! A1T kernel(i+1) A2
9092         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9093          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9094          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9095 ! Following matrices are needed only for 6-th order cumulants
9096         IF (wcorr6.gt.0.0d0) THEN
9097         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9098          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9099          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9100         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9101          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9102          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9103          ADtEAderx(1,1,1,1,1,2))
9104         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9105          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9106          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9107          ADtEA1derx(1,1,1,1,1,2))
9108         ENDIF
9109 ! End 6-th order cumulants
9110         call transpose2(EUgder(1,1,l),auxmat(1,1))
9111         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9112         call transpose2(EUg(1,1,l),auxmat(1,1))
9113         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9114         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9115         do iii=1,2
9116           do kkk=1,5
9117             do lll=1,3
9118               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9119                 EAEAderx(1,1,lll,kkk,iii,2))
9120             enddo
9121           enddo
9122         enddo
9123 ! AEAb1 and AEAb2
9124 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9125 ! They are needed only when the fifth- or the sixth-order cumulants are
9126 ! indluded.
9127         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9128         call transpose2(AEA(1,1,1),auxmat(1,1))
9129         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9130         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9131         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9132         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9133         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9134         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9135         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9136         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9137         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9138         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9139         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9140         call transpose2(AEA(1,1,2),auxmat(1,1))
9141         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9142         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9143         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9144         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9145         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9146         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9147         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9148         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9149         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9150         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9151         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9152 ! Calculate the Cartesian derivatives of the vectors.
9153         do iii=1,2
9154           do kkk=1,5
9155             do lll=1,3
9156               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9157               call matvec2(auxmat(1,1),b1(1,iti),&
9158                 AEAb1derx(1,lll,kkk,iii,1,1))
9159               call matvec2(auxmat(1,1),Ub2(1,i),&
9160                 AEAb2derx(1,lll,kkk,iii,1,1))
9161               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9162                 AEAb1derx(1,lll,kkk,iii,2,1))
9163               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9164                 AEAb2derx(1,lll,kkk,iii,2,1))
9165               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9166               call matvec2(auxmat(1,1),b1(1,itj),&
9167                 AEAb1derx(1,lll,kkk,iii,1,2))
9168               call matvec2(auxmat(1,1),Ub2(1,j),&
9169                 AEAb2derx(1,lll,kkk,iii,1,2))
9170               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9171                 AEAb1derx(1,lll,kkk,iii,2,2))
9172               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9173                 AEAb2derx(1,lll,kkk,iii,2,2))
9174             enddo
9175           enddo
9176         enddo
9177         ENDIF
9178 ! End vectors
9179       else
9180 ! Antiparallel orientation of the two CA-CA-CA frames.
9181         if (i.gt.1) then
9182           iti=itortyp(itype(i,1))
9183         else
9184           iti=ntortyp+1
9185         endif
9186         itk1=itortyp(itype(k+1,1))
9187         itl=itortyp(itype(l,1))
9188         itj=itortyp(itype(j,1))
9189         if (j.lt.nres-1) then
9190           itj1=itortyp(itype(j+1,1))
9191         else
9192           itj1=ntortyp+1
9193         endif
9194 ! A2 kernel(j-1)T A1T
9195         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9196          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9197          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9198 ! Following matrices are needed only for 6-th order cumulants
9199         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9200            j.eq.i+4 .and. l.eq.i+3)) THEN
9201         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9202          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9203          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9204         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9205          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9206          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9207          ADtEAderx(1,1,1,1,1,1))
9208         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9209          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9210          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9211          ADtEA1derx(1,1,1,1,1,1))
9212         ENDIF
9213 ! End 6-th order cumulants
9214         call transpose2(EUgder(1,1,k),auxmat(1,1))
9215         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9216         call transpose2(EUg(1,1,k),auxmat(1,1))
9217         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9218         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9219         do iii=1,2
9220           do kkk=1,5
9221             do lll=1,3
9222               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9223                 EAEAderx(1,1,lll,kkk,iii,1))
9224             enddo
9225           enddo
9226         enddo
9227 ! A2T kernel(i+1)T A1
9228         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9229          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9230          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9231 ! Following matrices are needed only for 6-th order cumulants
9232         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9233            j.eq.i+4 .and. l.eq.i+3)) THEN
9234         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9235          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9236          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9237         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9238          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9239          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9240          ADtEAderx(1,1,1,1,1,2))
9241         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9242          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9243          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9244          ADtEA1derx(1,1,1,1,1,2))
9245         ENDIF
9246 ! End 6-th order cumulants
9247         call transpose2(EUgder(1,1,j),auxmat(1,1))
9248         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9249         call transpose2(EUg(1,1,j),auxmat(1,1))
9250         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9251         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9252         do iii=1,2
9253           do kkk=1,5
9254             do lll=1,3
9255               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9256                 EAEAderx(1,1,lll,kkk,iii,2))
9257             enddo
9258           enddo
9259         enddo
9260 ! AEAb1 and AEAb2
9261 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9262 ! They are needed only when the fifth- or the sixth-order cumulants are
9263 ! indluded.
9264         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9265           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9266         call transpose2(AEA(1,1,1),auxmat(1,1))
9267         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9268         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9269         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9270         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9271         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9272         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9273         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9274         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9275         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9276         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9277         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9278         call transpose2(AEA(1,1,2),auxmat(1,1))
9279         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9280         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9281         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9282         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9283         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9284         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9285         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9286         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9287         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9288         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9289         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9290 ! Calculate the Cartesian derivatives of the vectors.
9291         do iii=1,2
9292           do kkk=1,5
9293             do lll=1,3
9294               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9295               call matvec2(auxmat(1,1),b1(1,iti),&
9296                 AEAb1derx(1,lll,kkk,iii,1,1))
9297               call matvec2(auxmat(1,1),Ub2(1,i),&
9298                 AEAb2derx(1,lll,kkk,iii,1,1))
9299               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9300                 AEAb1derx(1,lll,kkk,iii,2,1))
9301               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9302                 AEAb2derx(1,lll,kkk,iii,2,1))
9303               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9304               call matvec2(auxmat(1,1),b1(1,itl),&
9305                 AEAb1derx(1,lll,kkk,iii,1,2))
9306               call matvec2(auxmat(1,1),Ub2(1,l),&
9307                 AEAb2derx(1,lll,kkk,iii,1,2))
9308               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9309                 AEAb1derx(1,lll,kkk,iii,2,2))
9310               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9311                 AEAb2derx(1,lll,kkk,iii,2,2))
9312             enddo
9313           enddo
9314         enddo
9315         ENDIF
9316 ! End vectors
9317       endif
9318       return
9319       end subroutine calc_eello
9320 !-----------------------------------------------------------------------------
9321       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9322       use comm_kut
9323       implicit none
9324       integer :: nderg
9325       logical :: transp
9326       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9327       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9328       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9329       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9330       integer :: iii,kkk,lll
9331       integer :: jjj,mmm
9332 !el      logical :: lprn
9333 !el      common /kutas/ lprn
9334       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9335       do iii=1,nderg
9336         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9337           AKAderg(1,1,iii))
9338       enddo
9339 !d      if (lprn) write (2,*) 'In kernel'
9340       do kkk=1,5
9341 !d        if (lprn) write (2,*) 'kkk=',kkk
9342         do lll=1,3
9343           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9344             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9345 !d          if (lprn) then
9346 !d            write (2,*) 'lll=',lll
9347 !d            write (2,*) 'iii=1'
9348 !d            do jjj=1,2
9349 !d              write (2,'(3(2f10.5),5x)')
9350 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9351 !d            enddo
9352 !d          endif
9353           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9354             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9355 !d          if (lprn) then
9356 !d            write (2,*) 'lll=',lll
9357 !d            write (2,*) 'iii=2'
9358 !d            do jjj=1,2
9359 !d              write (2,'(3(2f10.5),5x)')
9360 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9361 !d            enddo
9362 !d          endif
9363         enddo
9364       enddo
9365       return
9366       end subroutine kernel
9367 !-----------------------------------------------------------------------------
9368       real(kind=8) function eello4(i,j,k,l,jj,kk)
9369 !      implicit real*8 (a-h,o-z)
9370 !      include 'DIMENSIONS'
9371 !      include 'COMMON.IOUNITS'
9372 !      include 'COMMON.CHAIN'
9373 !      include 'COMMON.DERIV'
9374 !      include 'COMMON.INTERACT'
9375 !      include 'COMMON.CONTACTS'
9376 !      include 'COMMON.TORSION'
9377 !      include 'COMMON.VAR'
9378 !      include 'COMMON.GEO'
9379       real(kind=8),dimension(2,2) :: pizda
9380       real(kind=8),dimension(3) :: ggg1,ggg2
9381       real(kind=8) ::  eel4,glongij,glongkl
9382       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9383 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9384 !d        eello4=0.0d0
9385 !d        return
9386 !d      endif
9387 !d      print *,'eello4:',i,j,k,l,jj,kk
9388 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9389 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9390 !old      eij=facont_hb(jj,i)
9391 !old      ekl=facont_hb(kk,k)
9392 !old      ekont=eij*ekl
9393       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9394 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9395       gcorr_loc(k-1)=gcorr_loc(k-1) &
9396          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9397       if (l.eq.j+1) then
9398         gcorr_loc(l-1)=gcorr_loc(l-1) &
9399            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9400       else
9401         gcorr_loc(j-1)=gcorr_loc(j-1) &
9402            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9403       endif
9404       do iii=1,2
9405         do kkk=1,5
9406           do lll=1,3
9407             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9408                               -EAEAderx(2,2,lll,kkk,iii,1)
9409 !d            derx(lll,kkk,iii)=0.0d0
9410           enddo
9411         enddo
9412       enddo
9413 !d      gcorr_loc(l-1)=0.0d0
9414 !d      gcorr_loc(j-1)=0.0d0
9415 !d      gcorr_loc(k-1)=0.0d0
9416 !d      eel4=1.0d0
9417 !d      write (iout,*)'Contacts have occurred for peptide groups',
9418 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9419 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9420       if (j.lt.nres-1) then
9421         j1=j+1
9422         j2=j-1
9423       else
9424         j1=j-1
9425         j2=j-2
9426       endif
9427       if (l.lt.nres-1) then
9428         l1=l+1
9429         l2=l-1
9430       else
9431         l1=l-1
9432         l2=l-2
9433       endif
9434       do ll=1,3
9435 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9436 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9437         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9438         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9439 !grad        ghalf=0.5d0*ggg1(ll)
9440         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9441         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9442         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9443         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9444         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9445         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9446 !grad        ghalf=0.5d0*ggg2(ll)
9447         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9448         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9449         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9450         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9451         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9452         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9453       enddo
9454 !grad      do m=i+1,j-1
9455 !grad        do ll=1,3
9456 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9457 !grad        enddo
9458 !grad      enddo
9459 !grad      do m=k+1,l-1
9460 !grad        do ll=1,3
9461 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9462 !grad        enddo
9463 !grad      enddo
9464 !grad      do m=i+2,j2
9465 !grad        do ll=1,3
9466 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9467 !grad        enddo
9468 !grad      enddo
9469 !grad      do m=k+2,l2
9470 !grad        do ll=1,3
9471 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9472 !grad        enddo
9473 !grad      enddo
9474 !d      do iii=1,nres-3
9475 !d        write (2,*) iii,gcorr_loc(iii)
9476 !d      enddo
9477       eello4=ekont*eel4
9478 !d      write (2,*) 'ekont',ekont
9479 !d      write (iout,*) 'eello4',ekont*eel4
9480       return
9481       end function eello4
9482 !-----------------------------------------------------------------------------
9483       real(kind=8) function eello5(i,j,k,l,jj,kk)
9484 !      implicit real*8 (a-h,o-z)
9485 !      include 'DIMENSIONS'
9486 !      include 'COMMON.IOUNITS'
9487 !      include 'COMMON.CHAIN'
9488 !      include 'COMMON.DERIV'
9489 !      include 'COMMON.INTERACT'
9490 !      include 'COMMON.CONTACTS'
9491 !      include 'COMMON.TORSION'
9492 !      include 'COMMON.VAR'
9493 !      include 'COMMON.GEO'
9494       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9495       real(kind=8),dimension(2) :: vv
9496       real(kind=8),dimension(3) :: ggg1,ggg2
9497       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9498       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9499       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9500 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9501 !                                                                              C
9502 !                            Parallel chains                                   C
9503 !                                                                              C
9504 !          o             o                   o             o                   C
9505 !         /l\           / \             \   / \           / \   /              C
9506 !        /   \         /   \             \ /   \         /   \ /               C
9507 !       j| o |l1       | o |                o| o |         | o |o                C
9508 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9509 !      \i/   \         /   \ /             /   \         /   \                 C
9510 !       o    k1             o                                                  C
9511 !         (I)          (II)                (III)          (IV)                 C
9512 !                                                                              C
9513 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9514 !                                                                              C
9515 !                            Antiparallel chains                               C
9516 !                                                                              C
9517 !          o             o                   o             o                   C
9518 !         /j\           / \             \   / \           / \   /              C
9519 !        /   \         /   \             \ /   \         /   \ /               C
9520 !      j1| o |l        | o |                o| o |         | o |o                C
9521 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9522 !      \i/   \         /   \ /             /   \         /   \                 C
9523 !       o     k1            o                                                  C
9524 !         (I)          (II)                (III)          (IV)                 C
9525 !                                                                              C
9526 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9527 !                                                                              C
9528 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9529 !                                                                              C
9530 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9531 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9532 !d        eello5=0.0d0
9533 !d        return
9534 !d      endif
9535 !d      write (iout,*)
9536 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9537 !d     &   ' and',k,l
9538       itk=itortyp(itype(k,1))
9539       itl=itortyp(itype(l,1))
9540       itj=itortyp(itype(j,1))
9541       eello5_1=0.0d0
9542       eello5_2=0.0d0
9543       eello5_3=0.0d0
9544       eello5_4=0.0d0
9545 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9546 !d     &   eel5_3_num,eel5_4_num)
9547       do iii=1,2
9548         do kkk=1,5
9549           do lll=1,3
9550             derx(lll,kkk,iii)=0.0d0
9551           enddo
9552         enddo
9553       enddo
9554 !d      eij=facont_hb(jj,i)
9555 !d      ekl=facont_hb(kk,k)
9556 !d      ekont=eij*ekl
9557 !d      write (iout,*)'Contacts have occurred for peptide groups',
9558 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9559 !d      goto 1111
9560 ! Contribution from the graph I.
9561 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9562 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9563       call transpose2(EUg(1,1,k),auxmat(1,1))
9564       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9565       vv(1)=pizda(1,1)-pizda(2,2)
9566       vv(2)=pizda(1,2)+pizda(2,1)
9567       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9568        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9569 ! Explicit gradient in virtual-dihedral angles.
9570       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9571        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9572        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9573       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9574       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9575       vv(1)=pizda(1,1)-pizda(2,2)
9576       vv(2)=pizda(1,2)+pizda(2,1)
9577       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9578        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9579        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9580       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9581       vv(1)=pizda(1,1)-pizda(2,2)
9582       vv(2)=pizda(1,2)+pizda(2,1)
9583       if (l.eq.j+1) then
9584         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9585          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9586          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9587       else
9588         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9589          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9590          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9591       endif
9592 ! Cartesian gradient
9593       do iii=1,2
9594         do kkk=1,5
9595           do lll=1,3
9596             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9597               pizda(1,1))
9598             vv(1)=pizda(1,1)-pizda(2,2)
9599             vv(2)=pizda(1,2)+pizda(2,1)
9600             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9601              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9602              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9603           enddo
9604         enddo
9605       enddo
9606 !      goto 1112
9607 !1111  continue
9608 ! Contribution from graph II
9609       call transpose2(EE(1,1,itk),auxmat(1,1))
9610       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9611       vv(1)=pizda(1,1)+pizda(2,2)
9612       vv(2)=pizda(2,1)-pizda(1,2)
9613       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9614        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9615 ! Explicit gradient in virtual-dihedral angles.
9616       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9617        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9618       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9619       vv(1)=pizda(1,1)+pizda(2,2)
9620       vv(2)=pizda(2,1)-pizda(1,2)
9621       if (l.eq.j+1) then
9622         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9623          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9624          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9625       else
9626         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9627          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9628          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9629       endif
9630 ! Cartesian gradient
9631       do iii=1,2
9632         do kkk=1,5
9633           do lll=1,3
9634             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9635               pizda(1,1))
9636             vv(1)=pizda(1,1)+pizda(2,2)
9637             vv(2)=pizda(2,1)-pizda(1,2)
9638             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9639              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9640              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9641           enddo
9642         enddo
9643       enddo
9644 !d      goto 1112
9645 !d1111  continue
9646       if (l.eq.j+1) then
9647 !d        goto 1110
9648 ! Parallel orientation
9649 ! Contribution from graph III
9650         call transpose2(EUg(1,1,l),auxmat(1,1))
9651         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9652         vv(1)=pizda(1,1)-pizda(2,2)
9653         vv(2)=pizda(1,2)+pizda(2,1)
9654         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9655          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9656 ! Explicit gradient in virtual-dihedral angles.
9657         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9658          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9659          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9660         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9661         vv(1)=pizda(1,1)-pizda(2,2)
9662         vv(2)=pizda(1,2)+pizda(2,1)
9663         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9664          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9665          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9666         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9667         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9668         vv(1)=pizda(1,1)-pizda(2,2)
9669         vv(2)=pizda(1,2)+pizda(2,1)
9670         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9671          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9672          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9673 ! Cartesian gradient
9674         do iii=1,2
9675           do kkk=1,5
9676             do lll=1,3
9677               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9678                 pizda(1,1))
9679               vv(1)=pizda(1,1)-pizda(2,2)
9680               vv(2)=pizda(1,2)+pizda(2,1)
9681               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9682                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9683                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9684             enddo
9685           enddo
9686         enddo
9687 !d        goto 1112
9688 ! Contribution from graph IV
9689 !d1110    continue
9690         call transpose2(EE(1,1,itl),auxmat(1,1))
9691         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9692         vv(1)=pizda(1,1)+pizda(2,2)
9693         vv(2)=pizda(2,1)-pizda(1,2)
9694         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9695          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9696 ! Explicit gradient in virtual-dihedral angles.
9697         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9698          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9699         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9700         vv(1)=pizda(1,1)+pizda(2,2)
9701         vv(2)=pizda(2,1)-pizda(1,2)
9702         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9703          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9704          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9705 ! Cartesian gradient
9706         do iii=1,2
9707           do kkk=1,5
9708             do lll=1,3
9709               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9710                 pizda(1,1))
9711               vv(1)=pizda(1,1)+pizda(2,2)
9712               vv(2)=pizda(2,1)-pizda(1,2)
9713               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9714                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9715                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9716             enddo
9717           enddo
9718         enddo
9719       else
9720 ! Antiparallel orientation
9721 ! Contribution from graph III
9722 !        goto 1110
9723         call transpose2(EUg(1,1,j),auxmat(1,1))
9724         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9725         vv(1)=pizda(1,1)-pizda(2,2)
9726         vv(2)=pizda(1,2)+pizda(2,1)
9727         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9728          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9729 ! Explicit gradient in virtual-dihedral angles.
9730         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9731          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9732          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9733         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9734         vv(1)=pizda(1,1)-pizda(2,2)
9735         vv(2)=pizda(1,2)+pizda(2,1)
9736         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9737          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9738          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9739         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9740         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9741         vv(1)=pizda(1,1)-pizda(2,2)
9742         vv(2)=pizda(1,2)+pizda(2,1)
9743         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9744          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9745          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9746 ! Cartesian gradient
9747         do iii=1,2
9748           do kkk=1,5
9749             do lll=1,3
9750               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9751                 pizda(1,1))
9752               vv(1)=pizda(1,1)-pizda(2,2)
9753               vv(2)=pizda(1,2)+pizda(2,1)
9754               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9755                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9756                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9757             enddo
9758           enddo
9759         enddo
9760 !d        goto 1112
9761 ! Contribution from graph IV
9762 1110    continue
9763         call transpose2(EE(1,1,itj),auxmat(1,1))
9764         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9765         vv(1)=pizda(1,1)+pizda(2,2)
9766         vv(2)=pizda(2,1)-pizda(1,2)
9767         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9768          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9769 ! Explicit gradient in virtual-dihedral angles.
9770         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9771          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9772         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9773         vv(1)=pizda(1,1)+pizda(2,2)
9774         vv(2)=pizda(2,1)-pizda(1,2)
9775         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9776          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9777          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9778 ! Cartesian gradient
9779         do iii=1,2
9780           do kkk=1,5
9781             do lll=1,3
9782               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9783                 pizda(1,1))
9784               vv(1)=pizda(1,1)+pizda(2,2)
9785               vv(2)=pizda(2,1)-pizda(1,2)
9786               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9787                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9788                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9789             enddo
9790           enddo
9791         enddo
9792       endif
9793 1112  continue
9794       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9795 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9796 !d        write (2,*) 'ijkl',i,j,k,l
9797 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9798 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9799 !d      endif
9800 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9801 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9802 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9803 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9804       if (j.lt.nres-1) then
9805         j1=j+1
9806         j2=j-1
9807       else
9808         j1=j-1
9809         j2=j-2
9810       endif
9811       if (l.lt.nres-1) then
9812         l1=l+1
9813         l2=l-1
9814       else
9815         l1=l-1
9816         l2=l-2
9817       endif
9818 !d      eij=1.0d0
9819 !d      ekl=1.0d0
9820 !d      ekont=1.0d0
9821 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9822 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9823 !        summed up outside the subrouine as for the other subroutines
9824 !        handling long-range interactions. The old code is commented out
9825 !        with "cgrad" to keep track of changes.
9826       do ll=1,3
9827 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9828 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9829         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9830         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9831 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9832 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9833 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9834 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9835 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9836 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9837 !     &   gradcorr5ij,
9838 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9839 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9840 !grad        ghalf=0.5d0*ggg1(ll)
9841 !d        ghalf=0.0d0
9842         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9843         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9844         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9845         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9846         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9847         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9848 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9849 !grad        ghalf=0.5d0*ggg2(ll)
9850         ghalf=0.0d0
9851         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9852         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9853         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9854         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9855         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9856         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9857       enddo
9858 !d      goto 1112
9859 !grad      do m=i+1,j-1
9860 !grad        do ll=1,3
9861 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9862 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9863 !grad        enddo
9864 !grad      enddo
9865 !grad      do m=k+1,l-1
9866 !grad        do ll=1,3
9867 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9868 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9869 !grad        enddo
9870 !grad      enddo
9871 !1112  continue
9872 !grad      do m=i+2,j2
9873 !grad        do ll=1,3
9874 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9875 !grad        enddo
9876 !grad      enddo
9877 !grad      do m=k+2,l2
9878 !grad        do ll=1,3
9879 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9880 !grad        enddo
9881 !grad      enddo
9882 !d      do iii=1,nres-3
9883 !d        write (2,*) iii,g_corr5_loc(iii)
9884 !d      enddo
9885       eello5=ekont*eel5
9886 !d      write (2,*) 'ekont',ekont
9887 !d      write (iout,*) 'eello5',ekont*eel5
9888       return
9889       end function eello5
9890 !-----------------------------------------------------------------------------
9891       real(kind=8) function eello6(i,j,k,l,jj,kk)
9892 !      implicit real*8 (a-h,o-z)
9893 !      include 'DIMENSIONS'
9894 !      include 'COMMON.IOUNITS'
9895 !      include 'COMMON.CHAIN'
9896 !      include 'COMMON.DERIV'
9897 !      include 'COMMON.INTERACT'
9898 !      include 'COMMON.CONTACTS'
9899 !      include 'COMMON.TORSION'
9900 !      include 'COMMON.VAR'
9901 !      include 'COMMON.GEO'
9902 !      include 'COMMON.FFIELD'
9903       real(kind=8),dimension(3) :: ggg1,ggg2
9904       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9905                    eello6_6,eel6
9906       real(kind=8) :: gradcorr6ij,gradcorr6kl
9907       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9908 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9909 !d        eello6=0.0d0
9910 !d        return
9911 !d      endif
9912 !d      write (iout,*)
9913 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9914 !d     &   ' and',k,l
9915       eello6_1=0.0d0
9916       eello6_2=0.0d0
9917       eello6_3=0.0d0
9918       eello6_4=0.0d0
9919       eello6_5=0.0d0
9920       eello6_6=0.0d0
9921 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9922 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9923       do iii=1,2
9924         do kkk=1,5
9925           do lll=1,3
9926             derx(lll,kkk,iii)=0.0d0
9927           enddo
9928         enddo
9929       enddo
9930 !d      eij=facont_hb(jj,i)
9931 !d      ekl=facont_hb(kk,k)
9932 !d      ekont=eij*ekl
9933 !d      eij=1.0d0
9934 !d      ekl=1.0d0
9935 !d      ekont=1.0d0
9936       if (l.eq.j+1) then
9937         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9938         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9939         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9940         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9941         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9942         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9943       else
9944         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9945         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9946         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9947         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9948         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9949           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9950         else
9951           eello6_5=0.0d0
9952         endif
9953         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9954       endif
9955 ! If turn contributions are considered, they will be handled separately.
9956       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9957 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9958 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9959 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9960 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9961 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9962 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9963 !d      goto 1112
9964       if (j.lt.nres-1) then
9965         j1=j+1
9966         j2=j-1
9967       else
9968         j1=j-1
9969         j2=j-2
9970       endif
9971       if (l.lt.nres-1) then
9972         l1=l+1
9973         l2=l-1
9974       else
9975         l1=l-1
9976         l2=l-2
9977       endif
9978       do ll=1,3
9979 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9980 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9981 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9982 !grad        ghalf=0.5d0*ggg1(ll)
9983 !d        ghalf=0.0d0
9984         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9985         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9986         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9987         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9988         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9989         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9990         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9991         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9992 !grad        ghalf=0.5d0*ggg2(ll)
9993 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9994 !d        ghalf=0.0d0
9995         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9996         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9997         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9998         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9999         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10000         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10001       enddo
10002 !d      goto 1112
10003 !grad      do m=i+1,j-1
10004 !grad        do ll=1,3
10005 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10006 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10007 !grad        enddo
10008 !grad      enddo
10009 !grad      do m=k+1,l-1
10010 !grad        do ll=1,3
10011 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10012 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10013 !grad        enddo
10014 !grad      enddo
10015 !grad1112  continue
10016 !grad      do m=i+2,j2
10017 !grad        do ll=1,3
10018 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10019 !grad        enddo
10020 !grad      enddo
10021 !grad      do m=k+2,l2
10022 !grad        do ll=1,3
10023 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10024 !grad        enddo
10025 !grad      enddo
10026 !d      do iii=1,nres-3
10027 !d        write (2,*) iii,g_corr6_loc(iii)
10028 !d      enddo
10029       eello6=ekont*eel6
10030 !d      write (2,*) 'ekont',ekont
10031 !d      write (iout,*) 'eello6',ekont*eel6
10032       return
10033       end function eello6
10034 !-----------------------------------------------------------------------------
10035       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10036       use comm_kut
10037 !      implicit real*8 (a-h,o-z)
10038 !      include 'DIMENSIONS'
10039 !      include 'COMMON.IOUNITS'
10040 !      include 'COMMON.CHAIN'
10041 !      include 'COMMON.DERIV'
10042 !      include 'COMMON.INTERACT'
10043 !      include 'COMMON.CONTACTS'
10044 !      include 'COMMON.TORSION'
10045 !      include 'COMMON.VAR'
10046 !      include 'COMMON.GEO'
10047       real(kind=8),dimension(2) :: vv,vv1
10048       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10049       logical :: swap
10050 !el      logical :: lprn
10051 !el      common /kutas/ lprn
10052       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10053       real(kind=8) :: s1,s2,s3,s4,s5
10054 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10055 !                                                                              C
10056 !      Parallel       Antiparallel                                             C
10057 !                                                                              C
10058 !          o             o                                                     C
10059 !         /l\           /j\                                                    C
10060 !        /   \         /   \                                                   C
10061 !       /| o |         | o |\                                                  C
10062 !     \ j|/k\|  /   \  |/k\|l /                                                C
10063 !      \ /   \ /     \ /   \ /                                                 C
10064 !       o     o       o     o                                                  C
10065 !       i             i                                                        C
10066 !                                                                              C
10067 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10068       itk=itortyp(itype(k,1))
10069       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10070       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10071       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10072       call transpose2(EUgC(1,1,k),auxmat(1,1))
10073       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10074       vv1(1)=pizda1(1,1)-pizda1(2,2)
10075       vv1(2)=pizda1(1,2)+pizda1(2,1)
10076       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10077       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10078       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10079       s5=scalar2(vv(1),Dtobr2(1,i))
10080 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10081       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10082       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10083        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10084        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10085        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10086        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10087        +scalar2(vv(1),Dtobr2der(1,i)))
10088       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10089       vv1(1)=pizda1(1,1)-pizda1(2,2)
10090       vv1(2)=pizda1(1,2)+pizda1(2,1)
10091       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10092       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10093       if (l.eq.j+1) then
10094         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10095        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10096        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10097        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10098        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10099       else
10100         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10101        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10102        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10103        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10104        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10105       endif
10106       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10107       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10108       vv1(1)=pizda1(1,1)-pizda1(2,2)
10109       vv1(2)=pizda1(1,2)+pizda1(2,1)
10110       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10111        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10112        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10113        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10114       do iii=1,2
10115         if (swap) then
10116           ind=3-iii
10117         else
10118           ind=iii
10119         endif
10120         do kkk=1,5
10121           do lll=1,3
10122             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10123             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10124             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10125             call transpose2(EUgC(1,1,k),auxmat(1,1))
10126             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10127               pizda1(1,1))
10128             vv1(1)=pizda1(1,1)-pizda1(2,2)
10129             vv1(2)=pizda1(1,2)+pizda1(2,1)
10130             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10131             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10132              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10133             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10134              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10135             s5=scalar2(vv(1),Dtobr2(1,i))
10136             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10137           enddo
10138         enddo
10139       enddo
10140       return
10141       end function eello6_graph1
10142 !-----------------------------------------------------------------------------
10143       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10144       use comm_kut
10145 !      implicit real*8 (a-h,o-z)
10146 !      include 'DIMENSIONS'
10147 !      include 'COMMON.IOUNITS'
10148 !      include 'COMMON.CHAIN'
10149 !      include 'COMMON.DERIV'
10150 !      include 'COMMON.INTERACT'
10151 !      include 'COMMON.CONTACTS'
10152 !      include 'COMMON.TORSION'
10153 !      include 'COMMON.VAR'
10154 !      include 'COMMON.GEO'
10155       logical :: swap
10156       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10157       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10158 !el      logical :: lprn
10159 !el      common /kutas/ lprn
10160       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10161       real(kind=8) :: s2,s3,s4
10162 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10163 !                                                                              C
10164 !      Parallel       Antiparallel                                             C
10165 !                                                                              C
10166 !          o             o                                                     C
10167 !     \   /l\           /j\   /                                                C
10168 !      \ /   \         /   \ /                                                 C
10169 !       o| o |         | o |o                                                  C
10170 !     \ j|/k\|      \  |/k\|l                                                  C
10171 !      \ /   \       \ /   \                                                   C
10172 !       o             o                                                        C
10173 !       i             i                                                        C
10174 !                                                                              C
10175 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10176 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10177 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10178 !           but not in a cluster cumulant
10179 #ifdef MOMENT
10180       s1=dip(1,jj,i)*dip(1,kk,k)
10181 #endif
10182       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10183       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10184       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10185       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10186       call transpose2(EUg(1,1,k),auxmat(1,1))
10187       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10188       vv(1)=pizda(1,1)-pizda(2,2)
10189       vv(2)=pizda(1,2)+pizda(2,1)
10190       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10191 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10192 #ifdef MOMENT
10193       eello6_graph2=-(s1+s2+s3+s4)
10194 #else
10195       eello6_graph2=-(s2+s3+s4)
10196 #endif
10197 !      eello6_graph2=-s3
10198 ! Derivatives in gamma(i-1)
10199       if (i.gt.1) then
10200 #ifdef MOMENT
10201         s1=dipderg(1,jj,i)*dip(1,kk,k)
10202 #endif
10203         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10204         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10205         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10206         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10207 #ifdef MOMENT
10208         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10209 #else
10210         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10211 #endif
10212 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10213       endif
10214 ! Derivatives in gamma(k-1)
10215 #ifdef MOMENT
10216       s1=dip(1,jj,i)*dipderg(1,kk,k)
10217 #endif
10218       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10219       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10220       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10221       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10222       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10223       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10224       vv(1)=pizda(1,1)-pizda(2,2)
10225       vv(2)=pizda(1,2)+pizda(2,1)
10226       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10227 #ifdef MOMENT
10228       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10229 #else
10230       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10231 #endif
10232 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10233 ! Derivatives in gamma(j-1) or gamma(l-1)
10234       if (j.gt.1) then
10235 #ifdef MOMENT
10236         s1=dipderg(3,jj,i)*dip(1,kk,k)
10237 #endif
10238         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10239         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10240         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10241         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10242         vv(1)=pizda(1,1)-pizda(2,2)
10243         vv(2)=pizda(1,2)+pizda(2,1)
10244         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10245 #ifdef MOMENT
10246         if (swap) then
10247           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10248         else
10249           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10250         endif
10251 #endif
10252         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10253 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10254       endif
10255 ! Derivatives in gamma(l-1) or gamma(j-1)
10256       if (l.gt.1) then
10257 #ifdef MOMENT
10258         s1=dip(1,jj,i)*dipderg(3,kk,k)
10259 #endif
10260         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10261         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10262         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10263         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10264         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10265         vv(1)=pizda(1,1)-pizda(2,2)
10266         vv(2)=pizda(1,2)+pizda(2,1)
10267         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10268 #ifdef MOMENT
10269         if (swap) then
10270           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10271         else
10272           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10273         endif
10274 #endif
10275         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10276 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10277       endif
10278 ! Cartesian derivatives.
10279       if (lprn) then
10280         write (2,*) 'In eello6_graph2'
10281         do iii=1,2
10282           write (2,*) 'iii=',iii
10283           do kkk=1,5
10284             write (2,*) 'kkk=',kkk
10285             do jjj=1,2
10286               write (2,'(3(2f10.5),5x)') &
10287               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10288             enddo
10289           enddo
10290         enddo
10291       endif
10292       do iii=1,2
10293         do kkk=1,5
10294           do lll=1,3
10295 #ifdef MOMENT
10296             if (iii.eq.1) then
10297               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10298             else
10299               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10300             endif
10301 #endif
10302             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10303               auxvec(1))
10304             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10305             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10306               auxvec(1))
10307             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10308             call transpose2(EUg(1,1,k),auxmat(1,1))
10309             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10310               pizda(1,1))
10311             vv(1)=pizda(1,1)-pizda(2,2)
10312             vv(2)=pizda(1,2)+pizda(2,1)
10313             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10314 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10315 #ifdef MOMENT
10316             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10317 #else
10318             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10319 #endif
10320             if (swap) then
10321               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10322             else
10323               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10324             endif
10325           enddo
10326         enddo
10327       enddo
10328       return
10329       end function eello6_graph2
10330 !-----------------------------------------------------------------------------
10331       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10332 !      implicit real*8 (a-h,o-z)
10333 !      include 'DIMENSIONS'
10334 !      include 'COMMON.IOUNITS'
10335 !      include 'COMMON.CHAIN'
10336 !      include 'COMMON.DERIV'
10337 !      include 'COMMON.INTERACT'
10338 !      include 'COMMON.CONTACTS'
10339 !      include 'COMMON.TORSION'
10340 !      include 'COMMON.VAR'
10341 !      include 'COMMON.GEO'
10342       real(kind=8),dimension(2) :: vv,auxvec
10343       real(kind=8),dimension(2,2) :: pizda,auxmat
10344       logical :: swap
10345       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10346       real(kind=8) :: s1,s2,s3,s4
10347 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10348 !                                                                              C
10349 !      Parallel       Antiparallel                                             C
10350 !                                                                              C
10351 !          o             o                                                     C
10352 !         /l\   /   \   /j\                                                    C
10353 !        /   \ /     \ /   \                                                   C
10354 !       /| o |o       o| o |\                                                  C
10355 !       j|/k\|  /      |/k\|l /                                                C
10356 !        /   \ /       /   \ /                                                 C
10357 !       /     o       /     o                                                  C
10358 !       i             i                                                        C
10359 !                                                                              C
10360 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10361 !
10362 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10363 !           energy moment and not to the cluster cumulant.
10364       iti=itortyp(itype(i,1))
10365       if (j.lt.nres-1) then
10366         itj1=itortyp(itype(j+1,1))
10367       else
10368         itj1=ntortyp+1
10369       endif
10370       itk=itortyp(itype(k,1))
10371       itk1=itortyp(itype(k+1,1))
10372       if (l.lt.nres-1) then
10373         itl1=itortyp(itype(l+1,1))
10374       else
10375         itl1=ntortyp+1
10376       endif
10377 #ifdef MOMENT
10378       s1=dip(4,jj,i)*dip(4,kk,k)
10379 #endif
10380       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10381       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10382       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10383       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10384       call transpose2(EE(1,1,itk),auxmat(1,1))
10385       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10386       vv(1)=pizda(1,1)+pizda(2,2)
10387       vv(2)=pizda(2,1)-pizda(1,2)
10388       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10389 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10390 !d     & "sum",-(s2+s3+s4)
10391 #ifdef MOMENT
10392       eello6_graph3=-(s1+s2+s3+s4)
10393 #else
10394       eello6_graph3=-(s2+s3+s4)
10395 #endif
10396 !      eello6_graph3=-s4
10397 ! Derivatives in gamma(k-1)
10398       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10399       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10400       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10401       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10402 ! Derivatives in gamma(l-1)
10403       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10404       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10405       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10406       vv(1)=pizda(1,1)+pizda(2,2)
10407       vv(2)=pizda(2,1)-pizda(1,2)
10408       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10409       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10410 ! Cartesian derivatives.
10411       do iii=1,2
10412         do kkk=1,5
10413           do lll=1,3
10414 #ifdef MOMENT
10415             if (iii.eq.1) then
10416               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10417             else
10418               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10419             endif
10420 #endif
10421             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10422               auxvec(1))
10423             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10424             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10425               auxvec(1))
10426             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10427             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10428               pizda(1,1))
10429             vv(1)=pizda(1,1)+pizda(2,2)
10430             vv(2)=pizda(2,1)-pizda(1,2)
10431             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10432 #ifdef MOMENT
10433             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10434 #else
10435             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10436 #endif
10437             if (swap) then
10438               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10439             else
10440               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10441             endif
10442 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10443           enddo
10444         enddo
10445       enddo
10446       return
10447       end function eello6_graph3
10448 !-----------------------------------------------------------------------------
10449       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10450 !      implicit real*8 (a-h,o-z)
10451 !      include 'DIMENSIONS'
10452 !      include 'COMMON.IOUNITS'
10453 !      include 'COMMON.CHAIN'
10454 !      include 'COMMON.DERIV'
10455 !      include 'COMMON.INTERACT'
10456 !      include 'COMMON.CONTACTS'
10457 !      include 'COMMON.TORSION'
10458 !      include 'COMMON.VAR'
10459 !      include 'COMMON.GEO'
10460 !      include 'COMMON.FFIELD'
10461       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10462       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10463       logical :: swap
10464       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10465               iii,kkk,lll
10466       real(kind=8) :: s1,s2,s3,s4
10467 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10468 !                                                                              C
10469 !      Parallel       Antiparallel                                             C
10470 !                                                                              C
10471 !          o             o                                                     C
10472 !         /l\   /   \   /j\                                                    C
10473 !        /   \ /     \ /   \                                                   C
10474 !       /| o |o       o| o |\                                                  C
10475 !     \ j|/k\|      \  |/k\|l                                                  C
10476 !      \ /   \       \ /   \                                                   C
10477 !       o     \       o     \                                                  C
10478 !       i             i                                                        C
10479 !                                                                              C
10480 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10481 !
10482 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10483 !           energy moment and not to the cluster cumulant.
10484 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10485       iti=itortyp(itype(i,1))
10486       itj=itortyp(itype(j,1))
10487       if (j.lt.nres-1) then
10488         itj1=itortyp(itype(j+1,1))
10489       else
10490         itj1=ntortyp+1
10491       endif
10492       itk=itortyp(itype(k,1))
10493       if (k.lt.nres-1) then
10494         itk1=itortyp(itype(k+1,1))
10495       else
10496         itk1=ntortyp+1
10497       endif
10498       itl=itortyp(itype(l,1))
10499       if (l.lt.nres-1) then
10500         itl1=itortyp(itype(l+1,1))
10501       else
10502         itl1=ntortyp+1
10503       endif
10504 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10505 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10506 !d     & ' itl',itl,' itl1',itl1
10507 #ifdef MOMENT
10508       if (imat.eq.1) then
10509         s1=dip(3,jj,i)*dip(3,kk,k)
10510       else
10511         s1=dip(2,jj,j)*dip(2,kk,l)
10512       endif
10513 #endif
10514       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10515       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10516       if (j.eq.l+1) then
10517         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10518         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10519       else
10520         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10521         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10522       endif
10523       call transpose2(EUg(1,1,k),auxmat(1,1))
10524       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10525       vv(1)=pizda(1,1)-pizda(2,2)
10526       vv(2)=pizda(2,1)+pizda(1,2)
10527       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10528 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10529 #ifdef MOMENT
10530       eello6_graph4=-(s1+s2+s3+s4)
10531 #else
10532       eello6_graph4=-(s2+s3+s4)
10533 #endif
10534 ! Derivatives in gamma(i-1)
10535       if (i.gt.1) then
10536 #ifdef MOMENT
10537         if (imat.eq.1) then
10538           s1=dipderg(2,jj,i)*dip(3,kk,k)
10539         else
10540           s1=dipderg(4,jj,j)*dip(2,kk,l)
10541         endif
10542 #endif
10543         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10544         if (j.eq.l+1) then
10545           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10546           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10547         else
10548           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10549           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10550         endif
10551         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10552         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10553 !d          write (2,*) 'turn6 derivatives'
10554 #ifdef MOMENT
10555           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10556 #else
10557           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10558 #endif
10559         else
10560 #ifdef MOMENT
10561           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10562 #else
10563           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10564 #endif
10565         endif
10566       endif
10567 ! Derivatives in gamma(k-1)
10568 #ifdef MOMENT
10569       if (imat.eq.1) then
10570         s1=dip(3,jj,i)*dipderg(2,kk,k)
10571       else
10572         s1=dip(2,jj,j)*dipderg(4,kk,l)
10573       endif
10574 #endif
10575       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10576       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10577       if (j.eq.l+1) then
10578         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10579         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10580       else
10581         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10582         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10583       endif
10584       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10585       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10586       vv(1)=pizda(1,1)-pizda(2,2)
10587       vv(2)=pizda(2,1)+pizda(1,2)
10588       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10589       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10590 #ifdef MOMENT
10591         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10592 #else
10593         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10594 #endif
10595       else
10596 #ifdef MOMENT
10597         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10598 #else
10599         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10600 #endif
10601       endif
10602 ! Derivatives in gamma(j-1) or gamma(l-1)
10603       if (l.eq.j+1 .and. l.gt.1) then
10604         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10605         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10606         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10607         vv(1)=pizda(1,1)-pizda(2,2)
10608         vv(2)=pizda(2,1)+pizda(1,2)
10609         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10610         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10611       else if (j.gt.1) then
10612         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10613         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10614         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10615         vv(1)=pizda(1,1)-pizda(2,2)
10616         vv(2)=pizda(2,1)+pizda(1,2)
10617         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10618         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10619           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10620         else
10621           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10622         endif
10623       endif
10624 ! Cartesian derivatives.
10625       do iii=1,2
10626         do kkk=1,5
10627           do lll=1,3
10628 #ifdef MOMENT
10629             if (iii.eq.1) then
10630               if (imat.eq.1) then
10631                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10632               else
10633                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10634               endif
10635             else
10636               if (imat.eq.1) then
10637                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10638               else
10639                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10640               endif
10641             endif
10642 #endif
10643             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10644               auxvec(1))
10645             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10646             if (j.eq.l+1) then
10647               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10648                 b1(1,itj1),auxvec(1))
10649               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10650             else
10651               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10652                 b1(1,itl1),auxvec(1))
10653               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10654             endif
10655             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10656               pizda(1,1))
10657             vv(1)=pizda(1,1)-pizda(2,2)
10658             vv(2)=pizda(2,1)+pizda(1,2)
10659             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10660             if (swap) then
10661               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10662 #ifdef MOMENT
10663                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10664                    -(s1+s2+s4)
10665 #else
10666                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10667                    -(s2+s4)
10668 #endif
10669                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10670               else
10671 #ifdef MOMENT
10672                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10673 #else
10674                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10675 #endif
10676                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10677               endif
10678             else
10679 #ifdef MOMENT
10680               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10681 #else
10682               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10683 #endif
10684               if (l.eq.j+1) then
10685                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10686               else
10687                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10688               endif
10689             endif
10690           enddo
10691         enddo
10692       enddo
10693       return
10694       end function eello6_graph4
10695 !-----------------------------------------------------------------------------
10696       real(kind=8) function eello_turn6(i,jj,kk)
10697 !      implicit real*8 (a-h,o-z)
10698 !      include 'DIMENSIONS'
10699 !      include 'COMMON.IOUNITS'
10700 !      include 'COMMON.CHAIN'
10701 !      include 'COMMON.DERIV'
10702 !      include 'COMMON.INTERACT'
10703 !      include 'COMMON.CONTACTS'
10704 !      include 'COMMON.TORSION'
10705 !      include 'COMMON.VAR'
10706 !      include 'COMMON.GEO'
10707       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10708       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10709       real(kind=8),dimension(3) :: ggg1,ggg2
10710       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10711       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10712 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10713 !           the respective energy moment and not to the cluster cumulant.
10714 !el local variables
10715       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10716       integer :: j1,j2,l1,l2,ll
10717       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10718       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10719       s1=0.0d0
10720       s8=0.0d0
10721       s13=0.0d0
10722 !
10723       eello_turn6=0.0d0
10724       j=i+4
10725       k=i+1
10726       l=i+3
10727       iti=itortyp(itype(i,1))
10728       itk=itortyp(itype(k,1))
10729       itk1=itortyp(itype(k+1,1))
10730       itl=itortyp(itype(l,1))
10731       itj=itortyp(itype(j,1))
10732 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10733 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10734 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10735 !d        eello6=0.0d0
10736 !d        return
10737 !d      endif
10738 !d      write (iout,*)
10739 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10740 !d     &   ' and',k,l
10741 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10742       do iii=1,2
10743         do kkk=1,5
10744           do lll=1,3
10745             derx_turn(lll,kkk,iii)=0.0d0
10746           enddo
10747         enddo
10748       enddo
10749 !d      eij=1.0d0
10750 !d      ekl=1.0d0
10751 !d      ekont=1.0d0
10752       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10753 !d      eello6_5=0.0d0
10754 !d      write (2,*) 'eello6_5',eello6_5
10755 #ifdef MOMENT
10756       call transpose2(AEA(1,1,1),auxmat(1,1))
10757       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10758       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10759       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10760 #endif
10761       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10762       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10763       s2 = scalar2(b1(1,itk),vtemp1(1))
10764 #ifdef MOMENT
10765       call transpose2(AEA(1,1,2),atemp(1,1))
10766       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10767       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10768       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10769 #endif
10770       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10771       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10772       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10773 #ifdef MOMENT
10774       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10775       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10776       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10777       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10778       ss13 = scalar2(b1(1,itk),vtemp4(1))
10779       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10780 #endif
10781 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10782 !      s1=0.0d0
10783 !      s2=0.0d0
10784 !      s8=0.0d0
10785 !      s12=0.0d0
10786 !      s13=0.0d0
10787       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10788 ! Derivatives in gamma(i+2)
10789       s1d =0.0d0
10790       s8d =0.0d0
10791 #ifdef MOMENT
10792       call transpose2(AEA(1,1,1),auxmatd(1,1))
10793       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10794       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10795       call transpose2(AEAderg(1,1,2),atempd(1,1))
10796       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10797       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10798 #endif
10799       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10800       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10801       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10802 !      s1d=0.0d0
10803 !      s2d=0.0d0
10804 !      s8d=0.0d0
10805 !      s12d=0.0d0
10806 !      s13d=0.0d0
10807       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10808 ! Derivatives in gamma(i+3)
10809 #ifdef MOMENT
10810       call transpose2(AEA(1,1,1),auxmatd(1,1))
10811       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10812       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10813       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10814 #endif
10815       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10816       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10817       s2d = scalar2(b1(1,itk),vtemp1d(1))
10818 #ifdef MOMENT
10819       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10820       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10821 #endif
10822       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10823 #ifdef MOMENT
10824       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10825       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10826       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10827 #endif
10828 !      s1d=0.0d0
10829 !      s2d=0.0d0
10830 !      s8d=0.0d0
10831 !      s12d=0.0d0
10832 !      s13d=0.0d0
10833 #ifdef MOMENT
10834       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10835                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10836 #else
10837       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10838                     -0.5d0*ekont*(s2d+s12d)
10839 #endif
10840 ! Derivatives in gamma(i+4)
10841       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10842       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10843       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10844 #ifdef MOMENT
10845       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10846       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10847       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10848 #endif
10849 !      s1d=0.0d0
10850 !      s2d=0.0d0
10851 !      s8d=0.0d0
10852 !      s12d=0.0d0
10853 !      s13d=0.0d0
10854 #ifdef MOMENT
10855       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10856 #else
10857       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10858 #endif
10859 ! Derivatives in gamma(i+5)
10860 #ifdef MOMENT
10861       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10862       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10863       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10864 #endif
10865       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10866       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10867       s2d = scalar2(b1(1,itk),vtemp1d(1))
10868 #ifdef MOMENT
10869       call transpose2(AEA(1,1,2),atempd(1,1))
10870       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10871       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10872 #endif
10873       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10875 #ifdef MOMENT
10876       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10877       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10878       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10879 #endif
10880 !      s1d=0.0d0
10881 !      s2d=0.0d0
10882 !      s8d=0.0d0
10883 !      s12d=0.0d0
10884 !      s13d=0.0d0
10885 #ifdef MOMENT
10886       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10887                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10888 #else
10889       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10890                     -0.5d0*ekont*(s2d+s12d)
10891 #endif
10892 ! Cartesian derivatives
10893       do iii=1,2
10894         do kkk=1,5
10895           do lll=1,3
10896 #ifdef MOMENT
10897             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10898             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10899             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10900 #endif
10901             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10902             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10903                 vtemp1d(1))
10904             s2d = scalar2(b1(1,itk),vtemp1d(1))
10905 #ifdef MOMENT
10906             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10907             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10908             s8d = -(atempd(1,1)+atempd(2,2))* &
10909                  scalar2(cc(1,1,itl),vtemp2(1))
10910 #endif
10911             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10912                  auxmatd(1,1))
10913             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10914             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10915 !      s1d=0.0d0
10916 !      s2d=0.0d0
10917 !      s8d=0.0d0
10918 !      s12d=0.0d0
10919 !      s13d=0.0d0
10920 #ifdef MOMENT
10921             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10922               - 0.5d0*(s1d+s2d)
10923 #else
10924             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10925               - 0.5d0*s2d
10926 #endif
10927 #ifdef MOMENT
10928             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10929               - 0.5d0*(s8d+s12d)
10930 #else
10931             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10932               - 0.5d0*s12d
10933 #endif
10934           enddo
10935         enddo
10936       enddo
10937 #ifdef MOMENT
10938       do kkk=1,5
10939         do lll=1,3
10940           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10941             achuj_tempd(1,1))
10942           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10943           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10944           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10945           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10946           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10947             vtemp4d(1))
10948           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10949           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10950           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10951         enddo
10952       enddo
10953 #endif
10954 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10955 !d     &  16*eel_turn6_num
10956 !d      goto 1112
10957       if (j.lt.nres-1) then
10958         j1=j+1
10959         j2=j-1
10960       else
10961         j1=j-1
10962         j2=j-2
10963       endif
10964       if (l.lt.nres-1) then
10965         l1=l+1
10966         l2=l-1
10967       else
10968         l1=l-1
10969         l2=l-2
10970       endif
10971       do ll=1,3
10972 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10973 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10974 !grad        ghalf=0.5d0*ggg1(ll)
10975 !d        ghalf=0.0d0
10976         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10977         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10978         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10979           +ekont*derx_turn(ll,2,1)
10980         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10981         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10982           +ekont*derx_turn(ll,4,1)
10983         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10984         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10985         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10986 !grad        ghalf=0.5d0*ggg2(ll)
10987 !d        ghalf=0.0d0
10988         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10989           +ekont*derx_turn(ll,2,2)
10990         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10991         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10992           +ekont*derx_turn(ll,4,2)
10993         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10994         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10995         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10996       enddo
10997 !d      goto 1112
10998 !grad      do m=i+1,j-1
10999 !grad        do ll=1,3
11000 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11001 !grad        enddo
11002 !grad      enddo
11003 !grad      do m=k+1,l-1
11004 !grad        do ll=1,3
11005 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11006 !grad        enddo
11007 !grad      enddo
11008 !grad1112  continue
11009 !grad      do m=i+2,j2
11010 !grad        do ll=1,3
11011 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11012 !grad        enddo
11013 !grad      enddo
11014 !grad      do m=k+2,l2
11015 !grad        do ll=1,3
11016 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11017 !grad        enddo
11018 !grad      enddo
11019 !d      do iii=1,nres-3
11020 !d        write (2,*) iii,g_corr6_loc(iii)
11021 !d      enddo
11022       eello_turn6=ekont*eel_turn6
11023 !d      write (2,*) 'ekont',ekont
11024 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11025       return
11026       end function eello_turn6
11027 !-----------------------------------------------------------------------------
11028       subroutine MATVEC2(A1,V1,V2)
11029 !DIR$ INLINEALWAYS MATVEC2
11030 #ifndef OSF
11031 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11032 #endif
11033 !      implicit real*8 (a-h,o-z)
11034 !      include 'DIMENSIONS'
11035       real(kind=8),dimension(2) :: V1,V2
11036       real(kind=8),dimension(2,2) :: A1
11037       real(kind=8) :: vaux1,vaux2
11038 !      DO 1 I=1,2
11039 !        VI=0.0
11040 !        DO 3 K=1,2
11041 !    3     VI=VI+A1(I,K)*V1(K)
11042 !        Vaux(I)=VI
11043 !    1 CONTINUE
11044
11045       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11046       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11047
11048       v2(1)=vaux1
11049       v2(2)=vaux2
11050       end subroutine MATVEC2
11051 !-----------------------------------------------------------------------------
11052       subroutine MATMAT2(A1,A2,A3)
11053 #ifndef OSF
11054 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11055 #endif
11056 !      implicit real*8 (a-h,o-z)
11057 !      include 'DIMENSIONS'
11058       real(kind=8),dimension(2,2) :: A1,A2,A3
11059       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11060 !      DIMENSION AI3(2,2)
11061 !        DO  J=1,2
11062 !          A3IJ=0.0
11063 !          DO K=1,2
11064 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11065 !          enddo
11066 !          A3(I,J)=A3IJ
11067 !       enddo
11068 !      enddo
11069
11070       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11071       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11072       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11073       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11074
11075       A3(1,1)=AI3_11
11076       A3(2,1)=AI3_21
11077       A3(1,2)=AI3_12
11078       A3(2,2)=AI3_22
11079       end subroutine MATMAT2
11080 !-----------------------------------------------------------------------------
11081       real(kind=8) function scalar2(u,v)
11082 !DIR$ INLINEALWAYS scalar2
11083       implicit none
11084       real(kind=8),dimension(2) :: u,v
11085       real(kind=8) :: sc
11086       integer :: i
11087       scalar2=u(1)*v(1)+u(2)*v(2)
11088       return
11089       end function scalar2
11090 !-----------------------------------------------------------------------------
11091       subroutine transpose2(a,at)
11092 !DIR$ INLINEALWAYS transpose2
11093 #ifndef OSF
11094 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11095 #endif
11096       implicit none
11097       real(kind=8),dimension(2,2) :: a,at
11098       at(1,1)=a(1,1)
11099       at(1,2)=a(2,1)
11100       at(2,1)=a(1,2)
11101       at(2,2)=a(2,2)
11102       return
11103       end subroutine transpose2
11104 !-----------------------------------------------------------------------------
11105       subroutine transpose(n,a,at)
11106       implicit none
11107       integer :: n,i,j
11108       real(kind=8),dimension(n,n) :: a,at
11109       do i=1,n
11110         do j=1,n
11111           at(j,i)=a(i,j)
11112         enddo
11113       enddo
11114       return
11115       end subroutine transpose
11116 !-----------------------------------------------------------------------------
11117       subroutine prodmat3(a1,a2,kk,transp,prod)
11118 !DIR$ INLINEALWAYS prodmat3
11119 #ifndef OSF
11120 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11121 #endif
11122       implicit none
11123       integer :: i,j
11124       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11125       logical :: transp
11126 !rc      double precision auxmat(2,2),prod_(2,2)
11127
11128       if (transp) then
11129 !rc        call transpose2(kk(1,1),auxmat(1,1))
11130 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11131 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11132
11133            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11134        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11135            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11136        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11137            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11138        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11139            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11140        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11141
11142       else
11143 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11144 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11145
11146            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11147         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11148            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11149         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11150            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11151         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11152            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11153         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11154
11155       endif
11156 !      call transpose2(a2(1,1),a2t(1,1))
11157
11158 !rc      print *,transp
11159 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11160 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11161
11162       return
11163       end subroutine prodmat3
11164 !-----------------------------------------------------------------------------
11165 ! energy_p_new_barrier.F
11166 !-----------------------------------------------------------------------------
11167       subroutine sum_gradient
11168 !      implicit real*8 (a-h,o-z)
11169       use io_base, only: pdbout
11170 !      include 'DIMENSIONS'
11171 #ifndef ISNAN
11172       external proc_proc
11173 #ifdef WINPGI
11174 !MS$ATTRIBUTES C ::  proc_proc
11175 #endif
11176 #endif
11177 #ifdef MPI
11178       include 'mpif.h'
11179 #endif
11180       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11181                    gloc_scbuf !(3,maxres)
11182
11183       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11184 !#endif
11185 !el local variables
11186       integer :: i,j,k,ierror,ierr
11187       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11188                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11189                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11190                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11191                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11192                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11193                    gsccorr_max,gsccorrx_max,time00
11194
11195 !      include 'COMMON.SETUP'
11196 !      include 'COMMON.IOUNITS'
11197 !      include 'COMMON.FFIELD'
11198 !      include 'COMMON.DERIV'
11199 !      include 'COMMON.INTERACT'
11200 !      include 'COMMON.SBRIDGE'
11201 !      include 'COMMON.CHAIN'
11202 !      include 'COMMON.VAR'
11203 !      include 'COMMON.CONTROL'
11204 !      include 'COMMON.TIME1'
11205 !      include 'COMMON.MAXGRAD'
11206 !      include 'COMMON.SCCOR'
11207 #ifdef TIMING
11208       time01=MPI_Wtime()
11209 #endif
11210 !#define DEBUG
11211 #ifdef DEBUG
11212       write (iout,*) "sum_gradient gvdwc, gvdwx"
11213       do i=1,nres
11214         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11215          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11216       enddo
11217       call flush(iout)
11218 #endif
11219 #ifdef MPI
11220         gradbufc=0.0d0
11221         gradbufx=0.0d0
11222         gradbufc_sum=0.0d0
11223         gloc_scbuf=0.0d0
11224         glocbuf=0.0d0
11225 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11226         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11227           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11228 #endif
11229 !
11230 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11231 !            in virtual-bond-vector coordinates
11232 !
11233 #ifdef DEBUG
11234 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11235 !      do i=1,nres-1
11236 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11237 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11238 !      enddo
11239 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11240 !      do i=1,nres-1
11241 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11242 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11243 !      enddo
11244 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11245 !      do i=1,nres
11246 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11247 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11248 !         (gvdwc_scpp(j,i),j=1,3)
11249 !      enddo
11250 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11251 !      do i=1,nres
11252 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11253 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11254 !         (gelc_loc_long(j,i),j=1,3)
11255 !      enddo
11256       call flush(iout)
11257 #endif
11258 #ifdef SPLITELE
11259       do i=0,nct
11260         do j=1,3
11261           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11262                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11263                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11264                       wel_loc*gel_loc_long(j,i)+ &
11265                       wcorr*gradcorr_long(j,i)+ &
11266                       wcorr5*gradcorr5_long(j,i)+ &
11267                       wcorr6*gradcorr6_long(j,i)+ &
11268                       wturn6*gcorr6_turn_long(j,i)+ &
11269                       wstrain*ghpbc(j,i) &
11270                      +wliptran*gliptranc(j,i) &
11271                      +gradafm(j,i) &
11272                      +welec*gshieldc(j,i) &
11273                      +wcorr*gshieldc_ec(j,i) &
11274                      +wturn3*gshieldc_t3(j,i)&
11275                      +wturn4*gshieldc_t4(j,i)&
11276                      +wel_loc*gshieldc_ll(j,i)&
11277                      +wtube*gg_tube(j,i) &
11278                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11279                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11280                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11281                      wcorr_nucl*gradcorr_nucl(j,i)&
11282                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11283                      wcatprot* gradpepcat(j,i)+ &
11284                      wcatcat*gradcatcat(j,i)+   &
11285                      wscbase*gvdwc_scbase(j,i)+ &
11286                      wpepbase*gvdwc_pepbase(j,i)+&
11287                      wscpho*gvdwc_scpho(j,i)+   &
11288                      wpeppho*gvdwc_peppho(j,i)
11289
11290
11291
11292
11293
11294         enddo
11295       enddo
11296 #else
11297       do i=0,nct
11298         do j=1,3
11299           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11300                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11301                       welec*gelc_long(j,i)+ &
11302                       wbond*gradb(j,i)+ &
11303                       wel_loc*gel_loc_long(j,i)+ &
11304                       wcorr*gradcorr_long(j,i)+ &
11305                       wcorr5*gradcorr5_long(j,i)+ &
11306                       wcorr6*gradcorr6_long(j,i)+ &
11307                       wturn6*gcorr6_turn_long(j,i)+ &
11308                       wstrain*ghpbc(j,i) &
11309                      +wliptran*gliptranc(j,i) &
11310                      +gradafm(j,i) &
11311                      +welec*gshieldc(j,i)&
11312                      +wcorr*gshieldc_ec(j,i) &
11313                      +wturn4*gshieldc_t4(j,i) &
11314                      +wel_loc*gshieldc_ll(j,i)&
11315                      +wtube*gg_tube(j,i) &
11316                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11317                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11318                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11319                      wcorr_nucl*gradcorr_nucl(j,i) &
11320                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11321                      wcatprot* gradpepcat(j,i)+ &
11322                      wcatcat*gradcatcat(j,i)+   &
11323                      wscbase*gvdwc_scbase(j,i)  &
11324                      wpepbase*gvdwc_pepbase(j,i)+&
11325                      wscpho*gvdwc_scpho(j,i)+&
11326                      wpeppho*gvdwc_peppho(j,i)
11327
11328
11329         enddo
11330       enddo
11331 #endif
11332 #ifdef MPI
11333       if (nfgtasks.gt.1) then
11334       time00=MPI_Wtime()
11335 #ifdef DEBUG
11336       write (iout,*) "gradbufc before allreduce"
11337       do i=1,nres
11338         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11339       enddo
11340       call flush(iout)
11341 #endif
11342       do i=0,nres
11343         do j=1,3
11344           gradbufc_sum(j,i)=gradbufc(j,i)
11345         enddo
11346       enddo
11347 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11348 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11349 !      time_reduce=time_reduce+MPI_Wtime()-time00
11350 #ifdef DEBUG
11351 !      write (iout,*) "gradbufc_sum after allreduce"
11352 !      do i=1,nres
11353 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11354 !      enddo
11355 !      call flush(iout)
11356 #endif
11357 #ifdef TIMING
11358 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11359 #endif
11360       do i=0,nres
11361         do k=1,3
11362           gradbufc(k,i)=0.0d0
11363         enddo
11364       enddo
11365 #ifdef DEBUG
11366       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11367       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11368                         " jgrad_end  ",jgrad_end(i),&
11369                         i=igrad_start,igrad_end)
11370 #endif
11371 !
11372 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11373 ! do not parallelize this part.
11374 !
11375 !      do i=igrad_start,igrad_end
11376 !        do j=jgrad_start(i),jgrad_end(i)
11377 !          do k=1,3
11378 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11379 !          enddo
11380 !        enddo
11381 !      enddo
11382       do j=1,3
11383         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11384       enddo
11385       do i=nres-2,-1,-1
11386         do j=1,3
11387           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11388         enddo
11389       enddo
11390 #ifdef DEBUG
11391       write (iout,*) "gradbufc after summing"
11392       do i=1,nres
11393         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11394       enddo
11395       call flush(iout)
11396 #endif
11397       else
11398 #endif
11399 !el#define DEBUG
11400 #ifdef DEBUG
11401       write (iout,*) "gradbufc"
11402       do i=1,nres
11403         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11404       enddo
11405       call flush(iout)
11406 #endif
11407 !el#undef DEBUG
11408       do i=-1,nres
11409         do j=1,3
11410           gradbufc_sum(j,i)=gradbufc(j,i)
11411           gradbufc(j,i)=0.0d0
11412         enddo
11413       enddo
11414       do j=1,3
11415         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11416       enddo
11417       do i=nres-2,-1,-1
11418         do j=1,3
11419           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11420         enddo
11421       enddo
11422 !      do i=nnt,nres-1
11423 !        do k=1,3
11424 !          gradbufc(k,i)=0.0d0
11425 !        enddo
11426 !        do j=i+1,nres
11427 !          do k=1,3
11428 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11429 !          enddo
11430 !        enddo
11431 !      enddo
11432 !el#define DEBUG
11433 #ifdef DEBUG
11434       write (iout,*) "gradbufc after summing"
11435       do i=1,nres
11436         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11437       enddo
11438       call flush(iout)
11439 #endif
11440 !el#undef DEBUG
11441 #ifdef MPI
11442       endif
11443 #endif
11444       do k=1,3
11445         gradbufc(k,nres)=0.0d0
11446       enddo
11447 !el----------------
11448 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11449 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11450 !el-----------------
11451       do i=-1,nct
11452         do j=1,3
11453 #ifdef SPLITELE
11454           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11455                       wel_loc*gel_loc(j,i)+ &
11456                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11457                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11458                       wel_loc*gel_loc_long(j,i)+ &
11459                       wcorr*gradcorr_long(j,i)+ &
11460                       wcorr5*gradcorr5_long(j,i)+ &
11461                       wcorr6*gradcorr6_long(j,i)+ &
11462                       wturn6*gcorr6_turn_long(j,i))+ &
11463                       wbond*gradb(j,i)+ &
11464                       wcorr*gradcorr(j,i)+ &
11465                       wturn3*gcorr3_turn(j,i)+ &
11466                       wturn4*gcorr4_turn(j,i)+ &
11467                       wcorr5*gradcorr5(j,i)+ &
11468                       wcorr6*gradcorr6(j,i)+ &
11469                       wturn6*gcorr6_turn(j,i)+ &
11470                       wsccor*gsccorc(j,i) &
11471                      +wscloc*gscloc(j,i)  &
11472                      +wliptran*gliptranc(j,i) &
11473                      +gradafm(j,i) &
11474                      +welec*gshieldc(j,i) &
11475                      +welec*gshieldc_loc(j,i) &
11476                      +wcorr*gshieldc_ec(j,i) &
11477                      +wcorr*gshieldc_loc_ec(j,i) &
11478                      +wturn3*gshieldc_t3(j,i) &
11479                      +wturn3*gshieldc_loc_t3(j,i) &
11480                      +wturn4*gshieldc_t4(j,i) &
11481                      +wturn4*gshieldc_loc_t4(j,i) &
11482                      +wel_loc*gshieldc_ll(j,i) &
11483                      +wel_loc*gshieldc_loc_ll(j,i) &
11484                      +wtube*gg_tube(j,i) &
11485                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11486                      +wvdwpsb*gvdwpsb1(j,i))&
11487                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11488 !                      if (i.eq.21) then
11489 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11490 !                      wturn4*gshieldc_t4(j,i), &
11491 !                     wturn4*gshieldc_loc_t4(j,i)
11492 !                       endif
11493 !                 if ((i.le.2).and.(i.ge.1))
11494 !                       print *,gradc(j,i,icg),&
11495 !                      gradbufc(j,i),welec*gelc(j,i), &
11496 !                      wel_loc*gel_loc(j,i), &
11497 !                      wscp*gvdwc_scpp(j,i), &
11498 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11499 !                      wel_loc*gel_loc_long(j,i), &
11500 !                      wcorr*gradcorr_long(j,i), &
11501 !                      wcorr5*gradcorr5_long(j,i), &
11502 !                      wcorr6*gradcorr6_long(j,i), &
11503 !                      wturn6*gcorr6_turn_long(j,i), &
11504 !                      wbond*gradb(j,i), &
11505 !                      wcorr*gradcorr(j,i), &
11506 !                      wturn3*gcorr3_turn(j,i), &
11507 !                      wturn4*gcorr4_turn(j,i), &
11508 !                      wcorr5*gradcorr5(j,i), &
11509 !                      wcorr6*gradcorr6(j,i), &
11510 !                      wturn6*gcorr6_turn(j,i), &
11511 !                      wsccor*gsccorc(j,i) &
11512 !                     ,wscloc*gscloc(j,i)  &
11513 !                     ,wliptran*gliptranc(j,i) &
11514 !                    ,gradafm(j,i) &
11515 !                     ,welec*gshieldc(j,i) &
11516 !                     ,welec*gshieldc_loc(j,i) &
11517 !                     ,wcorr*gshieldc_ec(j,i) &
11518 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11519 !                     ,wturn3*gshieldc_t3(j,i) &
11520 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11521 !                     ,wturn4*gshieldc_t4(j,i) &
11522 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11523 !                     ,wel_loc*gshieldc_ll(j,i) &
11524 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11525 !                     ,wtube*gg_tube(j,i) &
11526 !                     ,wbond_nucl*gradb_nucl(j,i) &
11527 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11528 !                     wvdwpsb*gvdwpsb1(j,i)&
11529 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11530 !
11531
11532 #else
11533           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11534                       wel_loc*gel_loc(j,i)+ &
11535                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11536                       welec*gelc_long(j,i)+ &
11537                       wel_loc*gel_loc_long(j,i)+ &
11538 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11539                       wcorr5*gradcorr5_long(j,i)+ &
11540                       wcorr6*gradcorr6_long(j,i)+ &
11541                       wturn6*gcorr6_turn_long(j,i))+ &
11542                       wbond*gradb(j,i)+ &
11543                       wcorr*gradcorr(j,i)+ &
11544                       wturn3*gcorr3_turn(j,i)+ &
11545                       wturn4*gcorr4_turn(j,i)+ &
11546                       wcorr5*gradcorr5(j,i)+ &
11547                       wcorr6*gradcorr6(j,i)+ &
11548                       wturn6*gcorr6_turn(j,i)+ &
11549                       wsccor*gsccorc(j,i) &
11550                      +wscloc*gscloc(j,i) &
11551                      +gradafm(j,i) &
11552                      +wliptran*gliptranc(j,i) &
11553                      +welec*gshieldc(j,i) &
11554                      +welec*gshieldc_loc(j,) &
11555                      +wcorr*gshieldc_ec(j,i) &
11556                      +wcorr*gshieldc_loc_ec(j,i) &
11557                      +wturn3*gshieldc_t3(j,i) &
11558                      +wturn3*gshieldc_loc_t3(j,i) &
11559                      +wturn4*gshieldc_t4(j,i) &
11560                      +wturn4*gshieldc_loc_t4(j,i) &
11561                      +wel_loc*gshieldc_ll(j,i) &
11562                      +wel_loc*gshieldc_loc_ll(j,i) &
11563                      +wtube*gg_tube(j,i) &
11564                      +wbond_nucl*gradb_nucl(j,i) &
11565                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11566                      +wvdwpsb*gvdwpsb1(j,i))&
11567                      +wsbloc*gsbloc(j,i)
11568
11569
11570
11571
11572 #endif
11573           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11574                         wbond*gradbx(j,i)+ &
11575                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11576                         wsccor*gsccorx(j,i) &
11577                        +wscloc*gsclocx(j,i) &
11578                        +wliptran*gliptranx(j,i) &
11579                        +welec*gshieldx(j,i)     &
11580                        +wcorr*gshieldx_ec(j,i)  &
11581                        +wturn3*gshieldx_t3(j,i) &
11582                        +wturn4*gshieldx_t4(j,i) &
11583                        +wel_loc*gshieldx_ll(j,i)&
11584                        +wtube*gg_tube_sc(j,i)   &
11585                        +wbond_nucl*gradbx_nucl(j,i) &
11586                        +wvdwsb*gvdwsbx(j,i) &
11587                        +welsb*gelsbx(j,i) &
11588                        +wcorr_nucl*gradxorr_nucl(j,i)&
11589                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11590                        +wsbloc*gsblocx(j,i) &
11591                        +wcatprot* gradpepcatx(j,i)&
11592                        +wscbase*gvdwx_scbase(j,i) &
11593                        +wpepbase*gvdwx_pepbase(j,i)&
11594                        +wscpho*gvdwx_scpho(j,i)
11595 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11596
11597         enddo
11598       enddo
11599 !#define DEBUG
11600 #ifdef DEBUG
11601       write (iout,*) "gloc before adding corr"
11602       do i=1,4*nres
11603         write (iout,*) i,gloc(i,icg)
11604       enddo
11605 #endif
11606       do i=1,nres-3
11607         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11608          +wcorr5*g_corr5_loc(i) &
11609          +wcorr6*g_corr6_loc(i) &
11610          +wturn4*gel_loc_turn4(i) &
11611          +wturn3*gel_loc_turn3(i) &
11612          +wturn6*gel_loc_turn6(i) &
11613          +wel_loc*gel_loc_loc(i)
11614       enddo
11615 #ifdef DEBUG
11616       write (iout,*) "gloc after adding corr"
11617       do i=1,4*nres
11618         write (iout,*) i,gloc(i,icg)
11619       enddo
11620 #endif
11621 !#undef DEBUG
11622 #ifdef MPI
11623       if (nfgtasks.gt.1) then
11624         do j=1,3
11625           do i=0,nres
11626             gradbufc(j,i)=gradc(j,i,icg)
11627             gradbufx(j,i)=gradx(j,i,icg)
11628           enddo
11629         enddo
11630         do i=1,4*nres
11631           glocbuf(i)=gloc(i,icg)
11632         enddo
11633 !#define DEBUG
11634 #ifdef DEBUG
11635       write (iout,*) "gloc_sc before reduce"
11636       do i=1,nres
11637        do j=1,1
11638         write (iout,*) i,j,gloc_sc(j,i,icg)
11639        enddo
11640       enddo
11641 #endif
11642 !#undef DEBUG
11643         do i=1,nres
11644          do j=1,3
11645           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11646          enddo
11647         enddo
11648         time00=MPI_Wtime()
11649         call MPI_Barrier(FG_COMM,IERR)
11650         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11651         time00=MPI_Wtime()
11652         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11653           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11654         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11655           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11656         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11657           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11658         time_reduce=time_reduce+MPI_Wtime()-time00
11659         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11660           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11661         time_reduce=time_reduce+MPI_Wtime()-time00
11662 !#define DEBUG
11663 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11664 #ifdef DEBUG
11665       write (iout,*) "gloc_sc after reduce"
11666       do i=1,nres
11667        do j=1,1
11668         write (iout,*) i,j,gloc_sc(j,i,icg)
11669        enddo
11670       enddo
11671 #endif
11672 !#undef DEBUG
11673 #ifdef DEBUG
11674       write (iout,*) "gloc after reduce"
11675       do i=1,4*nres
11676         write (iout,*) i,gloc(i,icg)
11677       enddo
11678 #endif
11679       endif
11680 #endif
11681       if (gnorm_check) then
11682 !
11683 ! Compute the maximum elements of the gradient
11684 !
11685       gvdwc_max=0.0d0
11686       gvdwc_scp_max=0.0d0
11687       gelc_max=0.0d0
11688       gvdwpp_max=0.0d0
11689       gradb_max=0.0d0
11690       ghpbc_max=0.0d0
11691       gradcorr_max=0.0d0
11692       gel_loc_max=0.0d0
11693       gcorr3_turn_max=0.0d0
11694       gcorr4_turn_max=0.0d0
11695       gradcorr5_max=0.0d0
11696       gradcorr6_max=0.0d0
11697       gcorr6_turn_max=0.0d0
11698       gsccorc_max=0.0d0
11699       gscloc_max=0.0d0
11700       gvdwx_max=0.0d0
11701       gradx_scp_max=0.0d0
11702       ghpbx_max=0.0d0
11703       gradxorr_max=0.0d0
11704       gsccorx_max=0.0d0
11705       gsclocx_max=0.0d0
11706       do i=1,nct
11707         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11708         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11709         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11710         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11711          gvdwc_scp_max=gvdwc_scp_norm
11712         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11713         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11714         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11715         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11716         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11717         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11718         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11719         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11720         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11721         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11722         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11723         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11724         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11725           gcorr3_turn(1,i)))
11726         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11727           gcorr3_turn_max=gcorr3_turn_norm
11728         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11729           gcorr4_turn(1,i)))
11730         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11731           gcorr4_turn_max=gcorr4_turn_norm
11732         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11733         if (gradcorr5_norm.gt.gradcorr5_max) &
11734           gradcorr5_max=gradcorr5_norm
11735         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11736         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11737         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11738           gcorr6_turn(1,i)))
11739         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11740           gcorr6_turn_max=gcorr6_turn_norm
11741         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11742         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11743         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11744         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11745         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11746         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11747         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11748         if (gradx_scp_norm.gt.gradx_scp_max) &
11749           gradx_scp_max=gradx_scp_norm
11750         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11751         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11752         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11753         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11754         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11755         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11756         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11757         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11758       enddo
11759       if (gradout) then
11760 #ifdef AIX
11761         open(istat,file=statname,position="append")
11762 #else
11763         open(istat,file=statname,access="append")
11764 #endif
11765         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11766            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11767            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11768            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11769            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11770            gsccorx_max,gsclocx_max
11771         close(istat)
11772         if (gvdwc_max.gt.1.0d4) then
11773           write (iout,*) "gvdwc gvdwx gradb gradbx"
11774           do i=nnt,nct
11775             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11776               gradb(j,i),gradbx(j,i),j=1,3)
11777           enddo
11778           call pdbout(0.0d0,'cipiszcze',iout)
11779           call flush(iout)
11780         endif
11781       endif
11782       endif
11783 !#define DEBUG
11784 #ifdef DEBUG
11785       write (iout,*) "gradc gradx gloc"
11786       do i=1,nres
11787         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11788          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11789       enddo
11790 #endif
11791 !#undef DEBUG
11792 #ifdef TIMING
11793       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11794 #endif
11795       return
11796       end subroutine sum_gradient
11797 !-----------------------------------------------------------------------------
11798       subroutine sc_grad
11799 !      implicit real*8 (a-h,o-z)
11800       use calc_data
11801 !      include 'DIMENSIONS'
11802 !      include 'COMMON.CHAIN'
11803 !      include 'COMMON.DERIV'
11804 !      include 'COMMON.CALC'
11805 !      include 'COMMON.IOUNITS'
11806       real(kind=8), dimension(3) :: dcosom1,dcosom2
11807 !      print *,"wchodze"
11808       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11809           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11810       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11811           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11812
11813       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11814            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11815            +dCAVdOM12+ dGCLdOM12
11816 ! diagnostics only
11817 !      eom1=0.0d0
11818 !      eom2=0.0d0
11819 !      eom12=evdwij*eps1_om12
11820 ! end diagnostics
11821 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11822 !       " sigder",sigder
11823 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11824 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11825 !C      print *,sss_ele_cut,'in sc_grad'
11826       do k=1,3
11827         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11828         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11829       enddo
11830       do k=1,3
11831         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11832 !C      print *,'gg',k,gg(k)
11833        enddo
11834 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11835 !      write (iout,*) "gg",(gg(k),k=1,3)
11836       do k=1,3
11837         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11838                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11839                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11840                   *sss_ele_cut
11841
11842         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11843                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11844                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11845                   *sss_ele_cut
11846
11847 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11848 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11849 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11850 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11851       enddo
11852 !
11853 ! Calculate the components of the gradient in DC and X
11854 !
11855 !grad      do k=i,j-1
11856 !grad        do l=1,3
11857 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11858 !grad        enddo
11859 !grad      enddo
11860       do l=1,3
11861         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11862         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11863       enddo
11864       return
11865       end subroutine sc_grad
11866 #ifdef CRYST_THETA
11867 !-----------------------------------------------------------------------------
11868       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11869
11870       use comm_calcthet
11871 !      implicit real*8 (a-h,o-z)
11872 !      include 'DIMENSIONS'
11873 !      include 'COMMON.LOCAL'
11874 !      include 'COMMON.IOUNITS'
11875 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11876 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11877 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11878       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11879       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11880 !el      integer :: it
11881 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11882 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11883 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11884 !el local variables
11885
11886       delthec=thetai-thet_pred_mean
11887       delthe0=thetai-theta0i
11888 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11889       t3 = thetai-thet_pred_mean
11890       t6 = t3**2
11891       t9 = term1
11892       t12 = t3*sigcsq
11893       t14 = t12+t6*sigsqtc
11894       t16 = 1.0d0
11895       t21 = thetai-theta0i
11896       t23 = t21**2
11897       t26 = term2
11898       t27 = t21*t26
11899       t32 = termexp
11900       t40 = t32**2
11901       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11902        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11903        *(-t12*t9-ak*sig0inv*t27)
11904       return
11905       end subroutine mixder
11906 #endif
11907 !-----------------------------------------------------------------------------
11908 ! cartder.F
11909 !-----------------------------------------------------------------------------
11910       subroutine cartder
11911 !-----------------------------------------------------------------------------
11912 ! This subroutine calculates the derivatives of the consecutive virtual
11913 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11914 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11915 ! in the angles alpha and omega, describing the location of a side chain
11916 ! in its local coordinate system.
11917 !
11918 ! The derivatives are stored in the following arrays:
11919 !
11920 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11921 ! The structure is as follows:
11922 !
11923 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11924 ! 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)
11925 !         . . . . . . . . . . . .  . . . . . .
11926 ! 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)
11927 !                          .
11928 !                          .
11929 !                          .
11930 ! 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)
11931 !
11932 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11933 ! The structure is same as above.
11934 !
11935 ! DCDS - the derivatives of the side chain vectors in the local spherical
11936 ! andgles alph and omega:
11937 !
11938 ! 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)
11939 ! 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)
11940 !                          .
11941 !                          .
11942 !                          .
11943 ! 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)
11944 !
11945 ! Version of March '95, based on an early version of November '91.
11946 !
11947 !**********************************************************************
11948 !      implicit real*8 (a-h,o-z)
11949 !      include 'DIMENSIONS'
11950 !      include 'COMMON.VAR'
11951 !      include 'COMMON.CHAIN'
11952 !      include 'COMMON.DERIV'
11953 !      include 'COMMON.GEO'
11954 !      include 'COMMON.LOCAL'
11955 !      include 'COMMON.INTERACT'
11956       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11957       real(kind=8),dimension(3,3) :: dp,temp
11958 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11959       real(kind=8),dimension(3) :: xx,xx1
11960 !el local variables
11961       integer :: i,k,l,j,m,ind,ind1,jjj
11962       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11963                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11964                  sint2,xp,yp,xxp,yyp,zzp,dj
11965
11966 !      common /przechowalnia/ fromto
11967       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11968 ! get the position of the jth ijth fragment of the chain coordinate system
11969 ! in the fromto array.
11970 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11971 !
11972 !      maxdim=(nres-1)*(nres-2)/2
11973 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11974 ! calculate the derivatives of transformation matrix elements in theta
11975 !
11976
11977 !el      call flush(iout) !el
11978       do i=1,nres-2
11979         rdt(1,1,i)=-rt(1,2,i)
11980         rdt(1,2,i)= rt(1,1,i)
11981         rdt(1,3,i)= 0.0d0
11982         rdt(2,1,i)=-rt(2,2,i)
11983         rdt(2,2,i)= rt(2,1,i)
11984         rdt(2,3,i)= 0.0d0
11985         rdt(3,1,i)=-rt(3,2,i)
11986         rdt(3,2,i)= rt(3,1,i)
11987         rdt(3,3,i)= 0.0d0
11988       enddo
11989 !
11990 ! derivatives in phi
11991 !
11992       do i=2,nres-2
11993         drt(1,1,i)= 0.0d0
11994         drt(1,2,i)= 0.0d0
11995         drt(1,3,i)= 0.0d0
11996         drt(2,1,i)= rt(3,1,i)
11997         drt(2,2,i)= rt(3,2,i)
11998         drt(2,3,i)= rt(3,3,i)
11999         drt(3,1,i)=-rt(2,1,i)
12000         drt(3,2,i)=-rt(2,2,i)
12001         drt(3,3,i)=-rt(2,3,i)
12002       enddo
12003 !
12004 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12005 !
12006       do i=2,nres-2
12007         ind=indmat(i,i+1)
12008         do k=1,3
12009           do l=1,3
12010             temp(k,l)=rt(k,l,i)
12011           enddo
12012         enddo
12013         do k=1,3
12014           do l=1,3
12015             fromto(k,l,ind)=temp(k,l)
12016           enddo
12017         enddo
12018         do j=i+1,nres-2
12019           ind=indmat(i,j+1)
12020           do k=1,3
12021             do l=1,3
12022               dpkl=0.0d0
12023               do m=1,3
12024                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12025               enddo
12026               dp(k,l)=dpkl
12027               fromto(k,l,ind)=dpkl
12028             enddo
12029           enddo
12030           do k=1,3
12031             do l=1,3
12032               temp(k,l)=dp(k,l)
12033             enddo
12034           enddo
12035         enddo
12036       enddo
12037 !
12038 ! Calculate derivatives.
12039 !
12040       ind1=0
12041       do i=1,nres-2
12042       ind1=ind1+1
12043 !
12044 ! Derivatives of DC(i+1) in theta(i+2)
12045 !
12046         do j=1,3
12047           do k=1,2
12048             dpjk=0.0D0
12049             do l=1,3
12050               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12051             enddo
12052             dp(j,k)=dpjk
12053             prordt(j,k,i)=dp(j,k)
12054           enddo
12055           dp(j,3)=0.0D0
12056           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12057         enddo
12058 !
12059 ! Derivatives of SC(i+1) in theta(i+2)
12060 !
12061         xx1(1)=-0.5D0*xloc(2,i+1)
12062         xx1(2)= 0.5D0*xloc(1,i+1)
12063         do j=1,3
12064           xj=0.0D0
12065           do k=1,2
12066             xj=xj+r(j,k,i)*xx1(k)
12067           enddo
12068           xx(j)=xj
12069         enddo
12070         do j=1,3
12071           rj=0.0D0
12072           do k=1,3
12073             rj=rj+prod(j,k,i)*xx(k)
12074           enddo
12075           dxdv(j,ind1)=rj
12076         enddo
12077 !
12078 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12079 ! than the other off-diagonal derivatives.
12080 !
12081         do j=1,3
12082           dxoiij=0.0D0
12083           do k=1,3
12084             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12085           enddo
12086           dxdv(j,ind1+1)=dxoiij
12087         enddo
12088 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12089 !
12090 ! Derivatives of DC(i+1) in phi(i+2)
12091 !
12092         do j=1,3
12093           do k=1,3
12094             dpjk=0.0
12095             do l=2,3
12096               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12097             enddo
12098             dp(j,k)=dpjk
12099             prodrt(j,k,i)=dp(j,k)
12100           enddo
12101           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12102         enddo
12103 !
12104 ! Derivatives of SC(i+1) in phi(i+2)
12105 !
12106         xx(1)= 0.0D0
12107         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12108         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12109         do j=1,3
12110           rj=0.0D0
12111           do k=2,3
12112             rj=rj+prod(j,k,i)*xx(k)
12113           enddo
12114           dxdv(j+3,ind1)=-rj
12115         enddo
12116 !
12117 ! Derivatives of SC(i+1) in phi(i+3).
12118 !
12119         do j=1,3
12120           dxoiij=0.0D0
12121           do k=1,3
12122             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12123           enddo
12124           dxdv(j+3,ind1+1)=dxoiij
12125         enddo
12126 !
12127 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12128 ! theta(nres) and phi(i+3) thru phi(nres).
12129 !
12130         do j=i+1,nres-2
12131         ind1=ind1+1
12132         ind=indmat(i+1,j+1)
12133 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12134           do k=1,3
12135             do l=1,3
12136               tempkl=0.0D0
12137               do m=1,2
12138                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12139               enddo
12140               temp(k,l)=tempkl
12141             enddo
12142           enddo
12143 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12144 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12145 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12146 ! Derivatives of virtual-bond vectors in theta
12147           do k=1,3
12148             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12149           enddo
12150 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12151 ! Derivatives of SC vectors in theta
12152           do k=1,3
12153             dxoijk=0.0D0
12154             do l=1,3
12155               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12156             enddo
12157             dxdv(k,ind1+1)=dxoijk
12158           enddo
12159 !
12160 !--- Calculate the derivatives in phi
12161 !
12162           do k=1,3
12163             do l=1,3
12164               tempkl=0.0D0
12165               do m=1,3
12166                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12167               enddo
12168               temp(k,l)=tempkl
12169             enddo
12170           enddo
12171           do k=1,3
12172             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12173         enddo
12174           do k=1,3
12175             dxoijk=0.0D0
12176             do l=1,3
12177               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12178             enddo
12179             dxdv(k+3,ind1+1)=dxoijk
12180           enddo
12181         enddo
12182       enddo
12183 !
12184 ! Derivatives in alpha and omega:
12185 !
12186       do i=2,nres-1
12187 !       dsci=dsc(itype(i,1))
12188         dsci=vbld(i+nres)
12189 #ifdef OSF
12190         alphi=alph(i)
12191         omegi=omeg(i)
12192         if(alphi.ne.alphi) alphi=100.0
12193         if(omegi.ne.omegi) omegi=-100.0
12194 #else
12195       alphi=alph(i)
12196       omegi=omeg(i)
12197 #endif
12198 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12199       cosalphi=dcos(alphi)
12200       sinalphi=dsin(alphi)
12201       cosomegi=dcos(omegi)
12202       sinomegi=dsin(omegi)
12203       temp(1,1)=-dsci*sinalphi
12204       temp(2,1)= dsci*cosalphi*cosomegi
12205       temp(3,1)=-dsci*cosalphi*sinomegi
12206       temp(1,2)=0.0D0
12207       temp(2,2)=-dsci*sinalphi*sinomegi
12208       temp(3,2)=-dsci*sinalphi*cosomegi
12209       theta2=pi-0.5D0*theta(i+1)
12210       cost2=dcos(theta2)
12211       sint2=dsin(theta2)
12212       jjj=0
12213 !d      print *,((temp(l,k),l=1,3),k=1,2)
12214         do j=1,2
12215         xp=temp(1,j)
12216         yp=temp(2,j)
12217         xxp= xp*cost2+yp*sint2
12218         yyp=-xp*sint2+yp*cost2
12219         zzp=temp(3,j)
12220         xx(1)=xxp
12221         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12222         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12223         do k=1,3
12224           dj=0.0D0
12225           do l=1,3
12226             dj=dj+prod(k,l,i-1)*xx(l)
12227             enddo
12228           dxds(jjj+k,i)=dj
12229           enddo
12230         jjj=jjj+3
12231       enddo
12232       enddo
12233       return
12234       end subroutine cartder
12235 !-----------------------------------------------------------------------------
12236 ! checkder_p.F
12237 !-----------------------------------------------------------------------------
12238       subroutine check_cartgrad
12239 ! Check the gradient of Cartesian coordinates in internal coordinates.
12240 !      implicit real*8 (a-h,o-z)
12241 !      include 'DIMENSIONS'
12242 !      include 'COMMON.IOUNITS'
12243 !      include 'COMMON.VAR'
12244 !      include 'COMMON.CHAIN'
12245 !      include 'COMMON.GEO'
12246 !      include 'COMMON.LOCAL'
12247 !      include 'COMMON.DERIV'
12248       real(kind=8),dimension(6,nres) :: temp
12249       real(kind=8),dimension(3) :: xx,gg
12250       integer :: i,k,j,ii
12251       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12252 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12253 !
12254 ! Check the gradient of the virtual-bond and SC vectors in the internal
12255 ! coordinates.
12256 !
12257       aincr=1.0d-6
12258       aincr2=5.0d-7
12259       call cartder
12260       write (iout,'(a)') '**************** dx/dalpha'
12261       write (iout,'(a)')
12262       do i=2,nres-1
12263       alphi=alph(i)
12264       alph(i)=alph(i)+aincr
12265       do k=1,3
12266         temp(k,i)=dc(k,nres+i)
12267         enddo
12268       call chainbuild
12269       do k=1,3
12270         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12271         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12272         enddo
12273         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12274         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12275         write (iout,'(a)')
12276       alph(i)=alphi
12277       call chainbuild
12278       enddo
12279       write (iout,'(a)')
12280       write (iout,'(a)') '**************** dx/domega'
12281       write (iout,'(a)')
12282       do i=2,nres-1
12283       omegi=omeg(i)
12284       omeg(i)=omeg(i)+aincr
12285       do k=1,3
12286         temp(k,i)=dc(k,nres+i)
12287         enddo
12288       call chainbuild
12289       do k=1,3
12290           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12291           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12292                 (aincr*dabs(dxds(k+3,i))+aincr))
12293         enddo
12294         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12295             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12296         write (iout,'(a)')
12297       omeg(i)=omegi
12298       call chainbuild
12299       enddo
12300       write (iout,'(a)')
12301       write (iout,'(a)') '**************** dx/dtheta'
12302       write (iout,'(a)')
12303       do i=3,nres
12304       theti=theta(i)
12305         theta(i)=theta(i)+aincr
12306         do j=i-1,nres-1
12307           do k=1,3
12308             temp(k,j)=dc(k,nres+j)
12309           enddo
12310         enddo
12311         call chainbuild
12312         do j=i-1,nres-1
12313         ii = indmat(i-2,j)
12314 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12315         do k=1,3
12316           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12317           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12318                   (aincr*dabs(dxdv(k,ii))+aincr))
12319           enddo
12320           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12321               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12322           write(iout,'(a)')
12323         enddo
12324         write (iout,'(a)')
12325         theta(i)=theti
12326         call chainbuild
12327       enddo
12328       write (iout,'(a)') '***************** dx/dphi'
12329       write (iout,'(a)')
12330       do i=4,nres
12331         phi(i)=phi(i)+aincr
12332         do j=i-1,nres-1
12333           do k=1,3
12334             temp(k,j)=dc(k,nres+j)
12335           enddo
12336         enddo
12337         call chainbuild
12338         do j=i-1,nres-1
12339         ii = indmat(i-2,j)
12340 !         print *,'ii=',ii
12341         do k=1,3
12342           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12343             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12344                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12345           enddo
12346           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12347               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12348           write(iout,'(a)')
12349         enddo
12350         phi(i)=phi(i)-aincr
12351         call chainbuild
12352       enddo
12353       write (iout,'(a)') '****************** ddc/dtheta'
12354       do i=1,nres-2
12355         thet=theta(i+2)
12356         theta(i+2)=thet+aincr
12357         do j=i,nres
12358           do k=1,3
12359             temp(k,j)=dc(k,j)
12360           enddo
12361         enddo
12362         call chainbuild
12363         do j=i+1,nres-1
12364         ii = indmat(i,j)
12365 !         print *,'ii=',ii
12366         do k=1,3
12367           gg(k)=(dc(k,j)-temp(k,j))/aincr
12368           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12369                  (aincr*dabs(dcdv(k,ii))+aincr))
12370           enddo
12371           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12372                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12373         write (iout,'(a)')
12374         enddo
12375         do j=1,nres
12376           do k=1,3
12377             dc(k,j)=temp(k,j)
12378           enddo
12379         enddo
12380         theta(i+2)=thet
12381       enddo
12382       write (iout,'(a)') '******************* ddc/dphi'
12383       do i=1,nres-3
12384         phii=phi(i+3)
12385         phi(i+3)=phii+aincr
12386         do j=1,nres
12387           do k=1,3
12388             temp(k,j)=dc(k,j)
12389           enddo
12390         enddo
12391         call chainbuild
12392         do j=i+2,nres-1
12393         ii = indmat(i+1,j)
12394 !         print *,'ii=',ii
12395         do k=1,3
12396           gg(k)=(dc(k,j)-temp(k,j))/aincr
12397             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12398                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12399           enddo
12400           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12401                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12402         write (iout,'(a)')
12403         enddo
12404         do j=1,nres
12405           do k=1,3
12406             dc(k,j)=temp(k,j)
12407           enddo
12408         enddo
12409         phi(i+3)=phii
12410       enddo
12411       return
12412       end subroutine check_cartgrad
12413 !-----------------------------------------------------------------------------
12414       subroutine check_ecart
12415 ! Check the gradient of the energy in Cartesian coordinates.
12416 !     implicit real*8 (a-h,o-z)
12417 !     include 'DIMENSIONS'
12418 !     include 'COMMON.CHAIN'
12419 !     include 'COMMON.DERIV'
12420 !     include 'COMMON.IOUNITS'
12421 !     include 'COMMON.VAR'
12422 !     include 'COMMON.CONTACTS'
12423       use comm_srutu
12424 !el      integer :: icall
12425 !el      common /srutu/ icall
12426       real(kind=8),dimension(6) :: ggg
12427       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12428       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12429       real(kind=8),dimension(6,nres) :: grad_s
12430       real(kind=8),dimension(0:n_ene) :: energia,energia1
12431       integer :: uiparm(1)
12432       real(kind=8) :: urparm(1)
12433 !EL      external fdum
12434       integer :: nf,i,j,k
12435       real(kind=8) :: aincr,etot,etot1
12436       icg=1
12437       nf=0
12438       nfl=0
12439       call zerograd
12440       aincr=1.0D-5
12441       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12442       nf=0
12443       icall=0
12444       call geom_to_var(nvar,x)
12445       call etotal(energia)
12446       etot=energia(0)
12447 !el      call enerprint(energia)
12448       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12449       icall =1
12450       do i=1,nres
12451         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12452       enddo
12453       do i=1,nres
12454       do j=1,3
12455         grad_s(j,i)=gradc(j,i,icg)
12456         grad_s(j+3,i)=gradx(j,i,icg)
12457         enddo
12458       enddo
12459       call flush(iout)
12460       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12461       do i=1,nres
12462         do j=1,3
12463         xx(j)=c(j,i+nres)
12464         ddc(j)=dc(j,i)
12465         ddx(j)=dc(j,i+nres)
12466         enddo
12467       do j=1,3
12468         dc(j,i)=dc(j,i)+aincr
12469         do k=i+1,nres
12470           c(j,k)=c(j,k)+aincr
12471           c(j,k+nres)=c(j,k+nres)+aincr
12472           enddo
12473           call zerograd
12474           call etotal(energia1)
12475           etot1=energia1(0)
12476         ggg(j)=(etot1-etot)/aincr
12477         dc(j,i)=ddc(j)
12478         do k=i+1,nres
12479           c(j,k)=c(j,k)-aincr
12480           c(j,k+nres)=c(j,k+nres)-aincr
12481           enddo
12482         enddo
12483       do j=1,3
12484         c(j,i+nres)=c(j,i+nres)+aincr
12485         dc(j,i+nres)=dc(j,i+nres)+aincr
12486           call zerograd
12487           call etotal(energia1)
12488           etot1=energia1(0)
12489         ggg(j+3)=(etot1-etot)/aincr
12490         c(j,i+nres)=xx(j)
12491         dc(j,i+nres)=ddx(j)
12492         enddo
12493       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12494          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12495       enddo
12496       return
12497       end subroutine check_ecart
12498 #ifdef CARGRAD
12499 !-----------------------------------------------------------------------------
12500       subroutine check_ecartint
12501 ! Check the gradient of the energy in Cartesian coordinates.
12502       use io_base, only: intout
12503 !      implicit real*8 (a-h,o-z)
12504 !      include 'DIMENSIONS'
12505 !      include 'COMMON.CONTROL'
12506 !      include 'COMMON.CHAIN'
12507 !      include 'COMMON.DERIV'
12508 !      include 'COMMON.IOUNITS'
12509 !      include 'COMMON.VAR'
12510 !      include 'COMMON.CONTACTS'
12511 !      include 'COMMON.MD'
12512 !      include 'COMMON.LOCAL'
12513 !      include 'COMMON.SPLITELE'
12514       use comm_srutu
12515 !el      integer :: icall
12516 !el      common /srutu/ icall
12517       real(kind=8),dimension(6) :: ggg,ggg1
12518       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12519       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12520       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12521       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12522       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12523       real(kind=8),dimension(0:n_ene) :: energia,energia1
12524       integer :: uiparm(1)
12525       real(kind=8) :: urparm(1)
12526 !EL      external fdum
12527       integer :: i,j,k,nf
12528       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12529                    etot21,etot22
12530       r_cut=2.0d0
12531       rlambd=0.3d0
12532       icg=1
12533       nf=0
12534       nfl=0
12535       call intout
12536 !      call intcartderiv
12537 !      call checkintcartgrad
12538       call zerograd
12539       aincr=1.0D-4
12540       write(iout,*) 'Calling CHECK_ECARTINT.'
12541       nf=0
12542       icall=0
12543       call geom_to_var(nvar,x)
12544       write (iout,*) "split_ene ",split_ene
12545       call flush(iout)
12546       if (.not.split_ene) then
12547         call zerograd
12548         call etotal(energia)
12549         etot=energia(0)
12550         call cartgrad
12551         icall =1
12552         do i=1,nres
12553           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12554         enddo
12555         do j=1,3
12556           grad_s(j,0)=gcart(j,0)
12557         enddo
12558         do i=1,nres
12559           do j=1,3
12560             grad_s(j,i)=gcart(j,i)
12561             grad_s(j+3,i)=gxcart(j,i)
12562           enddo
12563         enddo
12564       else
12565 !- split gradient check
12566         call zerograd
12567         call etotal_long(energia)
12568 !el        call enerprint(energia)
12569         call cartgrad
12570         icall =1
12571         do i=1,nres
12572           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12573           (gxcart(j,i),j=1,3)
12574         enddo
12575         do j=1,3
12576           grad_s(j,0)=gcart(j,0)
12577         enddo
12578         do i=1,nres
12579           do j=1,3
12580             grad_s(j,i)=gcart(j,i)
12581             grad_s(j+3,i)=gxcart(j,i)
12582           enddo
12583         enddo
12584         call zerograd
12585         call etotal_short(energia)
12586         call enerprint(energia)
12587         call cartgrad
12588         icall =1
12589         do i=1,nres
12590           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12591           (gxcart(j,i),j=1,3)
12592         enddo
12593         do j=1,3
12594           grad_s1(j,0)=gcart(j,0)
12595         enddo
12596         do i=1,nres
12597           do j=1,3
12598             grad_s1(j,i)=gcart(j,i)
12599             grad_s1(j+3,i)=gxcart(j,i)
12600           enddo
12601         enddo
12602       endif
12603       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12604 !      do i=1,nres
12605       do i=nnt,nct
12606         do j=1,3
12607           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12608           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12609         ddc(j)=c(j,i)
12610         ddx(j)=c(j,i+nres)
12611           dcnorm_safe1(j)=dc_norm(j,i-1)
12612           dcnorm_safe2(j)=dc_norm(j,i)
12613           dxnorm_safe(j)=dc_norm(j,i+nres)
12614         enddo
12615       do j=1,3
12616         c(j,i)=ddc(j)+aincr
12617           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12618           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12619           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12620           dc(j,i)=c(j,i+1)-c(j,i)
12621           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12622           call int_from_cart1(.false.)
12623           if (.not.split_ene) then
12624            call zerograd
12625             call etotal(energia1)
12626             etot1=energia1(0)
12627             write (iout,*) "ij",i,j," etot1",etot1
12628           else
12629 !- split gradient
12630             call etotal_long(energia1)
12631             etot11=energia1(0)
12632             call etotal_short(energia1)
12633             etot12=energia1(0)
12634           endif
12635 !- end split gradient
12636 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12637         c(j,i)=ddc(j)-aincr
12638           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12639           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12640           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12641           dc(j,i)=c(j,i+1)-c(j,i)
12642           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12643           call int_from_cart1(.false.)
12644           if (.not.split_ene) then
12645             call zerograd
12646             call etotal(energia1)
12647             etot2=energia1(0)
12648             write (iout,*) "ij",i,j," etot2",etot2
12649           ggg(j)=(etot1-etot2)/(2*aincr)
12650           else
12651 !- split gradient
12652             call etotal_long(energia1)
12653             etot21=energia1(0)
12654           ggg(j)=(etot11-etot21)/(2*aincr)
12655             call etotal_short(energia1)
12656             etot22=energia1(0)
12657           ggg1(j)=(etot12-etot22)/(2*aincr)
12658 !- end split gradient
12659 !            write (iout,*) "etot21",etot21," etot22",etot22
12660           endif
12661 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12662         c(j,i)=ddc(j)
12663           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12664           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12665           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12666           dc(j,i)=c(j,i+1)-c(j,i)
12667           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12668           dc_norm(j,i-1)=dcnorm_safe1(j)
12669           dc_norm(j,i)=dcnorm_safe2(j)
12670           dc_norm(j,i+nres)=dxnorm_safe(j)
12671         enddo
12672       do j=1,3
12673         c(j,i+nres)=ddx(j)+aincr
12674           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12675           call int_from_cart1(.false.)
12676           if (.not.split_ene) then
12677             call zerograd
12678             call etotal(energia1)
12679             etot1=energia1(0)
12680           else
12681 !- split gradient
12682             call etotal_long(energia1)
12683             etot11=energia1(0)
12684             call etotal_short(energia1)
12685             etot12=energia1(0)
12686           endif
12687 !- end split gradient
12688         c(j,i+nres)=ddx(j)-aincr
12689           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12690           call int_from_cart1(.false.)
12691           if (.not.split_ene) then
12692            call zerograd
12693            call etotal(energia1)
12694             etot2=energia1(0)
12695           ggg(j+3)=(etot1-etot2)/(2*aincr)
12696           else
12697 !- split gradient
12698             call etotal_long(energia1)
12699             etot21=energia1(0)
12700           ggg(j+3)=(etot11-etot21)/(2*aincr)
12701             call etotal_short(energia1)
12702             etot22=energia1(0)
12703           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12704 !- end split gradient
12705           endif
12706 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12707         c(j,i+nres)=ddx(j)
12708           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12709           dc_norm(j,i+nres)=dxnorm_safe(j)
12710           call int_from_cart1(.false.)
12711         enddo
12712       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12713          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12714         if (split_ene) then
12715           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12716          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12717          k=1,6)
12718          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12719          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12720          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12721         endif
12722       enddo
12723       return
12724       end subroutine check_ecartint
12725 #else
12726 !-----------------------------------------------------------------------------
12727       subroutine check_ecartint
12728 ! Check the gradient of the energy in Cartesian coordinates.
12729       use io_base, only: intout
12730 !      implicit real*8 (a-h,o-z)
12731 !      include 'DIMENSIONS'
12732 !      include 'COMMON.CONTROL'
12733 !      include 'COMMON.CHAIN'
12734 !      include 'COMMON.DERIV'
12735 !      include 'COMMON.IOUNITS'
12736 !      include 'COMMON.VAR'
12737 !      include 'COMMON.CONTACTS'
12738 !      include 'COMMON.MD'
12739 !      include 'COMMON.LOCAL'
12740 !      include 'COMMON.SPLITELE'
12741       use comm_srutu
12742 !el      integer :: icall
12743 !el      common /srutu/ icall
12744       real(kind=8),dimension(6) :: ggg,ggg1
12745       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12746       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12747       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12748       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12749       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12750       real(kind=8),dimension(0:n_ene) :: energia,energia1
12751       integer :: uiparm(1)
12752       real(kind=8) :: urparm(1)
12753 !EL      external fdum
12754       integer :: i,j,k,nf
12755       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12756                    etot21,etot22
12757       r_cut=2.0d0
12758       rlambd=0.3d0
12759       icg=1
12760       nf=0
12761       nfl=0
12762       call intout
12763 !      call intcartderiv
12764 !      call checkintcartgrad
12765       call zerograd
12766       aincr=1.0D-7
12767       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12768       nf=0
12769       icall=0
12770       call geom_to_var(nvar,x)
12771       if (.not.split_ene) then
12772         call etotal(energia)
12773         etot=energia(0)
12774 !el        call enerprint(energia)
12775         call cartgrad
12776         icall =1
12777         do i=1,nres
12778           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12779         enddo
12780         do j=1,3
12781           grad_s(j,0)=gcart(j,0)
12782         enddo
12783         do i=1,nres
12784           do j=1,3
12785             grad_s(j,i)=gcart(j,i)
12786 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12787
12788 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12789             grad_s(j+3,i)=gxcart(j,i)
12790           enddo
12791         enddo
12792       else
12793 !- split gradient check
12794         call zerograd
12795         call etotal_long(energia)
12796 !el        call enerprint(energia)
12797         call cartgrad
12798         icall =1
12799         do i=1,nres
12800           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12801           (gxcart(j,i),j=1,3)
12802         enddo
12803         do j=1,3
12804           grad_s(j,0)=gcart(j,0)
12805         enddo
12806         do i=1,nres
12807           do j=1,3
12808             grad_s(j,i)=gcart(j,i)
12809 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12810             grad_s(j+3,i)=gxcart(j,i)
12811           enddo
12812         enddo
12813         call zerograd
12814         call etotal_short(energia)
12815 !el        call enerprint(energia)
12816         call cartgrad
12817         icall =1
12818         do i=1,nres
12819           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12820           (gxcart(j,i),j=1,3)
12821         enddo
12822         do j=1,3
12823           grad_s1(j,0)=gcart(j,0)
12824         enddo
12825         do i=1,nres
12826           do j=1,3
12827             grad_s1(j,i)=gcart(j,i)
12828             grad_s1(j+3,i)=gxcart(j,i)
12829           enddo
12830         enddo
12831       endif
12832       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12833       do i=0,nres
12834         do j=1,3
12835         xx(j)=c(j,i+nres)
12836         ddc(j)=dc(j,i)
12837         ddx(j)=dc(j,i+nres)
12838           do k=1,3
12839             dcnorm_safe(k)=dc_norm(k,i)
12840             dxnorm_safe(k)=dc_norm(k,i+nres)
12841           enddo
12842         enddo
12843       do j=1,3
12844         dc(j,i)=ddc(j)+aincr
12845           call chainbuild_cart
12846 #ifdef MPI
12847 ! Broadcast the order to compute internal coordinates to the slaves.
12848 !          if (nfgtasks.gt.1)
12849 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12850 #endif
12851 !          call int_from_cart1(.false.)
12852           if (.not.split_ene) then
12853            call zerograd
12854             call etotal(energia1)
12855             etot1=energia1(0)
12856 !            call enerprint(energia1)
12857           else
12858 !- split gradient
12859             call etotal_long(energia1)
12860             etot11=energia1(0)
12861             call etotal_short(energia1)
12862             etot12=energia1(0)
12863 !            write (iout,*) "etot11",etot11," etot12",etot12
12864           endif
12865 !- end split gradient
12866 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12867         dc(j,i)=ddc(j)-aincr
12868           call chainbuild_cart
12869 !          call int_from_cart1(.false.)
12870           if (.not.split_ene) then
12871                   call zerograd
12872             call etotal(energia1)
12873             etot2=energia1(0)
12874           ggg(j)=(etot1-etot2)/(2*aincr)
12875           else
12876 !- split gradient
12877             call etotal_long(energia1)
12878             etot21=energia1(0)
12879           ggg(j)=(etot11-etot21)/(2*aincr)
12880             call etotal_short(energia1)
12881             etot22=energia1(0)
12882           ggg1(j)=(etot12-etot22)/(2*aincr)
12883 !- end split gradient
12884 !            write (iout,*) "etot21",etot21," etot22",etot22
12885           endif
12886 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12887         dc(j,i)=ddc(j)
12888           call chainbuild_cart
12889         enddo
12890       do j=1,3
12891         dc(j,i+nres)=ddx(j)+aincr
12892           call chainbuild_cart
12893 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12894 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12895 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12896 !          write (iout,*) "dxnormnorm",dsqrt(
12897 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12898 !          write (iout,*) "dxnormnormsafe",dsqrt(
12899 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12900 !          write (iout,*)
12901           if (.not.split_ene) then
12902             call zerograd
12903             call etotal(energia1)
12904             etot1=energia1(0)
12905           else
12906 !- split gradient
12907             call etotal_long(energia1)
12908             etot11=energia1(0)
12909             call etotal_short(energia1)
12910             etot12=energia1(0)
12911           endif
12912 !- end split gradient
12913 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12914         dc(j,i+nres)=ddx(j)-aincr
12915           call chainbuild_cart
12916 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12917 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12918 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12919 !          write (iout,*)
12920 !          write (iout,*) "dxnormnorm",dsqrt(
12921 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12922 !          write (iout,*) "dxnormnormsafe",dsqrt(
12923 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12924           if (.not.split_ene) then
12925             call zerograd
12926             call etotal(energia1)
12927             etot2=energia1(0)
12928           ggg(j+3)=(etot1-etot2)/(2*aincr)
12929           else
12930 !- split gradient
12931             call etotal_long(energia1)
12932             etot21=energia1(0)
12933           ggg(j+3)=(etot11-etot21)/(2*aincr)
12934             call etotal_short(energia1)
12935             etot22=energia1(0)
12936           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12937 !- end split gradient
12938           endif
12939 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12940         dc(j,i+nres)=ddx(j)
12941           call chainbuild_cart
12942         enddo
12943       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12944          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12945         if (split_ene) then
12946           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12947          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12948          k=1,6)
12949          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12950          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12951          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12952         endif
12953       enddo
12954       return
12955       end subroutine check_ecartint
12956 #endif
12957 !-----------------------------------------------------------------------------
12958       subroutine check_eint
12959 ! Check the gradient of energy in internal coordinates.
12960 !      implicit real*8 (a-h,o-z)
12961 !      include 'DIMENSIONS'
12962 !      include 'COMMON.CHAIN'
12963 !      include 'COMMON.DERIV'
12964 !      include 'COMMON.IOUNITS'
12965 !      include 'COMMON.VAR'
12966 !      include 'COMMON.GEO'
12967       use comm_srutu
12968 !el      integer :: icall
12969 !el      common /srutu/ icall
12970       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12971       integer :: uiparm(1)
12972       real(kind=8) :: urparm(1)
12973       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12974       character(len=6) :: key
12975 !EL      external fdum
12976       integer :: i,ii,nf
12977       real(kind=8) :: xi,aincr,etot,etot1,etot2
12978       call zerograd
12979       aincr=1.0D-7
12980       print '(a)','Calling CHECK_INT.'
12981       nf=0
12982       nfl=0
12983       icg=1
12984       call geom_to_var(nvar,x)
12985       call var_to_geom(nvar,x)
12986       call chainbuild
12987       icall=1
12988 !      print *,'ICG=',ICG
12989       call etotal(energia)
12990       etot = energia(0)
12991 !el      call enerprint(energia)
12992 !      print *,'ICG=',ICG
12993 #ifdef MPL
12994       if (MyID.ne.BossID) then
12995         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12996         nf=x(nvar+1)
12997         nfl=x(nvar+2)
12998         icg=x(nvar+3)
12999       endif
13000 #endif
13001       nf=1
13002       nfl=3
13003 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13004       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13005 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13006       icall=1
13007       do i=1,nvar
13008         xi=x(i)
13009         x(i)=xi-0.5D0*aincr
13010         call var_to_geom(nvar,x)
13011         call chainbuild
13012         call etotal(energia1)
13013         etot1=energia1(0)
13014         x(i)=xi+0.5D0*aincr
13015         call var_to_geom(nvar,x)
13016         call chainbuild
13017         call etotal(energia2)
13018         etot2=energia2(0)
13019         gg(i)=(etot2-etot1)/aincr
13020         write (iout,*) i,etot1,etot2
13021         x(i)=xi
13022       enddo
13023       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13024           '     RelDiff*100% '
13025       do i=1,nvar
13026         if (i.le.nphi) then
13027           ii=i
13028           key = ' phi'
13029         else if (i.le.nphi+ntheta) then
13030           ii=i-nphi
13031           key=' theta'
13032         else if (i.le.nphi+ntheta+nside) then
13033            ii=i-(nphi+ntheta)
13034            key=' alpha'
13035         else
13036            ii=i-(nphi+ntheta+nside)
13037            key=' omega'
13038         endif
13039         write (iout,'(i3,a,i3,3(1pd16.6))') &
13040        i,key,ii,gg(i),gana(i),&
13041        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13042       enddo
13043       return
13044       end subroutine check_eint
13045 !-----------------------------------------------------------------------------
13046 ! econstr_local.F
13047 !-----------------------------------------------------------------------------
13048       subroutine Econstr_back
13049 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13050 !      implicit real*8 (a-h,o-z)
13051 !      include 'DIMENSIONS'
13052 !      include 'COMMON.CONTROL'
13053 !      include 'COMMON.VAR'
13054 !      include 'COMMON.MD'
13055       use MD_data
13056 !#ifndef LANG0
13057 !      include 'COMMON.LANGEVIN'
13058 !#else
13059 !      include 'COMMON.LANGEVIN.lang0'
13060 !#endif
13061 !      include 'COMMON.CHAIN'
13062 !      include 'COMMON.DERIV'
13063 !      include 'COMMON.GEO'
13064 !      include 'COMMON.LOCAL'
13065 !      include 'COMMON.INTERACT'
13066 !      include 'COMMON.IOUNITS'
13067 !      include 'COMMON.NAMES'
13068 !      include 'COMMON.TIME1'
13069       integer :: i,j,ii,k
13070       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13071
13072       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13073       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13074       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13075
13076       Uconst_back=0.0d0
13077       do i=1,nres
13078         dutheta(i)=0.0d0
13079         dugamma(i)=0.0d0
13080         do j=1,3
13081           duscdiff(j,i)=0.0d0
13082           duscdiffx(j,i)=0.0d0
13083         enddo
13084       enddo
13085       do i=1,nfrag_back
13086         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13087 !
13088 ! Deviations from theta angles
13089 !
13090         utheta_i=0.0d0
13091         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13092           dtheta_i=theta(j)-thetaref(j)
13093           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13094           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13095         enddo
13096         utheta(i)=utheta_i/(ii-1)
13097 !
13098 ! Deviations from gamma angles
13099 !
13100         ugamma_i=0.0d0
13101         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13102           dgamma_i=pinorm(phi(j)-phiref(j))
13103 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13104           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13105           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13106 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13107         enddo
13108         ugamma(i)=ugamma_i/(ii-2)
13109 !
13110 ! Deviations from local SC geometry
13111 !
13112         uscdiff(i)=0.0d0
13113         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13114           dxx=xxtab(j)-xxref(j)
13115           dyy=yytab(j)-yyref(j)
13116           dzz=zztab(j)-zzref(j)
13117           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13118           do k=1,3
13119             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13120              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13121              (ii-1)
13122             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13123              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13124              (ii-1)
13125             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13126            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13127             /(ii-1)
13128           enddo
13129 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13130 !     &      xxref(j),yyref(j),zzref(j)
13131         enddo
13132         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13133 !        write (iout,*) i," uscdiff",uscdiff(i)
13134 !
13135 ! Put together deviations from local geometry
13136 !
13137         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13138           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13139 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13140 !     &   " uconst_back",uconst_back
13141         utheta(i)=dsqrt(utheta(i))
13142         ugamma(i)=dsqrt(ugamma(i))
13143         uscdiff(i)=dsqrt(uscdiff(i))
13144       enddo
13145       return
13146       end subroutine Econstr_back
13147 !-----------------------------------------------------------------------------
13148 ! energy_p_new-sep_barrier.F
13149 !-----------------------------------------------------------------------------
13150       real(kind=8) function sscale(r)
13151 !      include "COMMON.SPLITELE"
13152       real(kind=8) :: r,gamm
13153       if(r.lt.r_cut-rlamb) then
13154         sscale=1.0d0
13155       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13156         gamm=(r-(r_cut-rlamb))/rlamb
13157         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13158       else
13159         sscale=0d0
13160       endif
13161       return
13162       end function sscale
13163       real(kind=8) function sscale_grad(r)
13164 !      include "COMMON.SPLITELE"
13165       real(kind=8) :: r,gamm
13166       if(r.lt.r_cut-rlamb) then
13167         sscale_grad=0.0d0
13168       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13169         gamm=(r-(r_cut-rlamb))/rlamb
13170         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13171       else
13172         sscale_grad=0d0
13173       endif
13174       return
13175       end function sscale_grad
13176
13177 !!!!!!!!!! PBCSCALE
13178       real(kind=8) function sscale_ele(r)
13179 !      include "COMMON.SPLITELE"
13180       real(kind=8) :: r,gamm
13181       if(r.lt.r_cut_ele-rlamb_ele) then
13182         sscale_ele=1.0d0
13183       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13184         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13185         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13186       else
13187         sscale_ele=0d0
13188       endif
13189       return
13190       end function sscale_ele
13191
13192       real(kind=8)  function sscagrad_ele(r)
13193       real(kind=8) :: r,gamm
13194 !      include "COMMON.SPLITELE"
13195       if(r.lt.r_cut_ele-rlamb_ele) then
13196         sscagrad_ele=0.0d0
13197       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13198         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13199         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13200       else
13201         sscagrad_ele=0.0d0
13202       endif
13203       return
13204       end function sscagrad_ele
13205       real(kind=8) function sscalelip(r)
13206       real(kind=8) r,gamm
13207         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13208       return
13209       end function sscalelip
13210 !C-----------------------------------------------------------------------
13211       real(kind=8) function sscagradlip(r)
13212       real(kind=8) r,gamm
13213         sscagradlip=r*(6.0d0*r-6.0d0)
13214       return
13215       end function sscagradlip
13216
13217 !!!!!!!!!!!!!!!
13218 !-----------------------------------------------------------------------------
13219       subroutine elj_long(evdw)
13220 !
13221 ! This subroutine calculates the interaction energy of nonbonded side chains
13222 ! assuming the LJ potential of interaction.
13223 !
13224 !      implicit real*8 (a-h,o-z)
13225 !      include 'DIMENSIONS'
13226 !      include 'COMMON.GEO'
13227 !      include 'COMMON.VAR'
13228 !      include 'COMMON.LOCAL'
13229 !      include 'COMMON.CHAIN'
13230 !      include 'COMMON.DERIV'
13231 !      include 'COMMON.INTERACT'
13232 !      include 'COMMON.TORSION'
13233 !      include 'COMMON.SBRIDGE'
13234 !      include 'COMMON.NAMES'
13235 !      include 'COMMON.IOUNITS'
13236 !      include 'COMMON.CONTACTS'
13237       real(kind=8),parameter :: accur=1.0d-10
13238       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13239 !el local variables
13240       integer :: i,iint,j,k,itypi,itypi1,itypj
13241       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13242       real(kind=8) :: e1,e2,evdwij,evdw
13243 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13244       evdw=0.0D0
13245       do i=iatsc_s,iatsc_e
13246         itypi=itype(i,1)
13247         if (itypi.eq.ntyp1) cycle
13248         itypi1=itype(i+1,1)
13249         xi=c(1,nres+i)
13250         yi=c(2,nres+i)
13251         zi=c(3,nres+i)
13252 !
13253 ! Calculate SC interaction energy.
13254 !
13255         do iint=1,nint_gr(i)
13256 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13257 !d   &                  'iend=',iend(i,iint)
13258           do j=istart(i,iint),iend(i,iint)
13259             itypj=itype(j,1)
13260             if (itypj.eq.ntyp1) cycle
13261             xj=c(1,nres+j)-xi
13262             yj=c(2,nres+j)-yi
13263             zj=c(3,nres+j)-zi
13264             rij=xj*xj+yj*yj+zj*zj
13265             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13266             if (sss.lt.1.0d0) then
13267               rrij=1.0D0/rij
13268               eps0ij=eps(itypi,itypj)
13269               fac=rrij**expon2
13270               e1=fac*fac*aa_aq(itypi,itypj)
13271               e2=fac*bb_aq(itypi,itypj)
13272               evdwij=e1+e2
13273               evdw=evdw+(1.0d0-sss)*evdwij
13274 !
13275 ! Calculate the components of the gradient in DC and X
13276 !
13277               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13278               gg(1)=xj*fac
13279               gg(2)=yj*fac
13280               gg(3)=zj*fac
13281               do k=1,3
13282                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13283                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13284                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13285                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13286               enddo
13287             endif
13288           enddo      ! j
13289         enddo        ! iint
13290       enddo          ! i
13291       do i=1,nct
13292         do j=1,3
13293           gvdwc(j,i)=expon*gvdwc(j,i)
13294           gvdwx(j,i)=expon*gvdwx(j,i)
13295         enddo
13296       enddo
13297 !******************************************************************************
13298 !
13299 !                              N O T E !!!
13300 !
13301 ! To save time, the factor of EXPON has been extracted from ALL components
13302 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13303 ! use!
13304 !
13305 !******************************************************************************
13306       return
13307       end subroutine elj_long
13308 !-----------------------------------------------------------------------------
13309       subroutine elj_short(evdw)
13310 !
13311 ! This subroutine calculates the interaction energy of nonbonded side chains
13312 ! assuming the LJ potential of interaction.
13313 !
13314 !      implicit real*8 (a-h,o-z)
13315 !      include 'DIMENSIONS'
13316 !      include 'COMMON.GEO'
13317 !      include 'COMMON.VAR'
13318 !      include 'COMMON.LOCAL'
13319 !      include 'COMMON.CHAIN'
13320 !      include 'COMMON.DERIV'
13321 !      include 'COMMON.INTERACT'
13322 !      include 'COMMON.TORSION'
13323 !      include 'COMMON.SBRIDGE'
13324 !      include 'COMMON.NAMES'
13325 !      include 'COMMON.IOUNITS'
13326 !      include 'COMMON.CONTACTS'
13327       real(kind=8),parameter :: accur=1.0d-10
13328       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13329 !el local variables
13330       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13331       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13332       real(kind=8) :: e1,e2,evdwij,evdw
13333 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13334       evdw=0.0D0
13335       do i=iatsc_s,iatsc_e
13336         itypi=itype(i,1)
13337         if (itypi.eq.ntyp1) cycle
13338         itypi1=itype(i+1,1)
13339         xi=c(1,nres+i)
13340         yi=c(2,nres+i)
13341         zi=c(3,nres+i)
13342 ! Change 12/1/95
13343         num_conti=0
13344 !
13345 ! Calculate SC interaction energy.
13346 !
13347         do iint=1,nint_gr(i)
13348 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13349 !d   &                  'iend=',iend(i,iint)
13350           do j=istart(i,iint),iend(i,iint)
13351             itypj=itype(j,1)
13352             if (itypj.eq.ntyp1) cycle
13353             xj=c(1,nres+j)-xi
13354             yj=c(2,nres+j)-yi
13355             zj=c(3,nres+j)-zi
13356 ! Change 12/1/95 to calculate four-body interactions
13357             rij=xj*xj+yj*yj+zj*zj
13358             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13359             if (sss.gt.0.0d0) then
13360               rrij=1.0D0/rij
13361               eps0ij=eps(itypi,itypj)
13362               fac=rrij**expon2
13363               e1=fac*fac*aa_aq(itypi,itypj)
13364               e2=fac*bb_aq(itypi,itypj)
13365               evdwij=e1+e2
13366               evdw=evdw+sss*evdwij
13367 !
13368 ! Calculate the components of the gradient in DC and X
13369 !
13370               fac=-rrij*(e1+evdwij)*sss
13371               gg(1)=xj*fac
13372               gg(2)=yj*fac
13373               gg(3)=zj*fac
13374               do k=1,3
13375                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13376                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13377                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13378                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13379               enddo
13380             endif
13381           enddo      ! j
13382         enddo        ! iint
13383       enddo          ! i
13384       do i=1,nct
13385         do j=1,3
13386           gvdwc(j,i)=expon*gvdwc(j,i)
13387           gvdwx(j,i)=expon*gvdwx(j,i)
13388         enddo
13389       enddo
13390 !******************************************************************************
13391 !
13392 !                              N O T E !!!
13393 !
13394 ! To save time, the factor of EXPON has been extracted from ALL components
13395 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13396 ! use!
13397 !
13398 !******************************************************************************
13399       return
13400       end subroutine elj_short
13401 !-----------------------------------------------------------------------------
13402       subroutine eljk_long(evdw)
13403 !
13404 ! This subroutine calculates the interaction energy of nonbonded side chains
13405 ! assuming the LJK potential of interaction.
13406 !
13407 !      implicit real*8 (a-h,o-z)
13408 !      include 'DIMENSIONS'
13409 !      include 'COMMON.GEO'
13410 !      include 'COMMON.VAR'
13411 !      include 'COMMON.LOCAL'
13412 !      include 'COMMON.CHAIN'
13413 !      include 'COMMON.DERIV'
13414 !      include 'COMMON.INTERACT'
13415 !      include 'COMMON.IOUNITS'
13416 !      include 'COMMON.NAMES'
13417       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13418       logical :: scheck
13419 !el local variables
13420       integer :: i,iint,j,k,itypi,itypi1,itypj
13421       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13422                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13423 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13424       evdw=0.0D0
13425       do i=iatsc_s,iatsc_e
13426         itypi=itype(i,1)
13427         if (itypi.eq.ntyp1) cycle
13428         itypi1=itype(i+1,1)
13429         xi=c(1,nres+i)
13430         yi=c(2,nres+i)
13431         zi=c(3,nres+i)
13432 !
13433 ! Calculate SC interaction energy.
13434 !
13435         do iint=1,nint_gr(i)
13436           do j=istart(i,iint),iend(i,iint)
13437             itypj=itype(j,1)
13438             if (itypj.eq.ntyp1) cycle
13439             xj=c(1,nres+j)-xi
13440             yj=c(2,nres+j)-yi
13441             zj=c(3,nres+j)-zi
13442             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13443             fac_augm=rrij**expon
13444             e_augm=augm(itypi,itypj)*fac_augm
13445             r_inv_ij=dsqrt(rrij)
13446             rij=1.0D0/r_inv_ij
13447             sss=sscale(rij/sigma(itypi,itypj))
13448             if (sss.lt.1.0d0) then
13449               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13450               fac=r_shift_inv**expon
13451               e1=fac*fac*aa_aq(itypi,itypj)
13452               e2=fac*bb_aq(itypi,itypj)
13453               evdwij=e_augm+e1+e2
13454 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13455 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13456 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13457 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13458 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13459 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13460 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13461               evdw=evdw+(1.0d0-sss)*evdwij
13462 !
13463 ! Calculate the components of the gradient in DC and X
13464 !
13465               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13466               fac=fac*(1.0d0-sss)
13467               gg(1)=xj*fac
13468               gg(2)=yj*fac
13469               gg(3)=zj*fac
13470               do k=1,3
13471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13475               enddo
13476             endif
13477           enddo      ! j
13478         enddo        ! iint
13479       enddo          ! i
13480       do i=1,nct
13481         do j=1,3
13482           gvdwc(j,i)=expon*gvdwc(j,i)
13483           gvdwx(j,i)=expon*gvdwx(j,i)
13484         enddo
13485       enddo
13486       return
13487       end subroutine eljk_long
13488 !-----------------------------------------------------------------------------
13489       subroutine eljk_short(evdw)
13490 !
13491 ! This subroutine calculates the interaction energy of nonbonded side chains
13492 ! assuming the LJK potential of interaction.
13493 !
13494 !      implicit real*8 (a-h,o-z)
13495 !      include 'DIMENSIONS'
13496 !      include 'COMMON.GEO'
13497 !      include 'COMMON.VAR'
13498 !      include 'COMMON.LOCAL'
13499 !      include 'COMMON.CHAIN'
13500 !      include 'COMMON.DERIV'
13501 !      include 'COMMON.INTERACT'
13502 !      include 'COMMON.IOUNITS'
13503 !      include 'COMMON.NAMES'
13504       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13505       logical :: scheck
13506 !el local variables
13507       integer :: i,iint,j,k,itypi,itypi1,itypj
13508       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13509                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13510 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13511       evdw=0.0D0
13512       do i=iatsc_s,iatsc_e
13513         itypi=itype(i,1)
13514         if (itypi.eq.ntyp1) cycle
13515         itypi1=itype(i+1,1)
13516         xi=c(1,nres+i)
13517         yi=c(2,nres+i)
13518         zi=c(3,nres+i)
13519 !
13520 ! Calculate SC interaction energy.
13521 !
13522         do iint=1,nint_gr(i)
13523           do j=istart(i,iint),iend(i,iint)
13524             itypj=itype(j,1)
13525             if (itypj.eq.ntyp1) cycle
13526             xj=c(1,nres+j)-xi
13527             yj=c(2,nres+j)-yi
13528             zj=c(3,nres+j)-zi
13529             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13530             fac_augm=rrij**expon
13531             e_augm=augm(itypi,itypj)*fac_augm
13532             r_inv_ij=dsqrt(rrij)
13533             rij=1.0D0/r_inv_ij
13534             sss=sscale(rij/sigma(itypi,itypj))
13535             if (sss.gt.0.0d0) then
13536               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13537               fac=r_shift_inv**expon
13538               e1=fac*fac*aa_aq(itypi,itypj)
13539               e2=fac*bb_aq(itypi,itypj)
13540               evdwij=e_augm+e1+e2
13541 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13542 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13543 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13544 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13545 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13546 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13547 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13548               evdw=evdw+sss*evdwij
13549 !
13550 ! Calculate the components of the gradient in DC and X
13551 !
13552               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13553               fac=fac*sss
13554               gg(1)=xj*fac
13555               gg(2)=yj*fac
13556               gg(3)=zj*fac
13557               do k=1,3
13558                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13559                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13560                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13561                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13562               enddo
13563             endif
13564           enddo      ! j
13565         enddo        ! iint
13566       enddo          ! i
13567       do i=1,nct
13568         do j=1,3
13569           gvdwc(j,i)=expon*gvdwc(j,i)
13570           gvdwx(j,i)=expon*gvdwx(j,i)
13571         enddo
13572       enddo
13573       return
13574       end subroutine eljk_short
13575 !-----------------------------------------------------------------------------
13576       subroutine ebp_long(evdw)
13577 !
13578 ! This subroutine calculates the interaction energy of nonbonded side chains
13579 ! assuming the Berne-Pechukas potential of interaction.
13580 !
13581       use calc_data
13582 !      implicit real*8 (a-h,o-z)
13583 !      include 'DIMENSIONS'
13584 !      include 'COMMON.GEO'
13585 !      include 'COMMON.VAR'
13586 !      include 'COMMON.LOCAL'
13587 !      include 'COMMON.CHAIN'
13588 !      include 'COMMON.DERIV'
13589 !      include 'COMMON.NAMES'
13590 !      include 'COMMON.INTERACT'
13591 !      include 'COMMON.IOUNITS'
13592 !      include 'COMMON.CALC'
13593       use comm_srutu
13594 !el      integer :: icall
13595 !el      common /srutu/ icall
13596 !     double precision rrsave(maxdim)
13597       logical :: lprn
13598 !el local variables
13599       integer :: iint,itypi,itypi1,itypj
13600       real(kind=8) :: rrij,xi,yi,zi,fac
13601       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13602       evdw=0.0D0
13603 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13604       evdw=0.0D0
13605 !     if (icall.eq.0) then
13606 !       lprn=.true.
13607 !     else
13608         lprn=.false.
13609 !     endif
13610 !el      ind=0
13611       do i=iatsc_s,iatsc_e
13612         itypi=itype(i,1)
13613         if (itypi.eq.ntyp1) cycle
13614         itypi1=itype(i+1,1)
13615         xi=c(1,nres+i)
13616         yi=c(2,nres+i)
13617         zi=c(3,nres+i)
13618         dxi=dc_norm(1,nres+i)
13619         dyi=dc_norm(2,nres+i)
13620         dzi=dc_norm(3,nres+i)
13621 !        dsci_inv=dsc_inv(itypi)
13622         dsci_inv=vbld_inv(i+nres)
13623 !
13624 ! Calculate SC interaction energy.
13625 !
13626         do iint=1,nint_gr(i)
13627           do j=istart(i,iint),iend(i,iint)
13628 !el            ind=ind+1
13629             itypj=itype(j,1)
13630             if (itypj.eq.ntyp1) cycle
13631 !            dscj_inv=dsc_inv(itypj)
13632             dscj_inv=vbld_inv(j+nres)
13633             chi1=chi(itypi,itypj)
13634             chi2=chi(itypj,itypi)
13635             chi12=chi1*chi2
13636             chip1=chip(itypi)
13637             chip2=chip(itypj)
13638             chip12=chip1*chip2
13639             alf1=alp(itypi)
13640             alf2=alp(itypj)
13641             alf12=0.5D0*(alf1+alf2)
13642             xj=c(1,nres+j)-xi
13643             yj=c(2,nres+j)-yi
13644             zj=c(3,nres+j)-zi
13645             dxj=dc_norm(1,nres+j)
13646             dyj=dc_norm(2,nres+j)
13647             dzj=dc_norm(3,nres+j)
13648             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13649             rij=dsqrt(rrij)
13650             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13651
13652             if (sss.lt.1.0d0) then
13653
13654 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13655               call sc_angular
13656 ! Calculate whole angle-dependent part of epsilon and contributions
13657 ! to its derivatives
13658               fac=(rrij*sigsq)**expon2
13659               e1=fac*fac*aa_aq(itypi,itypj)
13660               e2=fac*bb_aq(itypi,itypj)
13661               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13662               eps2der=evdwij*eps3rt
13663               eps3der=evdwij*eps2rt
13664               evdwij=evdwij*eps2rt*eps3rt
13665               evdw=evdw+evdwij*(1.0d0-sss)
13666               if (lprn) then
13667               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13668               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13669 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13670 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13671 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13672 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13673 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13674 !d     &          evdwij
13675               endif
13676 ! Calculate gradient components.
13677               e1=e1*eps1*eps2rt**2*eps3rt**2
13678               fac=-expon*(e1+evdwij)
13679               sigder=fac/sigsq
13680               fac=rrij*fac
13681 ! Calculate radial part of the gradient
13682               gg(1)=xj*fac
13683               gg(2)=yj*fac
13684               gg(3)=zj*fac
13685 ! Calculate the angular part of the gradient and sum add the contributions
13686 ! to the appropriate components of the Cartesian gradient.
13687               call sc_grad_scale(1.0d0-sss)
13688             endif
13689           enddo      ! j
13690         enddo        ! iint
13691       enddo          ! i
13692 !     stop
13693       return
13694       end subroutine ebp_long
13695 !-----------------------------------------------------------------------------
13696       subroutine ebp_short(evdw)
13697 !
13698 ! This subroutine calculates the interaction energy of nonbonded side chains
13699 ! assuming the Berne-Pechukas potential of interaction.
13700 !
13701       use calc_data
13702 !      implicit real*8 (a-h,o-z)
13703 !      include 'DIMENSIONS'
13704 !      include 'COMMON.GEO'
13705 !      include 'COMMON.VAR'
13706 !      include 'COMMON.LOCAL'
13707 !      include 'COMMON.CHAIN'
13708 !      include 'COMMON.DERIV'
13709 !      include 'COMMON.NAMES'
13710 !      include 'COMMON.INTERACT'
13711 !      include 'COMMON.IOUNITS'
13712 !      include 'COMMON.CALC'
13713       use comm_srutu
13714 !el      integer :: icall
13715 !el      common /srutu/ icall
13716 !     double precision rrsave(maxdim)
13717       logical :: lprn
13718 !el local variables
13719       integer :: iint,itypi,itypi1,itypj
13720       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13721       real(kind=8) :: sss,e1,e2,evdw
13722       evdw=0.0D0
13723 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13724       evdw=0.0D0
13725 !     if (icall.eq.0) then
13726 !       lprn=.true.
13727 !     else
13728         lprn=.false.
13729 !     endif
13730 !el      ind=0
13731       do i=iatsc_s,iatsc_e
13732         itypi=itype(i,1)
13733         if (itypi.eq.ntyp1) cycle
13734         itypi1=itype(i+1,1)
13735         xi=c(1,nres+i)
13736         yi=c(2,nres+i)
13737         zi=c(3,nres+i)
13738         dxi=dc_norm(1,nres+i)
13739         dyi=dc_norm(2,nres+i)
13740         dzi=dc_norm(3,nres+i)
13741 !        dsci_inv=dsc_inv(itypi)
13742         dsci_inv=vbld_inv(i+nres)
13743 !
13744 ! Calculate SC interaction energy.
13745 !
13746         do iint=1,nint_gr(i)
13747           do j=istart(i,iint),iend(i,iint)
13748 !el            ind=ind+1
13749             itypj=itype(j,1)
13750             if (itypj.eq.ntyp1) cycle
13751 !            dscj_inv=dsc_inv(itypj)
13752             dscj_inv=vbld_inv(j+nres)
13753             chi1=chi(itypi,itypj)
13754             chi2=chi(itypj,itypi)
13755             chi12=chi1*chi2
13756             chip1=chip(itypi)
13757             chip2=chip(itypj)
13758             chip12=chip1*chip2
13759             alf1=alp(itypi)
13760             alf2=alp(itypj)
13761             alf12=0.5D0*(alf1+alf2)
13762             xj=c(1,nres+j)-xi
13763             yj=c(2,nres+j)-yi
13764             zj=c(3,nres+j)-zi
13765             dxj=dc_norm(1,nres+j)
13766             dyj=dc_norm(2,nres+j)
13767             dzj=dc_norm(3,nres+j)
13768             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13769             rij=dsqrt(rrij)
13770             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13771
13772             if (sss.gt.0.0d0) then
13773
13774 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13775               call sc_angular
13776 ! Calculate whole angle-dependent part of epsilon and contributions
13777 ! to its derivatives
13778               fac=(rrij*sigsq)**expon2
13779               e1=fac*fac*aa_aq(itypi,itypj)
13780               e2=fac*bb_aq(itypi,itypj)
13781               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13782               eps2der=evdwij*eps3rt
13783               eps3der=evdwij*eps2rt
13784               evdwij=evdwij*eps2rt*eps3rt
13785               evdw=evdw+evdwij*sss
13786               if (lprn) then
13787               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13788               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13789 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13790 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13791 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13792 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13793 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13794 !d     &          evdwij
13795               endif
13796 ! Calculate gradient components.
13797               e1=e1*eps1*eps2rt**2*eps3rt**2
13798               fac=-expon*(e1+evdwij)
13799               sigder=fac/sigsq
13800               fac=rrij*fac
13801 ! Calculate radial part of the gradient
13802               gg(1)=xj*fac
13803               gg(2)=yj*fac
13804               gg(3)=zj*fac
13805 ! Calculate the angular part of the gradient and sum add the contributions
13806 ! to the appropriate components of the Cartesian gradient.
13807               call sc_grad_scale(sss)
13808             endif
13809           enddo      ! j
13810         enddo        ! iint
13811       enddo          ! i
13812 !     stop
13813       return
13814       end subroutine ebp_short
13815 !-----------------------------------------------------------------------------
13816       subroutine egb_long(evdw)
13817 !
13818 ! This subroutine calculates the interaction energy of nonbonded side chains
13819 ! assuming the Gay-Berne potential of interaction.
13820 !
13821       use calc_data
13822 !      implicit real*8 (a-h,o-z)
13823 !      include 'DIMENSIONS'
13824 !      include 'COMMON.GEO'
13825 !      include 'COMMON.VAR'
13826 !      include 'COMMON.LOCAL'
13827 !      include 'COMMON.CHAIN'
13828 !      include 'COMMON.DERIV'
13829 !      include 'COMMON.NAMES'
13830 !      include 'COMMON.INTERACT'
13831 !      include 'COMMON.IOUNITS'
13832 !      include 'COMMON.CALC'
13833 !      include 'COMMON.CONTROL'
13834       logical :: lprn
13835 !el local variables
13836       integer :: iint,itypi,itypi1,itypj,subchap
13837       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13838       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13839       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13840                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13841                     ssgradlipi,ssgradlipj
13842
13843
13844       evdw=0.0D0
13845 !cccc      energy_dec=.false.
13846 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13847       evdw=0.0D0
13848       lprn=.false.
13849 !     if (icall.eq.0) lprn=.false.
13850 !el      ind=0
13851       do i=iatsc_s,iatsc_e
13852         itypi=itype(i,1)
13853         if (itypi.eq.ntyp1) cycle
13854         itypi1=itype(i+1,1)
13855         xi=c(1,nres+i)
13856         yi=c(2,nres+i)
13857         zi=c(3,nres+i)
13858           xi=mod(xi,boxxsize)
13859           if (xi.lt.0) xi=xi+boxxsize
13860           yi=mod(yi,boxysize)
13861           if (yi.lt.0) yi=yi+boxysize
13862           zi=mod(zi,boxzsize)
13863           if (zi.lt.0) zi=zi+boxzsize
13864        if ((zi.gt.bordlipbot)    &
13865         .and.(zi.lt.bordliptop)) then
13866 !C the energy transfer exist
13867         if (zi.lt.buflipbot) then
13868 !C what fraction I am in
13869          fracinbuf=1.0d0-    &
13870              ((zi-bordlipbot)/lipbufthick)
13871 !C lipbufthick is thickenes of lipid buffore
13872          sslipi=sscalelip(fracinbuf)
13873          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13874         elseif (zi.gt.bufliptop) then
13875          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13876          sslipi=sscalelip(fracinbuf)
13877          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13878         else
13879          sslipi=1.0d0
13880          ssgradlipi=0.0
13881         endif
13882        else
13883          sslipi=0.0d0
13884          ssgradlipi=0.0
13885        endif
13886
13887         dxi=dc_norm(1,nres+i)
13888         dyi=dc_norm(2,nres+i)
13889         dzi=dc_norm(3,nres+i)
13890 !        dsci_inv=dsc_inv(itypi)
13891         dsci_inv=vbld_inv(i+nres)
13892 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13893 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13894 !
13895 ! Calculate SC interaction energy.
13896 !
13897         do iint=1,nint_gr(i)
13898           do j=istart(i,iint),iend(i,iint)
13899             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13900 !              call dyn_ssbond_ene(i,j,evdwij)
13901 !              evdw=evdw+evdwij
13902 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13903 !                              'evdw',i,j,evdwij,' ss'
13904 !              if (energy_dec) write (iout,*) &
13905 !                              'evdw',i,j,evdwij,' ss'
13906 !             do k=j+1,iend(i,iint)
13907 !C search over all next residues
13908 !              if (dyn_ss_mask(k)) then
13909 !C check if they are cysteins
13910 !C              write(iout,*) 'k=',k
13911
13912 !c              write(iout,*) "PRZED TRI", evdwij
13913 !               evdwij_przed_tri=evdwij
13914 !              call triple_ssbond_ene(i,j,k,evdwij)
13915 !c               if(evdwij_przed_tri.ne.evdwij) then
13916 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13917 !c               endif
13918
13919 !c              write(iout,*) "PO TRI", evdwij
13920 !C call the energy function that removes the artifical triple disulfide
13921 !C bond the soubroutine is located in ssMD.F
13922 !              evdw=evdw+evdwij
13923               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13924                             'evdw',i,j,evdwij,'tss'
13925 !              endif!dyn_ss_mask(k)
13926 !             enddo! k
13927
13928             ELSE
13929 !el            ind=ind+1
13930             itypj=itype(j,1)
13931             if (itypj.eq.ntyp1) cycle
13932 !            dscj_inv=dsc_inv(itypj)
13933             dscj_inv=vbld_inv(j+nres)
13934 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13935 !     &       1.0d0/vbld(j+nres)
13936 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13937             sig0ij=sigma(itypi,itypj)
13938             chi1=chi(itypi,itypj)
13939             chi2=chi(itypj,itypi)
13940             chi12=chi1*chi2
13941             chip1=chip(itypi)
13942             chip2=chip(itypj)
13943             chip12=chip1*chip2
13944             alf1=alp(itypi)
13945             alf2=alp(itypj)
13946             alf12=0.5D0*(alf1+alf2)
13947             xj=c(1,nres+j)
13948             yj=c(2,nres+j)
13949             zj=c(3,nres+j)
13950 ! Searching for nearest neighbour
13951           xj=mod(xj,boxxsize)
13952           if (xj.lt.0) xj=xj+boxxsize
13953           yj=mod(yj,boxysize)
13954           if (yj.lt.0) yj=yj+boxysize
13955           zj=mod(zj,boxzsize)
13956           if (zj.lt.0) zj=zj+boxzsize
13957        if ((zj.gt.bordlipbot)   &
13958       .and.(zj.lt.bordliptop)) then
13959 !C the energy transfer exist
13960         if (zj.lt.buflipbot) then
13961 !C what fraction I am in
13962          fracinbuf=1.0d0-  &
13963              ((zj-bordlipbot)/lipbufthick)
13964 !C lipbufthick is thickenes of lipid buffore
13965          sslipj=sscalelip(fracinbuf)
13966          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13967         elseif (zj.gt.bufliptop) then
13968          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13969          sslipj=sscalelip(fracinbuf)
13970          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13971         else
13972          sslipj=1.0d0
13973          ssgradlipj=0.0
13974         endif
13975        else
13976          sslipj=0.0d0
13977          ssgradlipj=0.0
13978        endif
13979       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13980        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13981       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13982        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13983
13984           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13985           xj_safe=xj
13986           yj_safe=yj
13987           zj_safe=zj
13988           subchap=0
13989           do xshift=-1,1
13990           do yshift=-1,1
13991           do zshift=-1,1
13992           xj=xj_safe+xshift*boxxsize
13993           yj=yj_safe+yshift*boxysize
13994           zj=zj_safe+zshift*boxzsize
13995           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13996           if(dist_temp.lt.dist_init) then
13997             dist_init=dist_temp
13998             xj_temp=xj
13999             yj_temp=yj
14000             zj_temp=zj
14001             subchap=1
14002           endif
14003           enddo
14004           enddo
14005           enddo
14006           if (subchap.eq.1) then
14007           xj=xj_temp-xi
14008           yj=yj_temp-yi
14009           zj=zj_temp-zi
14010           else
14011           xj=xj_safe-xi
14012           yj=yj_safe-yi
14013           zj=zj_safe-zi
14014           endif
14015
14016             dxj=dc_norm(1,nres+j)
14017             dyj=dc_norm(2,nres+j)
14018             dzj=dc_norm(3,nres+j)
14019             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14020             rij=dsqrt(rrij)
14021             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14022             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14023             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14024             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14025             if (sss_ele_cut.le.0.0) cycle
14026             if (sss.lt.1.0d0) then
14027
14028 ! Calculate angle-dependent terms of energy and contributions to their
14029 ! derivatives.
14030               call sc_angular
14031               sigsq=1.0D0/sigsq
14032               sig=sig0ij*dsqrt(sigsq)
14033               rij_shift=1.0D0/rij-sig+sig0ij
14034 ! for diagnostics; uncomment
14035 !              rij_shift=1.2*sig0ij
14036 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14037               if (rij_shift.le.0.0D0) then
14038                 evdw=1.0D20
14039 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14040 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14041 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14042                 return
14043               endif
14044               sigder=-sig*sigsq
14045 !---------------------------------------------------------------
14046               rij_shift=1.0D0/rij_shift
14047               fac=rij_shift**expon
14048               e1=fac*fac*aa
14049               e2=fac*bb
14050               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14051               eps2der=evdwij*eps3rt
14052               eps3der=evdwij*eps2rt
14053 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14054 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14055               evdwij=evdwij*eps2rt*eps3rt
14056               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14057               if (lprn) then
14058               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14059               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14060               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14061                 restyp(itypi,1),i,restyp(itypj,1),j,&
14062                 epsi,sigm,chi1,chi2,chip1,chip2,&
14063                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14064                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14065                 evdwij
14066               endif
14067
14068               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14069                               'evdw',i,j,evdwij
14070 !              if (energy_dec) write (iout,*) &
14071 !                              'evdw',i,j,evdwij,"egb_long"
14072
14073 ! Calculate gradient components.
14074               e1=e1*eps1*eps2rt**2*eps3rt**2
14075               fac=-expon*(e1+evdwij)*rij_shift
14076               sigder=fac*sigder
14077               fac=rij*fac
14078               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14079             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
14080             /sigmaii(itypi,itypj))
14081 !              fac=0.0d0
14082 ! Calculate the radial part of the gradient
14083               gg(1)=xj*fac
14084               gg(2)=yj*fac
14085               gg(3)=zj*fac
14086 ! Calculate angular part of the gradient.
14087               call sc_grad_scale(1.0d0-sss)
14088             ENDIF    !mask_dyn_ss
14089             endif
14090           enddo      ! j
14091         enddo        ! iint
14092       enddo          ! i
14093 !      write (iout,*) "Number of loop steps in EGB:",ind
14094 !ccc      energy_dec=.false.
14095       return
14096       end subroutine egb_long
14097 !-----------------------------------------------------------------------------
14098       subroutine egb_short(evdw)
14099 !
14100 ! This subroutine calculates the interaction energy of nonbonded side chains
14101 ! assuming the Gay-Berne potential of interaction.
14102 !
14103       use calc_data
14104 !      implicit real*8 (a-h,o-z)
14105 !      include 'DIMENSIONS'
14106 !      include 'COMMON.GEO'
14107 !      include 'COMMON.VAR'
14108 !      include 'COMMON.LOCAL'
14109 !      include 'COMMON.CHAIN'
14110 !      include 'COMMON.DERIV'
14111 !      include 'COMMON.NAMES'
14112 !      include 'COMMON.INTERACT'
14113 !      include 'COMMON.IOUNITS'
14114 !      include 'COMMON.CALC'
14115 !      include 'COMMON.CONTROL'
14116       logical :: lprn
14117 !el local variables
14118       integer :: iint,itypi,itypi1,itypj,subchap
14119       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14120       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14121       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14122                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14123                     ssgradlipi,ssgradlipj
14124       evdw=0.0D0
14125 !cccc      energy_dec=.false.
14126 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14127       evdw=0.0D0
14128       lprn=.false.
14129 !     if (icall.eq.0) lprn=.false.
14130 !el      ind=0
14131       do i=iatsc_s,iatsc_e
14132         itypi=itype(i,1)
14133         if (itypi.eq.ntyp1) cycle
14134         itypi1=itype(i+1,1)
14135         xi=c(1,nres+i)
14136         yi=c(2,nres+i)
14137         zi=c(3,nres+i)
14138           xi=mod(xi,boxxsize)
14139           if (xi.lt.0) xi=xi+boxxsize
14140           yi=mod(yi,boxysize)
14141           if (yi.lt.0) yi=yi+boxysize
14142           zi=mod(zi,boxzsize)
14143           if (zi.lt.0) zi=zi+boxzsize
14144        if ((zi.gt.bordlipbot)    &
14145         .and.(zi.lt.bordliptop)) then
14146 !C the energy transfer exist
14147         if (zi.lt.buflipbot) then
14148 !C what fraction I am in
14149          fracinbuf=1.0d0-    &
14150              ((zi-bordlipbot)/lipbufthick)
14151 !C lipbufthick is thickenes of lipid buffore
14152          sslipi=sscalelip(fracinbuf)
14153          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14154         elseif (zi.gt.bufliptop) then
14155          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14156          sslipi=sscalelip(fracinbuf)
14157          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14158         else
14159          sslipi=1.0d0
14160          ssgradlipi=0.0
14161         endif
14162        else
14163          sslipi=0.0d0
14164          ssgradlipi=0.0
14165        endif
14166
14167         dxi=dc_norm(1,nres+i)
14168         dyi=dc_norm(2,nres+i)
14169         dzi=dc_norm(3,nres+i)
14170 !        dsci_inv=dsc_inv(itypi)
14171         dsci_inv=vbld_inv(i+nres)
14172
14173         dxi=dc_norm(1,nres+i)
14174         dyi=dc_norm(2,nres+i)
14175         dzi=dc_norm(3,nres+i)
14176 !        dsci_inv=dsc_inv(itypi)
14177         dsci_inv=vbld_inv(i+nres)
14178 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14179 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14180 !
14181 ! Calculate SC interaction energy.
14182 !
14183         do iint=1,nint_gr(i)
14184           do j=istart(i,iint),iend(i,iint)
14185             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14186               call dyn_ssbond_ene(i,j,evdwij)
14187               evdw=evdw+evdwij
14188               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14189                               'evdw',i,j,evdwij,' ss'
14190              do k=j+1,iend(i,iint)
14191 !C search over all next residues
14192               if (dyn_ss_mask(k)) then
14193 !C check if they are cysteins
14194 !C              write(iout,*) 'k=',k
14195
14196 !c              write(iout,*) "PRZED TRI", evdwij
14197 !               evdwij_przed_tri=evdwij
14198               call triple_ssbond_ene(i,j,k,evdwij)
14199 !c               if(evdwij_przed_tri.ne.evdwij) then
14200 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14201 !c               endif
14202
14203 !c              write(iout,*) "PO TRI", evdwij
14204 !C call the energy function that removes the artifical triple disulfide
14205 !C bond the soubroutine is located in ssMD.F
14206               evdw=evdw+evdwij
14207               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14208                             'evdw',i,j,evdwij,'tss'
14209               endif!dyn_ss_mask(k)
14210              enddo! k
14211
14212 !              if (energy_dec) write (iout,*) &
14213 !                              'evdw',i,j,evdwij,' ss'
14214             ELSE
14215 !el            ind=ind+1
14216             itypj=itype(j,1)
14217             if (itypj.eq.ntyp1) cycle
14218 !            dscj_inv=dsc_inv(itypj)
14219             dscj_inv=vbld_inv(j+nres)
14220 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14221 !     &       1.0d0/vbld(j+nres)
14222 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14223             sig0ij=sigma(itypi,itypj)
14224             chi1=chi(itypi,itypj)
14225             chi2=chi(itypj,itypi)
14226             chi12=chi1*chi2
14227             chip1=chip(itypi)
14228             chip2=chip(itypj)
14229             chip12=chip1*chip2
14230             alf1=alp(itypi)
14231             alf2=alp(itypj)
14232             alf12=0.5D0*(alf1+alf2)
14233 !            xj=c(1,nres+j)-xi
14234 !            yj=c(2,nres+j)-yi
14235 !            zj=c(3,nres+j)-zi
14236             xj=c(1,nres+j)
14237             yj=c(2,nres+j)
14238             zj=c(3,nres+j)
14239 ! Searching for nearest neighbour
14240           xj=mod(xj,boxxsize)
14241           if (xj.lt.0) xj=xj+boxxsize
14242           yj=mod(yj,boxysize)
14243           if (yj.lt.0) yj=yj+boxysize
14244           zj=mod(zj,boxzsize)
14245           if (zj.lt.0) zj=zj+boxzsize
14246        if ((zj.gt.bordlipbot)   &
14247       .and.(zj.lt.bordliptop)) then
14248 !C the energy transfer exist
14249         if (zj.lt.buflipbot) then
14250 !C what fraction I am in
14251          fracinbuf=1.0d0-  &
14252              ((zj-bordlipbot)/lipbufthick)
14253 !C lipbufthick is thickenes of lipid buffore
14254          sslipj=sscalelip(fracinbuf)
14255          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14256         elseif (zj.gt.bufliptop) then
14257          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14258          sslipj=sscalelip(fracinbuf)
14259          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14260         else
14261          sslipj=1.0d0
14262          ssgradlipj=0.0
14263         endif
14264        else
14265          sslipj=0.0d0
14266          ssgradlipj=0.0
14267        endif
14268       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14269        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14270       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14271        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14272
14273           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14274           xj_safe=xj
14275           yj_safe=yj
14276           zj_safe=zj
14277           subchap=0
14278
14279           do xshift=-1,1
14280           do yshift=-1,1
14281           do zshift=-1,1
14282           xj=xj_safe+xshift*boxxsize
14283           yj=yj_safe+yshift*boxysize
14284           zj=zj_safe+zshift*boxzsize
14285           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14286           if(dist_temp.lt.dist_init) then
14287             dist_init=dist_temp
14288             xj_temp=xj
14289             yj_temp=yj
14290             zj_temp=zj
14291             subchap=1
14292           endif
14293           enddo
14294           enddo
14295           enddo
14296           if (subchap.eq.1) then
14297           xj=xj_temp-xi
14298           yj=yj_temp-yi
14299           zj=zj_temp-zi
14300           else
14301           xj=xj_safe-xi
14302           yj=yj_safe-yi
14303           zj=zj_safe-zi
14304           endif
14305
14306             dxj=dc_norm(1,nres+j)
14307             dyj=dc_norm(2,nres+j)
14308             dzj=dc_norm(3,nres+j)
14309             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14310             rij=dsqrt(rrij)
14311             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14312             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14313             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14314             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14315             if (sss_ele_cut.le.0.0) cycle
14316
14317             if (sss.gt.0.0d0) then
14318
14319 ! Calculate angle-dependent terms of energy and contributions to their
14320 ! derivatives.
14321               call sc_angular
14322               sigsq=1.0D0/sigsq
14323               sig=sig0ij*dsqrt(sigsq)
14324               rij_shift=1.0D0/rij-sig+sig0ij
14325 ! for diagnostics; uncomment
14326 !              rij_shift=1.2*sig0ij
14327 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14328               if (rij_shift.le.0.0D0) then
14329                 evdw=1.0D20
14330 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14331 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14332 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14333                 return
14334               endif
14335               sigder=-sig*sigsq
14336 !---------------------------------------------------------------
14337               rij_shift=1.0D0/rij_shift
14338               fac=rij_shift**expon
14339               e1=fac*fac*aa
14340               e2=fac*bb
14341               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14342               eps2der=evdwij*eps3rt
14343               eps3der=evdwij*eps2rt
14344 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14345 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14346               evdwij=evdwij*eps2rt*eps3rt
14347               evdw=evdw+evdwij*sss*sss_ele_cut
14348               if (lprn) then
14349               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14350               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14351               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14352                 restyp(itypi,1),i,restyp(itypj,1),j,&
14353                 epsi,sigm,chi1,chi2,chip1,chip2,&
14354                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14355                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14356                 evdwij
14357               endif
14358
14359               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14360                               'evdw',i,j,evdwij
14361 !              if (energy_dec) write (iout,*) &
14362 !                              'evdw',i,j,evdwij,"egb_short"
14363
14364 ! Calculate gradient components.
14365               e1=e1*eps1*eps2rt**2*eps3rt**2
14366               fac=-expon*(e1+evdwij)*rij_shift
14367               sigder=fac*sigder
14368               fac=rij*fac
14369               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14370             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
14371             /sigmaii(itypi,itypj))
14372
14373 !              fac=0.0d0
14374 ! Calculate the radial part of the gradient
14375               gg(1)=xj*fac
14376               gg(2)=yj*fac
14377               gg(3)=zj*fac
14378 ! Calculate angular part of the gradient.
14379               call sc_grad_scale(sss)
14380             endif
14381           ENDIF !mask_dyn_ss
14382           enddo      ! j
14383         enddo        ! iint
14384       enddo          ! i
14385 !      write (iout,*) "Number of loop steps in EGB:",ind
14386 !ccc      energy_dec=.false.
14387       return
14388       end subroutine egb_short
14389 !-----------------------------------------------------------------------------
14390       subroutine egbv_long(evdw)
14391 !
14392 ! This subroutine calculates the interaction energy of nonbonded side chains
14393 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14394 !
14395       use calc_data
14396 !      implicit real*8 (a-h,o-z)
14397 !      include 'DIMENSIONS'
14398 !      include 'COMMON.GEO'
14399 !      include 'COMMON.VAR'
14400 !      include 'COMMON.LOCAL'
14401 !      include 'COMMON.CHAIN'
14402 !      include 'COMMON.DERIV'
14403 !      include 'COMMON.NAMES'
14404 !      include 'COMMON.INTERACT'
14405 !      include 'COMMON.IOUNITS'
14406 !      include 'COMMON.CALC'
14407       use comm_srutu
14408 !el      integer :: icall
14409 !el      common /srutu/ icall
14410       logical :: lprn
14411 !el local variables
14412       integer :: iint,itypi,itypi1,itypj
14413       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14414       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14415       evdw=0.0D0
14416 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14417       evdw=0.0D0
14418       lprn=.false.
14419 !     if (icall.eq.0) lprn=.true.
14420 !el      ind=0
14421       do i=iatsc_s,iatsc_e
14422         itypi=itype(i,1)
14423         if (itypi.eq.ntyp1) cycle
14424         itypi1=itype(i+1,1)
14425         xi=c(1,nres+i)
14426         yi=c(2,nres+i)
14427         zi=c(3,nres+i)
14428         dxi=dc_norm(1,nres+i)
14429         dyi=dc_norm(2,nres+i)
14430         dzi=dc_norm(3,nres+i)
14431 !        dsci_inv=dsc_inv(itypi)
14432         dsci_inv=vbld_inv(i+nres)
14433 !
14434 ! Calculate SC interaction energy.
14435 !
14436         do iint=1,nint_gr(i)
14437           do j=istart(i,iint),iend(i,iint)
14438 !el            ind=ind+1
14439             itypj=itype(j,1)
14440             if (itypj.eq.ntyp1) cycle
14441 !            dscj_inv=dsc_inv(itypj)
14442             dscj_inv=vbld_inv(j+nres)
14443             sig0ij=sigma(itypi,itypj)
14444             r0ij=r0(itypi,itypj)
14445             chi1=chi(itypi,itypj)
14446             chi2=chi(itypj,itypi)
14447             chi12=chi1*chi2
14448             chip1=chip(itypi)
14449             chip2=chip(itypj)
14450             chip12=chip1*chip2
14451             alf1=alp(itypi)
14452             alf2=alp(itypj)
14453             alf12=0.5D0*(alf1+alf2)
14454             xj=c(1,nres+j)-xi
14455             yj=c(2,nres+j)-yi
14456             zj=c(3,nres+j)-zi
14457             dxj=dc_norm(1,nres+j)
14458             dyj=dc_norm(2,nres+j)
14459             dzj=dc_norm(3,nres+j)
14460             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14461             rij=dsqrt(rrij)
14462
14463             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14464
14465             if (sss.lt.1.0d0) then
14466
14467 ! Calculate angle-dependent terms of energy and contributions to their
14468 ! derivatives.
14469               call sc_angular
14470               sigsq=1.0D0/sigsq
14471               sig=sig0ij*dsqrt(sigsq)
14472               rij_shift=1.0D0/rij-sig+r0ij
14473 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14474               if (rij_shift.le.0.0D0) then
14475                 evdw=1.0D20
14476                 return
14477               endif
14478               sigder=-sig*sigsq
14479 !---------------------------------------------------------------
14480               rij_shift=1.0D0/rij_shift
14481               fac=rij_shift**expon
14482               e1=fac*fac*aa_aq(itypi,itypj)
14483               e2=fac*bb_aq(itypi,itypj)
14484               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14485               eps2der=evdwij*eps3rt
14486               eps3der=evdwij*eps2rt
14487               fac_augm=rrij**expon
14488               e_augm=augm(itypi,itypj)*fac_augm
14489               evdwij=evdwij*eps2rt*eps3rt
14490               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14491               if (lprn) then
14492               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14493               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14494               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14495                 restyp(itypi,1),i,restyp(itypj,1),j,&
14496                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14497                 chi1,chi2,chip1,chip2,&
14498                 eps1,eps2rt**2,eps3rt**2,&
14499                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14500                 evdwij+e_augm
14501               endif
14502 ! Calculate gradient components.
14503               e1=e1*eps1*eps2rt**2*eps3rt**2
14504               fac=-expon*(e1+evdwij)*rij_shift
14505               sigder=fac*sigder
14506               fac=rij*fac-2*expon*rrij*e_augm
14507 ! Calculate the radial part of the gradient
14508               gg(1)=xj*fac
14509               gg(2)=yj*fac
14510               gg(3)=zj*fac
14511 ! Calculate angular part of the gradient.
14512               call sc_grad_scale(1.0d0-sss)
14513             endif
14514           enddo      ! j
14515         enddo        ! iint
14516       enddo          ! i
14517       end subroutine egbv_long
14518 !-----------------------------------------------------------------------------
14519       subroutine egbv_short(evdw)
14520 !
14521 ! This subroutine calculates the interaction energy of nonbonded side chains
14522 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14523 !
14524       use calc_data
14525 !      implicit real*8 (a-h,o-z)
14526 !      include 'DIMENSIONS'
14527 !      include 'COMMON.GEO'
14528 !      include 'COMMON.VAR'
14529 !      include 'COMMON.LOCAL'
14530 !      include 'COMMON.CHAIN'
14531 !      include 'COMMON.DERIV'
14532 !      include 'COMMON.NAMES'
14533 !      include 'COMMON.INTERACT'
14534 !      include 'COMMON.IOUNITS'
14535 !      include 'COMMON.CALC'
14536       use comm_srutu
14537 !el      integer :: icall
14538 !el      common /srutu/ icall
14539       logical :: lprn
14540 !el local variables
14541       integer :: iint,itypi,itypi1,itypj
14542       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14543       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14544       evdw=0.0D0
14545 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14546       evdw=0.0D0
14547       lprn=.false.
14548 !     if (icall.eq.0) lprn=.true.
14549 !el      ind=0
14550       do i=iatsc_s,iatsc_e
14551         itypi=itype(i,1)
14552         if (itypi.eq.ntyp1) cycle
14553         itypi1=itype(i+1,1)
14554         xi=c(1,nres+i)
14555         yi=c(2,nres+i)
14556         zi=c(3,nres+i)
14557         dxi=dc_norm(1,nres+i)
14558         dyi=dc_norm(2,nres+i)
14559         dzi=dc_norm(3,nres+i)
14560 !        dsci_inv=dsc_inv(itypi)
14561         dsci_inv=vbld_inv(i+nres)
14562 !
14563 ! Calculate SC interaction energy.
14564 !
14565         do iint=1,nint_gr(i)
14566           do j=istart(i,iint),iend(i,iint)
14567 !el            ind=ind+1
14568             itypj=itype(j,1)
14569             if (itypj.eq.ntyp1) cycle
14570 !            dscj_inv=dsc_inv(itypj)
14571             dscj_inv=vbld_inv(j+nres)
14572             sig0ij=sigma(itypi,itypj)
14573             r0ij=r0(itypi,itypj)
14574             chi1=chi(itypi,itypj)
14575             chi2=chi(itypj,itypi)
14576             chi12=chi1*chi2
14577             chip1=chip(itypi)
14578             chip2=chip(itypj)
14579             chip12=chip1*chip2
14580             alf1=alp(itypi)
14581             alf2=alp(itypj)
14582             alf12=0.5D0*(alf1+alf2)
14583             xj=c(1,nres+j)-xi
14584             yj=c(2,nres+j)-yi
14585             zj=c(3,nres+j)-zi
14586             dxj=dc_norm(1,nres+j)
14587             dyj=dc_norm(2,nres+j)
14588             dzj=dc_norm(3,nres+j)
14589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14590             rij=dsqrt(rrij)
14591
14592             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14593
14594             if (sss.gt.0.0d0) then
14595
14596 ! Calculate angle-dependent terms of energy and contributions to their
14597 ! derivatives.
14598               call sc_angular
14599               sigsq=1.0D0/sigsq
14600               sig=sig0ij*dsqrt(sigsq)
14601               rij_shift=1.0D0/rij-sig+r0ij
14602 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14603               if (rij_shift.le.0.0D0) then
14604                 evdw=1.0D20
14605                 return
14606               endif
14607               sigder=-sig*sigsq
14608 !---------------------------------------------------------------
14609               rij_shift=1.0D0/rij_shift
14610               fac=rij_shift**expon
14611               e1=fac*fac*aa_aq(itypi,itypj)
14612               e2=fac*bb_aq(itypi,itypj)
14613               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14614               eps2der=evdwij*eps3rt
14615               eps3der=evdwij*eps2rt
14616               fac_augm=rrij**expon
14617               e_augm=augm(itypi,itypj)*fac_augm
14618               evdwij=evdwij*eps2rt*eps3rt
14619               evdw=evdw+(evdwij+e_augm)*sss
14620               if (lprn) then
14621               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14622               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14623               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14624                 restyp(itypi,1),i,restyp(itypj,1),j,&
14625                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14626                 chi1,chi2,chip1,chip2,&
14627                 eps1,eps2rt**2,eps3rt**2,&
14628                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14629                 evdwij+e_augm
14630               endif
14631 ! Calculate gradient components.
14632               e1=e1*eps1*eps2rt**2*eps3rt**2
14633               fac=-expon*(e1+evdwij)*rij_shift
14634               sigder=fac*sigder
14635               fac=rij*fac-2*expon*rrij*e_augm
14636 ! Calculate the radial part of the gradient
14637               gg(1)=xj*fac
14638               gg(2)=yj*fac
14639               gg(3)=zj*fac
14640 ! Calculate angular part of the gradient.
14641               call sc_grad_scale(sss)
14642             endif
14643           enddo      ! j
14644         enddo        ! iint
14645       enddo          ! i
14646       end subroutine egbv_short
14647 !-----------------------------------------------------------------------------
14648       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14649 !
14650 ! This subroutine calculates the average interaction energy and its gradient
14651 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14652 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14653 ! The potential depends both on the distance of peptide-group centers and on
14654 ! the orientation of the CA-CA virtual bonds.
14655 !
14656 !      implicit real*8 (a-h,o-z)
14657
14658       use comm_locel
14659 #ifdef MPI
14660       include 'mpif.h'
14661 #endif
14662 !      include 'DIMENSIONS'
14663 !      include 'COMMON.CONTROL'
14664 !      include 'COMMON.SETUP'
14665 !      include 'COMMON.IOUNITS'
14666 !      include 'COMMON.GEO'
14667 !      include 'COMMON.VAR'
14668 !      include 'COMMON.LOCAL'
14669 !      include 'COMMON.CHAIN'
14670 !      include 'COMMON.DERIV'
14671 !      include 'COMMON.INTERACT'
14672 !      include 'COMMON.CONTACTS'
14673 !      include 'COMMON.TORSION'
14674 !      include 'COMMON.VECTORS'
14675 !      include 'COMMON.FFIELD'
14676 !      include 'COMMON.TIME1'
14677       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14678       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14679       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14680 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14681       real(kind=8),dimension(4) :: muij
14682 !el      integer :: num_conti,j1,j2
14683 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14684 !el                   dz_normi,xmedi,ymedi,zmedi
14685 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14686 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14687 !el          num_conti,j1,j2
14688 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14689 #ifdef MOMENT
14690       real(kind=8) :: scal_el=1.0d0
14691 #else
14692       real(kind=8) :: scal_el=0.5d0
14693 #endif
14694 ! 12/13/98
14695 ! 13-go grudnia roku pamietnego...
14696       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14697                                              0.0d0,1.0d0,0.0d0,&
14698                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14699 !el local variables
14700       integer :: i,j,k
14701       real(kind=8) :: fac
14702       real(kind=8) :: dxj,dyj,dzj
14703       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14704
14705 !      allocate(num_cont_hb(nres)) !(maxres)
14706 !d      write(iout,*) 'In EELEC'
14707 !d      do i=1,nloctyp
14708 !d        write(iout,*) 'Type',i
14709 !d        write(iout,*) 'B1',B1(:,i)
14710 !d        write(iout,*) 'B2',B2(:,i)
14711 !d        write(iout,*) 'CC',CC(:,:,i)
14712 !d        write(iout,*) 'DD',DD(:,:,i)
14713 !d        write(iout,*) 'EE',EE(:,:,i)
14714 !d      enddo
14715 !d      call check_vecgrad
14716 !d      stop
14717       if (icheckgrad.eq.1) then
14718         do i=1,nres-1
14719           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14720           do k=1,3
14721             dc_norm(k,i)=dc(k,i)*fac
14722           enddo
14723 !          write (iout,*) 'i',i,' fac',fac
14724         enddo
14725       endif
14726       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14727           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14728           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14729 !        call vec_and_deriv
14730 #ifdef TIMING
14731         time01=MPI_Wtime()
14732 #endif
14733 !        print *, "before set matrices"
14734         call set_matrices
14735 !        print *,"after set martices"
14736 #ifdef TIMING
14737         time_mat=time_mat+MPI_Wtime()-time01
14738 #endif
14739       endif
14740 !d      do i=1,nres-1
14741 !d        write (iout,*) 'i=',i
14742 !d        do k=1,3
14743 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14744 !d        enddo
14745 !d        do k=1,3
14746 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14747 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14748 !d        enddo
14749 !d      enddo
14750       t_eelecij=0.0d0
14751       ees=0.0D0
14752       evdw1=0.0D0
14753       eel_loc=0.0d0
14754       eello_turn3=0.0d0
14755       eello_turn4=0.0d0
14756 !el      ind=0
14757       do i=1,nres
14758         num_cont_hb(i)=0
14759       enddo
14760 !d      print '(a)','Enter EELEC'
14761 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14762 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14763 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14764       do i=1,nres
14765         gel_loc_loc(i)=0.0d0
14766         gcorr_loc(i)=0.0d0
14767       enddo
14768 !
14769 !
14770 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14771 !
14772 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14773 !
14774       do i=iturn3_start,iturn3_end
14775         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14776         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14777         dxi=dc(1,i)
14778         dyi=dc(2,i)
14779         dzi=dc(3,i)
14780         dx_normi=dc_norm(1,i)
14781         dy_normi=dc_norm(2,i)
14782         dz_normi=dc_norm(3,i)
14783         xmedi=c(1,i)+0.5d0*dxi
14784         ymedi=c(2,i)+0.5d0*dyi
14785         zmedi=c(3,i)+0.5d0*dzi
14786           xmedi=dmod(xmedi,boxxsize)
14787           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14788           ymedi=dmod(ymedi,boxysize)
14789           if (ymedi.lt.0) ymedi=ymedi+boxysize
14790           zmedi=dmod(zmedi,boxzsize)
14791           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14792         num_conti=0
14793         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14794         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14795         num_cont_hb(i)=num_conti
14796       enddo
14797       do i=iturn4_start,iturn4_end
14798         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14799           .or. itype(i+3,1).eq.ntyp1 &
14800           .or. itype(i+4,1).eq.ntyp1) cycle
14801         dxi=dc(1,i)
14802         dyi=dc(2,i)
14803         dzi=dc(3,i)
14804         dx_normi=dc_norm(1,i)
14805         dy_normi=dc_norm(2,i)
14806         dz_normi=dc_norm(3,i)
14807         xmedi=c(1,i)+0.5d0*dxi
14808         ymedi=c(2,i)+0.5d0*dyi
14809         zmedi=c(3,i)+0.5d0*dzi
14810           xmedi=dmod(xmedi,boxxsize)
14811           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14812           ymedi=dmod(ymedi,boxysize)
14813           if (ymedi.lt.0) ymedi=ymedi+boxysize
14814           zmedi=dmod(zmedi,boxzsize)
14815           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14816         num_conti=num_cont_hb(i)
14817         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14818         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14819           call eturn4(i,eello_turn4)
14820         num_cont_hb(i)=num_conti
14821       enddo   ! i
14822 !
14823 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14824 !
14825       do i=iatel_s,iatel_e
14826         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14827         dxi=dc(1,i)
14828         dyi=dc(2,i)
14829         dzi=dc(3,i)
14830         dx_normi=dc_norm(1,i)
14831         dy_normi=dc_norm(2,i)
14832         dz_normi=dc_norm(3,i)
14833         xmedi=c(1,i)+0.5d0*dxi
14834         ymedi=c(2,i)+0.5d0*dyi
14835         zmedi=c(3,i)+0.5d0*dzi
14836           xmedi=dmod(xmedi,boxxsize)
14837           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14838           ymedi=dmod(ymedi,boxysize)
14839           if (ymedi.lt.0) ymedi=ymedi+boxysize
14840           zmedi=dmod(zmedi,boxzsize)
14841           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14842 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14843         num_conti=num_cont_hb(i)
14844         do j=ielstart(i),ielend(i)
14845           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14846           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14847         enddo ! j
14848         num_cont_hb(i)=num_conti
14849       enddo   ! i
14850 !      write (iout,*) "Number of loop steps in EELEC:",ind
14851 !d      do i=1,nres
14852 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14853 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14854 !d      enddo
14855 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14856 !cc      eel_loc=eel_loc+eello_turn3
14857 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14858       return
14859       end subroutine eelec_scale
14860 !-----------------------------------------------------------------------------
14861       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14862 !      implicit real*8 (a-h,o-z)
14863
14864       use comm_locel
14865 !      include 'DIMENSIONS'
14866 #ifdef MPI
14867       include "mpif.h"
14868 #endif
14869 !      include 'COMMON.CONTROL'
14870 !      include 'COMMON.IOUNITS'
14871 !      include 'COMMON.GEO'
14872 !      include 'COMMON.VAR'
14873 !      include 'COMMON.LOCAL'
14874 !      include 'COMMON.CHAIN'
14875 !      include 'COMMON.DERIV'
14876 !      include 'COMMON.INTERACT'
14877 !      include 'COMMON.CONTACTS'
14878 !      include 'COMMON.TORSION'
14879 !      include 'COMMON.VECTORS'
14880 !      include 'COMMON.FFIELD'
14881 !      include 'COMMON.TIME1'
14882       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14883       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14884       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14885 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14886       real(kind=8),dimension(4) :: muij
14887       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14888                     dist_temp, dist_init,sss_grad
14889       integer xshift,yshift,zshift
14890
14891 !el      integer :: num_conti,j1,j2
14892 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14893 !el                   dz_normi,xmedi,ymedi,zmedi
14894 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14895 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14896 !el          num_conti,j1,j2
14897 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14898 #ifdef MOMENT
14899       real(kind=8) :: scal_el=1.0d0
14900 #else
14901       real(kind=8) :: scal_el=0.5d0
14902 #endif
14903 ! 12/13/98
14904 ! 13-go grudnia roku pamietnego...
14905       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14906                                              0.0d0,1.0d0,0.0d0,&
14907                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14908 !el local variables
14909       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14910       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14911       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14912       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14913       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14914       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14915       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14916                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14917                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14918                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14919                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14920                   ecosam,ecosbm,ecosgm,ghalf,time00
14921 !      integer :: maxconts
14922 !      maxconts = nres/4
14923 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14924 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14925 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14926 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14927 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14928 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14929 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14930 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14931 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14932 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14933 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14934 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14935 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14936
14937 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14938 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14939
14940 #ifdef MPI
14941           time00=MPI_Wtime()
14942 #endif
14943 !d      write (iout,*) "eelecij",i,j
14944 !el          ind=ind+1
14945           iteli=itel(i)
14946           itelj=itel(j)
14947           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14948           aaa=app(iteli,itelj)
14949           bbb=bpp(iteli,itelj)
14950           ael6i=ael6(iteli,itelj)
14951           ael3i=ael3(iteli,itelj)
14952           dxj=dc(1,j)
14953           dyj=dc(2,j)
14954           dzj=dc(3,j)
14955           dx_normj=dc_norm(1,j)
14956           dy_normj=dc_norm(2,j)
14957           dz_normj=dc_norm(3,j)
14958 !          xj=c(1,j)+0.5D0*dxj-xmedi
14959 !          yj=c(2,j)+0.5D0*dyj-ymedi
14960 !          zj=c(3,j)+0.5D0*dzj-zmedi
14961           xj=c(1,j)+0.5D0*dxj
14962           yj=c(2,j)+0.5D0*dyj
14963           zj=c(3,j)+0.5D0*dzj
14964           xj=mod(xj,boxxsize)
14965           if (xj.lt.0) xj=xj+boxxsize
14966           yj=mod(yj,boxysize)
14967           if (yj.lt.0) yj=yj+boxysize
14968           zj=mod(zj,boxzsize)
14969           if (zj.lt.0) zj=zj+boxzsize
14970       isubchap=0
14971       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14972       xj_safe=xj
14973       yj_safe=yj
14974       zj_safe=zj
14975       do xshift=-1,1
14976       do yshift=-1,1
14977       do zshift=-1,1
14978           xj=xj_safe+xshift*boxxsize
14979           yj=yj_safe+yshift*boxysize
14980           zj=zj_safe+zshift*boxzsize
14981           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14982           if(dist_temp.lt.dist_init) then
14983             dist_init=dist_temp
14984             xj_temp=xj
14985             yj_temp=yj
14986             zj_temp=zj
14987             isubchap=1
14988           endif
14989        enddo
14990        enddo
14991        enddo
14992        if (isubchap.eq.1) then
14993 !C          print *,i,j
14994           xj=xj_temp-xmedi
14995           yj=yj_temp-ymedi
14996           zj=zj_temp-zmedi
14997        else
14998           xj=xj_safe-xmedi
14999           yj=yj_safe-ymedi
15000           zj=zj_safe-zmedi
15001        endif
15002
15003           rij=xj*xj+yj*yj+zj*zj
15004           rrmij=1.0D0/rij
15005           rij=dsqrt(rij)
15006           rmij=1.0D0/rij
15007 ! For extracting the short-range part of Evdwpp
15008           sss=sscale(rij/rpp(iteli,itelj))
15009             sss_ele_cut=sscale_ele(rij)
15010             sss_ele_grad=sscagrad_ele(rij)
15011             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15012 !             sss_ele_cut=1.0d0
15013 !             sss_ele_grad=0.0d0
15014             if (sss_ele_cut.le.0.0) go to 128
15015
15016           r3ij=rrmij*rmij
15017           r6ij=r3ij*r3ij
15018           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15019           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15020           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15021           fac=cosa-3.0D0*cosb*cosg
15022           ev1=aaa*r6ij*r6ij
15023 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15024           if (j.eq.i+2) ev1=scal_el*ev1
15025           ev2=bbb*r6ij
15026           fac3=ael6i*r6ij
15027           fac4=ael3i*r3ij
15028           evdwij=ev1+ev2
15029           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15030           el2=fac4*fac
15031           eesij=el1+el2
15032 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15033           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15034           ees=ees+eesij*sss_ele_cut
15035           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15036 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15037 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15038 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15039 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15040
15041           if (energy_dec) then
15042               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15043               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15044           endif
15045
15046 !
15047 ! Calculate contributions to the Cartesian gradient.
15048 !
15049 #ifdef SPLITELE
15050           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15051           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15052           fac1=fac
15053           erij(1)=xj*rmij
15054           erij(2)=yj*rmij
15055           erij(3)=zj*rmij
15056 !
15057 ! Radial derivatives. First process both termini of the fragment (i,j)
15058 !
15059           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15060           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15061           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15062 !          do k=1,3
15063 !            ghalf=0.5D0*ggg(k)
15064 !            gelc(k,i)=gelc(k,i)+ghalf
15065 !            gelc(k,j)=gelc(k,j)+ghalf
15066 !          enddo
15067 ! 9/28/08 AL Gradient compotents will be summed only at the end
15068           do k=1,3
15069             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15070             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15071           enddo
15072 !
15073 ! Loop over residues i+1 thru j-1.
15074 !
15075 !grad          do k=i+1,j-1
15076 !grad            do l=1,3
15077 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15078 !grad            enddo
15079 !grad          enddo
15080           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15081           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15082           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15083           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15084           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15085           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15086 !          do k=1,3
15087 !            ghalf=0.5D0*ggg(k)
15088 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15089 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15090 !          enddo
15091 ! 9/28/08 AL Gradient compotents will be summed only at the end
15092           do k=1,3
15093             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15094             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15095           enddo
15096 !
15097 ! Loop over residues i+1 thru j-1.
15098 !
15099 !grad          do k=i+1,j-1
15100 !grad            do l=1,3
15101 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15102 !grad            enddo
15103 !grad          enddo
15104 #else
15105           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15106           facel=(el1+eesij)*sss_ele_cut
15107           fac1=fac
15108           fac=-3*rrmij*(facvdw+facvdw+facel)
15109           erij(1)=xj*rmij
15110           erij(2)=yj*rmij
15111           erij(3)=zj*rmij
15112 !
15113 ! Radial derivatives. First process both termini of the fragment (i,j)
15114 !
15115           ggg(1)=fac*xj
15116           ggg(2)=fac*yj
15117           ggg(3)=fac*zj
15118 !          do k=1,3
15119 !            ghalf=0.5D0*ggg(k)
15120 !            gelc(k,i)=gelc(k,i)+ghalf
15121 !            gelc(k,j)=gelc(k,j)+ghalf
15122 !          enddo
15123 ! 9/28/08 AL Gradient compotents will be summed only at the end
15124           do k=1,3
15125             gelc_long(k,j)=gelc(k,j)+ggg(k)
15126             gelc_long(k,i)=gelc(k,i)-ggg(k)
15127           enddo
15128 !
15129 ! Loop over residues i+1 thru j-1.
15130 !
15131 !grad          do k=i+1,j-1
15132 !grad            do l=1,3
15133 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15134 !grad            enddo
15135 !grad          enddo
15136 ! 9/28/08 AL Gradient compotents will be summed only at the end
15137           ggg(1)=facvdw*xj
15138           ggg(2)=facvdw*yj
15139           ggg(3)=facvdw*zj
15140           do k=1,3
15141             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15142             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15143           enddo
15144 #endif
15145 !
15146 ! Angular part
15147 !
15148           ecosa=2.0D0*fac3*fac1+fac4
15149           fac4=-3.0D0*fac4
15150           fac3=-6.0D0*fac3
15151           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15152           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15153           do k=1,3
15154             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15155             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15156           enddo
15157 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15158 !d   &          (dcosg(k),k=1,3)
15159           do k=1,3
15160             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15161           enddo
15162 !          do k=1,3
15163 !            ghalf=0.5D0*ggg(k)
15164 !            gelc(k,i)=gelc(k,i)+ghalf
15165 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15166 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15167 !            gelc(k,j)=gelc(k,j)+ghalf
15168 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15169 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15170 !          enddo
15171 !grad          do k=i+1,j-1
15172 !grad            do l=1,3
15173 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15174 !grad            enddo
15175 !grad          enddo
15176           do k=1,3
15177             gelc(k,i)=gelc(k,i) &
15178                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15179                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15180                      *sss_ele_cut
15181             gelc(k,j)=gelc(k,j) &
15182                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15183                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15184                      *sss_ele_cut
15185             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15186             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15187           enddo
15188           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15189               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15190               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15191 !
15192 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15193 !   energy of a peptide unit is assumed in the form of a second-order
15194 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15195 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15196 !   are computed for EVERY pair of non-contiguous peptide groups.
15197 !
15198           if (j.lt.nres-1) then
15199             j1=j+1
15200             j2=j-1
15201           else
15202             j1=j-1
15203             j2=j-2
15204           endif
15205           kkk=0
15206           do k=1,2
15207             do l=1,2
15208               kkk=kkk+1
15209               muij(kkk)=mu(k,i)*mu(l,j)
15210             enddo
15211           enddo
15212 !d         write (iout,*) 'EELEC: i',i,' j',j
15213 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15214 !d          write(iout,*) 'muij',muij
15215           ury=scalar(uy(1,i),erij)
15216           urz=scalar(uz(1,i),erij)
15217           vry=scalar(uy(1,j),erij)
15218           vrz=scalar(uz(1,j),erij)
15219           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15220           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15221           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15222           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15223           fac=dsqrt(-ael6i)*r3ij
15224           a22=a22*fac
15225           a23=a23*fac
15226           a32=a32*fac
15227           a33=a33*fac
15228 !d          write (iout,'(4i5,4f10.5)')
15229 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15230 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15231 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15232 !d     &      uy(:,j),uz(:,j)
15233 !d          write (iout,'(4f10.5)')
15234 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15235 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15236 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15237 !d           write (iout,'(9f10.5/)')
15238 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15239 ! Derivatives of the elements of A in virtual-bond vectors
15240           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15241           do k=1,3
15242             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15243             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15244             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15245             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15246             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15247             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15248             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15249             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15250             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15251             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15252             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15253             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15254           enddo
15255 ! Compute radial contributions to the gradient
15256           facr=-3.0d0*rrmij
15257           a22der=a22*facr
15258           a23der=a23*facr
15259           a32der=a32*facr
15260           a33der=a33*facr
15261           agg(1,1)=a22der*xj
15262           agg(2,1)=a22der*yj
15263           agg(3,1)=a22der*zj
15264           agg(1,2)=a23der*xj
15265           agg(2,2)=a23der*yj
15266           agg(3,2)=a23der*zj
15267           agg(1,3)=a32der*xj
15268           agg(2,3)=a32der*yj
15269           agg(3,3)=a32der*zj
15270           agg(1,4)=a33der*xj
15271           agg(2,4)=a33der*yj
15272           agg(3,4)=a33der*zj
15273 ! Add the contributions coming from er
15274           fac3=-3.0d0*fac
15275           do k=1,3
15276             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15277             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15278             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15279             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15280           enddo
15281           do k=1,3
15282 ! Derivatives in DC(i)
15283 !grad            ghalf1=0.5d0*agg(k,1)
15284 !grad            ghalf2=0.5d0*agg(k,2)
15285 !grad            ghalf3=0.5d0*agg(k,3)
15286 !grad            ghalf4=0.5d0*agg(k,4)
15287             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15288             -3.0d0*uryg(k,2)*vry)!+ghalf1
15289             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15290             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15291             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15292             -3.0d0*urzg(k,2)*vry)!+ghalf3
15293             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15294             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15295 ! Derivatives in DC(i+1)
15296             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15297             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15298             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15299             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15300             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15301             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15302             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15303             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15304 ! Derivatives in DC(j)
15305             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15306             -3.0d0*vryg(k,2)*ury)!+ghalf1
15307             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15308             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15309             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15310             -3.0d0*vryg(k,2)*urz)!+ghalf3
15311             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15312             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15313 ! Derivatives in DC(j+1) or DC(nres-1)
15314             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15315             -3.0d0*vryg(k,3)*ury)
15316             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15317             -3.0d0*vrzg(k,3)*ury)
15318             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15319             -3.0d0*vryg(k,3)*urz)
15320             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15321             -3.0d0*vrzg(k,3)*urz)
15322 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15323 !grad              do l=1,4
15324 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15325 !grad              enddo
15326 !grad            endif
15327           enddo
15328           acipa(1,1)=a22
15329           acipa(1,2)=a23
15330           acipa(2,1)=a32
15331           acipa(2,2)=a33
15332           a22=-a22
15333           a23=-a23
15334           do l=1,2
15335             do k=1,3
15336               agg(k,l)=-agg(k,l)
15337               aggi(k,l)=-aggi(k,l)
15338               aggi1(k,l)=-aggi1(k,l)
15339               aggj(k,l)=-aggj(k,l)
15340               aggj1(k,l)=-aggj1(k,l)
15341             enddo
15342           enddo
15343           if (j.lt.nres-1) then
15344             a22=-a22
15345             a32=-a32
15346             do l=1,3,2
15347               do k=1,3
15348                 agg(k,l)=-agg(k,l)
15349                 aggi(k,l)=-aggi(k,l)
15350                 aggi1(k,l)=-aggi1(k,l)
15351                 aggj(k,l)=-aggj(k,l)
15352                 aggj1(k,l)=-aggj1(k,l)
15353               enddo
15354             enddo
15355           else
15356             a22=-a22
15357             a23=-a23
15358             a32=-a32
15359             a33=-a33
15360             do l=1,4
15361               do k=1,3
15362                 agg(k,l)=-agg(k,l)
15363                 aggi(k,l)=-aggi(k,l)
15364                 aggi1(k,l)=-aggi1(k,l)
15365                 aggj(k,l)=-aggj(k,l)
15366                 aggj1(k,l)=-aggj1(k,l)
15367               enddo
15368             enddo
15369           endif
15370           ENDIF ! WCORR
15371           IF (wel_loc.gt.0.0d0) THEN
15372 ! Contribution to the local-electrostatic energy coming from the i-j pair
15373           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15374            +a33*muij(4)
15375 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15376 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15377           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15378                   'eelloc',i,j,eel_loc_ij
15379 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15380
15381           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15382 ! Partial derivatives in virtual-bond dihedral angles gamma
15383           if (i.gt.1) &
15384           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15385                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15386                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15387                  *sss_ele_cut
15388           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15389                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15390                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15391                  *sss_ele_cut
15392            xtemp(1)=xj
15393            xtemp(2)=yj
15394            xtemp(3)=zj
15395
15396 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15397           do l=1,3
15398             ggg(l)=(agg(l,1)*muij(1)+ &
15399                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15400             *sss_ele_cut &
15401              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15402
15403             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15404             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15405 !grad            ghalf=0.5d0*ggg(l)
15406 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15407 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15408           enddo
15409 !grad          do k=i+1,j2
15410 !grad            do l=1,3
15411 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15412 !grad            enddo
15413 !grad          enddo
15414 ! Remaining derivatives of eello
15415           do l=1,3
15416             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15417                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15418             *sss_ele_cut
15419
15420             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15421                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15422             *sss_ele_cut
15423
15424             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15425                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15426             *sss_ele_cut
15427
15428             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15429                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15430             *sss_ele_cut
15431
15432           enddo
15433           ENDIF
15434 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15435 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15436           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15437              .and. num_conti.le.maxconts) then
15438 !            write (iout,*) i,j," entered corr"
15439 !
15440 ! Calculate the contact function. The ith column of the array JCONT will
15441 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15442 ! greater than I). The arrays FACONT and GACONT will contain the values of
15443 ! the contact function and its derivative.
15444 !           r0ij=1.02D0*rpp(iteli,itelj)
15445 !           r0ij=1.11D0*rpp(iteli,itelj)
15446             r0ij=2.20D0*rpp(iteli,itelj)
15447 !           r0ij=1.55D0*rpp(iteli,itelj)
15448             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15449 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15450             if (fcont.gt.0.0D0) then
15451               num_conti=num_conti+1
15452               if (num_conti.gt.maxconts) then
15453 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15454                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15455                                ' will skip next contacts for this conf.',num_conti
15456               else
15457                 jcont_hb(num_conti,i)=j
15458 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15459 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15460                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15461                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15462 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15463 !  terms.
15464                 d_cont(num_conti,i)=rij
15465 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15466 !     --- Electrostatic-interaction matrix ---
15467                 a_chuj(1,1,num_conti,i)=a22
15468                 a_chuj(1,2,num_conti,i)=a23
15469                 a_chuj(2,1,num_conti,i)=a32
15470                 a_chuj(2,2,num_conti,i)=a33
15471 !     --- Gradient of rij
15472                 do kkk=1,3
15473                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15474                 enddo
15475                 kkll=0
15476                 do k=1,2
15477                   do l=1,2
15478                     kkll=kkll+1
15479                     do m=1,3
15480                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15481                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15482                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15483                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15484                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15485                     enddo
15486                   enddo
15487                 enddo
15488                 ENDIF
15489                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15490 ! Calculate contact energies
15491                 cosa4=4.0D0*cosa
15492                 wij=cosa-3.0D0*cosb*cosg
15493                 cosbg1=cosb+cosg
15494                 cosbg2=cosb-cosg
15495 !               fac3=dsqrt(-ael6i)/r0ij**3
15496                 fac3=dsqrt(-ael6i)*r3ij
15497 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15498                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15499                 if (ees0tmp.gt.0) then
15500                   ees0pij=dsqrt(ees0tmp)
15501                 else
15502                   ees0pij=0
15503                 endif
15504 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15505                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15506                 if (ees0tmp.gt.0) then
15507                   ees0mij=dsqrt(ees0tmp)
15508                 else
15509                   ees0mij=0
15510                 endif
15511 !               ees0mij=0.0D0
15512                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15513                      *sss_ele_cut
15514
15515                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15516                      *sss_ele_cut
15517
15518 ! Diagnostics. Comment out or remove after debugging!
15519 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15520 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15521 !               ees0m(num_conti,i)=0.0D0
15522 ! End diagnostics.
15523 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15524 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15525 ! Angular derivatives of the contact function
15526                 ees0pij1=fac3/ees0pij
15527                 ees0mij1=fac3/ees0mij
15528                 fac3p=-3.0D0*fac3*rrmij
15529                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15530                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15531 !               ees0mij1=0.0D0
15532                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15533                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15534                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15535                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15536                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15537                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15538                 ecosap=ecosa1+ecosa2
15539                 ecosbp=ecosb1+ecosb2
15540                 ecosgp=ecosg1+ecosg2
15541                 ecosam=ecosa1-ecosa2
15542                 ecosbm=ecosb1-ecosb2
15543                 ecosgm=ecosg1-ecosg2
15544 ! Diagnostics
15545 !               ecosap=ecosa1
15546 !               ecosbp=ecosb1
15547 !               ecosgp=ecosg1
15548 !               ecosam=0.0D0
15549 !               ecosbm=0.0D0
15550 !               ecosgm=0.0D0
15551 ! End diagnostics
15552                 facont_hb(num_conti,i)=fcont
15553                 fprimcont=fprimcont/rij
15554 !d              facont_hb(num_conti,i)=1.0D0
15555 ! Following line is for diagnostics.
15556 !d              fprimcont=0.0D0
15557                 do k=1,3
15558                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15559                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15560                 enddo
15561                 do k=1,3
15562                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15563                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15564                 enddo
15565 !                gggp(1)=gggp(1)+ees0pijp*xj
15566 !                gggp(2)=gggp(2)+ees0pijp*yj
15567 !                gggp(3)=gggp(3)+ees0pijp*zj
15568 !                gggm(1)=gggm(1)+ees0mijp*xj
15569 !                gggm(2)=gggm(2)+ees0mijp*yj
15570 !                gggm(3)=gggm(3)+ees0mijp*zj
15571                 gggp(1)=gggp(1)+ees0pijp*xj &
15572                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15573                 gggp(2)=gggp(2)+ees0pijp*yj &
15574                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15575                 gggp(3)=gggp(3)+ees0pijp*zj &
15576                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15577
15578                 gggm(1)=gggm(1)+ees0mijp*xj &
15579                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15580
15581                 gggm(2)=gggm(2)+ees0mijp*yj &
15582                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15583
15584                 gggm(3)=gggm(3)+ees0mijp*zj &
15585                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15586
15587 ! Derivatives due to the contact function
15588                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15589                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15590                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15591                 do k=1,3
15592 !
15593 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15594 !          following the change of gradient-summation algorithm.
15595 !
15596 !grad                  ghalfp=0.5D0*gggp(k)
15597 !grad                  ghalfm=0.5D0*gggm(k)
15598 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15599 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15600 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15601 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15602 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15603 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15604 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15605 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15606 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15607 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15608 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15609 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15610 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15611 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15612                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15613                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15614                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15615                      *sss_ele_cut
15616
15617                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15618                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15619                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15620                      *sss_ele_cut
15621
15622                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15623                      *sss_ele_cut
15624
15625                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15626                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15627                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15628                      *sss_ele_cut
15629
15630                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15631                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15632                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15633                      *sss_ele_cut
15634
15635                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15636                      *sss_ele_cut
15637
15638                 enddo
15639               ENDIF ! wcorr
15640               endif  ! num_conti.le.maxconts
15641             endif  ! fcont.gt.0
15642           endif    ! j.gt.i+1
15643           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15644             do k=1,4
15645               do l=1,3
15646                 ghalf=0.5d0*agg(l,k)
15647                 aggi(l,k)=aggi(l,k)+ghalf
15648                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15649                 aggj(l,k)=aggj(l,k)+ghalf
15650               enddo
15651             enddo
15652             if (j.eq.nres-1 .and. i.lt.j-2) then
15653               do k=1,4
15654                 do l=1,3
15655                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15656                 enddo
15657               enddo
15658             endif
15659           endif
15660  128      continue
15661 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15662       return
15663       end subroutine eelecij_scale
15664 !-----------------------------------------------------------------------------
15665       subroutine evdwpp_short(evdw1)
15666 !
15667 ! Compute Evdwpp
15668 !
15669 !      implicit real*8 (a-h,o-z)
15670 !      include 'DIMENSIONS'
15671 !      include 'COMMON.CONTROL'
15672 !      include 'COMMON.IOUNITS'
15673 !      include 'COMMON.GEO'
15674 !      include 'COMMON.VAR'
15675 !      include 'COMMON.LOCAL'
15676 !      include 'COMMON.CHAIN'
15677 !      include 'COMMON.DERIV'
15678 !      include 'COMMON.INTERACT'
15679 !      include 'COMMON.CONTACTS'
15680 !      include 'COMMON.TORSION'
15681 !      include 'COMMON.VECTORS'
15682 !      include 'COMMON.FFIELD'
15683       real(kind=8),dimension(3) :: ggg
15684 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15685 #ifdef MOMENT
15686       real(kind=8) :: scal_el=1.0d0
15687 #else
15688       real(kind=8) :: scal_el=0.5d0
15689 #endif
15690 !el local variables
15691       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15692       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15693       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15694                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15695                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15696       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15697                     dist_temp, dist_init,sss_grad
15698       integer xshift,yshift,zshift
15699
15700
15701       evdw1=0.0D0
15702 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15703 !     & " iatel_e_vdw",iatel_e_vdw
15704       call flush(iout)
15705       do i=iatel_s_vdw,iatel_e_vdw
15706         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15707         dxi=dc(1,i)
15708         dyi=dc(2,i)
15709         dzi=dc(3,i)
15710         dx_normi=dc_norm(1,i)
15711         dy_normi=dc_norm(2,i)
15712         dz_normi=dc_norm(3,i)
15713         xmedi=c(1,i)+0.5d0*dxi
15714         ymedi=c(2,i)+0.5d0*dyi
15715         zmedi=c(3,i)+0.5d0*dzi
15716           xmedi=dmod(xmedi,boxxsize)
15717           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15718           ymedi=dmod(ymedi,boxysize)
15719           if (ymedi.lt.0) ymedi=ymedi+boxysize
15720           zmedi=dmod(zmedi,boxzsize)
15721           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15722         num_conti=0
15723 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15724 !     &   ' ielend',ielend_vdw(i)
15725         call flush(iout)
15726         do j=ielstart_vdw(i),ielend_vdw(i)
15727           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15728 !el          ind=ind+1
15729           iteli=itel(i)
15730           itelj=itel(j)
15731           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15732           aaa=app(iteli,itelj)
15733           bbb=bpp(iteli,itelj)
15734           dxj=dc(1,j)
15735           dyj=dc(2,j)
15736           dzj=dc(3,j)
15737           dx_normj=dc_norm(1,j)
15738           dy_normj=dc_norm(2,j)
15739           dz_normj=dc_norm(3,j)
15740 !          xj=c(1,j)+0.5D0*dxj-xmedi
15741 !          yj=c(2,j)+0.5D0*dyj-ymedi
15742 !          zj=c(3,j)+0.5D0*dzj-zmedi
15743           xj=c(1,j)+0.5D0*dxj
15744           yj=c(2,j)+0.5D0*dyj
15745           zj=c(3,j)+0.5D0*dzj
15746           xj=mod(xj,boxxsize)
15747           if (xj.lt.0) xj=xj+boxxsize
15748           yj=mod(yj,boxysize)
15749           if (yj.lt.0) yj=yj+boxysize
15750           zj=mod(zj,boxzsize)
15751           if (zj.lt.0) zj=zj+boxzsize
15752       isubchap=0
15753       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15754       xj_safe=xj
15755       yj_safe=yj
15756       zj_safe=zj
15757       do xshift=-1,1
15758       do yshift=-1,1
15759       do zshift=-1,1
15760           xj=xj_safe+xshift*boxxsize
15761           yj=yj_safe+yshift*boxysize
15762           zj=zj_safe+zshift*boxzsize
15763           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15764           if(dist_temp.lt.dist_init) then
15765             dist_init=dist_temp
15766             xj_temp=xj
15767             yj_temp=yj
15768             zj_temp=zj
15769             isubchap=1
15770           endif
15771        enddo
15772        enddo
15773        enddo
15774        if (isubchap.eq.1) then
15775 !C          print *,i,j
15776           xj=xj_temp-xmedi
15777           yj=yj_temp-ymedi
15778           zj=zj_temp-zmedi
15779        else
15780           xj=xj_safe-xmedi
15781           yj=yj_safe-ymedi
15782           zj=zj_safe-zmedi
15783        endif
15784
15785           rij=xj*xj+yj*yj+zj*zj
15786           rrmij=1.0D0/rij
15787           rij=dsqrt(rij)
15788           sss=sscale(rij/rpp(iteli,itelj))
15789             sss_ele_cut=sscale_ele(rij)
15790             sss_ele_grad=sscagrad_ele(rij)
15791             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15792             if (sss_ele_cut.le.0.0) cycle
15793           if (sss.gt.0.0d0) then
15794             rmij=1.0D0/rij
15795             r3ij=rrmij*rmij
15796             r6ij=r3ij*r3ij
15797             ev1=aaa*r6ij*r6ij
15798 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15799             if (j.eq.i+2) ev1=scal_el*ev1
15800             ev2=bbb*r6ij
15801             evdwij=ev1+ev2
15802             if (energy_dec) then
15803               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15804             endif
15805             evdw1=evdw1+evdwij*sss*sss_ele_cut
15806 !
15807 ! Calculate contributions to the Cartesian gradient.
15808 !
15809             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15810 !            ggg(1)=facvdw*xj
15811 !            ggg(2)=facvdw*yj
15812 !            ggg(3)=facvdw*zj
15813           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15814           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15815           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15816           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15817           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15818           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15819
15820             do k=1,3
15821               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15822               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15823             enddo
15824           endif
15825         enddo ! j
15826       enddo   ! i
15827       return
15828       end subroutine evdwpp_short
15829 !-----------------------------------------------------------------------------
15830       subroutine escp_long(evdw2,evdw2_14)
15831 !
15832 ! This subroutine calculates the excluded-volume interaction energy between
15833 ! peptide-group centers and side chains and its gradient in virtual-bond and
15834 ! side-chain vectors.
15835 !
15836 !      implicit real*8 (a-h,o-z)
15837 !      include 'DIMENSIONS'
15838 !      include 'COMMON.GEO'
15839 !      include 'COMMON.VAR'
15840 !      include 'COMMON.LOCAL'
15841 !      include 'COMMON.CHAIN'
15842 !      include 'COMMON.DERIV'
15843 !      include 'COMMON.INTERACT'
15844 !      include 'COMMON.FFIELD'
15845 !      include 'COMMON.IOUNITS'
15846 !      include 'COMMON.CONTROL'
15847       real(kind=8),dimension(3) :: ggg
15848 !el local variables
15849       integer :: i,iint,j,k,iteli,itypj,subchap
15850       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15851       real(kind=8) :: evdw2,evdw2_14,evdwij
15852       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15853                     dist_temp, dist_init
15854
15855       evdw2=0.0D0
15856       evdw2_14=0.0d0
15857 !d    print '(a)','Enter ESCP'
15858 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15859       do i=iatscp_s,iatscp_e
15860         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15861         iteli=itel(i)
15862         xi=0.5D0*(c(1,i)+c(1,i+1))
15863         yi=0.5D0*(c(2,i)+c(2,i+1))
15864         zi=0.5D0*(c(3,i)+c(3,i+1))
15865           xi=mod(xi,boxxsize)
15866           if (xi.lt.0) xi=xi+boxxsize
15867           yi=mod(yi,boxysize)
15868           if (yi.lt.0) yi=yi+boxysize
15869           zi=mod(zi,boxzsize)
15870           if (zi.lt.0) zi=zi+boxzsize
15871
15872         do iint=1,nscp_gr(i)
15873
15874         do j=iscpstart(i,iint),iscpend(i,iint)
15875           itypj=itype(j,1)
15876           if (itypj.eq.ntyp1) cycle
15877 ! Uncomment following three lines for SC-p interactions
15878 !         xj=c(1,nres+j)-xi
15879 !         yj=c(2,nres+j)-yi
15880 !         zj=c(3,nres+j)-zi
15881 ! Uncomment following three lines for Ca-p interactions
15882           xj=c(1,j)
15883           yj=c(2,j)
15884           zj=c(3,j)
15885           xj=mod(xj,boxxsize)
15886           if (xj.lt.0) xj=xj+boxxsize
15887           yj=mod(yj,boxysize)
15888           if (yj.lt.0) yj=yj+boxysize
15889           zj=mod(zj,boxzsize)
15890           if (zj.lt.0) zj=zj+boxzsize
15891       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15892       xj_safe=xj
15893       yj_safe=yj
15894       zj_safe=zj
15895       subchap=0
15896       do xshift=-1,1
15897       do yshift=-1,1
15898       do zshift=-1,1
15899           xj=xj_safe+xshift*boxxsize
15900           yj=yj_safe+yshift*boxysize
15901           zj=zj_safe+zshift*boxzsize
15902           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15903           if(dist_temp.lt.dist_init) then
15904             dist_init=dist_temp
15905             xj_temp=xj
15906             yj_temp=yj
15907             zj_temp=zj
15908             subchap=1
15909           endif
15910        enddo
15911        enddo
15912        enddo
15913        if (subchap.eq.1) then
15914           xj=xj_temp-xi
15915           yj=yj_temp-yi
15916           zj=zj_temp-zi
15917        else
15918           xj=xj_safe-xi
15919           yj=yj_safe-yi
15920           zj=zj_safe-zi
15921        endif
15922           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15923
15924           rij=dsqrt(1.0d0/rrij)
15925             sss_ele_cut=sscale_ele(rij)
15926             sss_ele_grad=sscagrad_ele(rij)
15927 !            print *,sss_ele_cut,sss_ele_grad,&
15928 !            (rij),r_cut_ele,rlamb_ele
15929             if (sss_ele_cut.le.0.0) cycle
15930           sss=sscale((rij/rscp(itypj,iteli)))
15931           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15932           if (sss.lt.1.0d0) then
15933
15934             fac=rrij**expon2
15935             e1=fac*fac*aad(itypj,iteli)
15936             e2=fac*bad(itypj,iteli)
15937             if (iabs(j-i) .le. 2) then
15938               e1=scal14*e1
15939               e2=scal14*e2
15940               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15941             endif
15942             evdwij=e1+e2
15943             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15944             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15945                 'evdw2',i,j,sss,evdwij
15946 !
15947 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15948 !
15949             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15950             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15951             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15952             ggg(1)=xj*fac
15953             ggg(2)=yj*fac
15954             ggg(3)=zj*fac
15955 ! Uncomment following three lines for SC-p interactions
15956 !           do k=1,3
15957 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15958 !           enddo
15959 ! Uncomment following line for SC-p interactions
15960 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15961             do k=1,3
15962               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15963               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15964             enddo
15965           endif
15966         enddo
15967
15968         enddo ! iint
15969       enddo ! i
15970       do i=1,nct
15971         do j=1,3
15972           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15973           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15974           gradx_scp(j,i)=expon*gradx_scp(j,i)
15975         enddo
15976       enddo
15977 !******************************************************************************
15978 !
15979 !                              N O T E !!!
15980 !
15981 ! To save time the factor EXPON has been extracted from ALL components
15982 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15983 ! use!
15984 !
15985 !******************************************************************************
15986       return
15987       end subroutine escp_long
15988 !-----------------------------------------------------------------------------
15989       subroutine escp_short(evdw2,evdw2_14)
15990 !
15991 ! This subroutine calculates the excluded-volume interaction energy between
15992 ! peptide-group centers and side chains and its gradient in virtual-bond and
15993 ! side-chain vectors.
15994 !
15995 !      implicit real*8 (a-h,o-z)
15996 !      include 'DIMENSIONS'
15997 !      include 'COMMON.GEO'
15998 !      include 'COMMON.VAR'
15999 !      include 'COMMON.LOCAL'
16000 !      include 'COMMON.CHAIN'
16001 !      include 'COMMON.DERIV'
16002 !      include 'COMMON.INTERACT'
16003 !      include 'COMMON.FFIELD'
16004 !      include 'COMMON.IOUNITS'
16005 !      include 'COMMON.CONTROL'
16006       real(kind=8),dimension(3) :: ggg
16007 !el local variables
16008       integer :: i,iint,j,k,iteli,itypj,subchap
16009       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16010       real(kind=8) :: evdw2,evdw2_14,evdwij
16011       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16012                     dist_temp, dist_init
16013
16014       evdw2=0.0D0
16015       evdw2_14=0.0d0
16016 !d    print '(a)','Enter ESCP'
16017 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16018       do i=iatscp_s,iatscp_e
16019         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16020         iteli=itel(i)
16021         xi=0.5D0*(c(1,i)+c(1,i+1))
16022         yi=0.5D0*(c(2,i)+c(2,i+1))
16023         zi=0.5D0*(c(3,i)+c(3,i+1))
16024           xi=mod(xi,boxxsize)
16025           if (xi.lt.0) xi=xi+boxxsize
16026           yi=mod(yi,boxysize)
16027           if (yi.lt.0) yi=yi+boxysize
16028           zi=mod(zi,boxzsize)
16029           if (zi.lt.0) zi=zi+boxzsize
16030
16031         do iint=1,nscp_gr(i)
16032
16033         do j=iscpstart(i,iint),iscpend(i,iint)
16034           itypj=itype(j,1)
16035           if (itypj.eq.ntyp1) cycle
16036 ! Uncomment following three lines for SC-p interactions
16037 !         xj=c(1,nres+j)-xi
16038 !         yj=c(2,nres+j)-yi
16039 !         zj=c(3,nres+j)-zi
16040 ! Uncomment following three lines for Ca-p interactions
16041 !          xj=c(1,j)-xi
16042 !          yj=c(2,j)-yi
16043 !          zj=c(3,j)-zi
16044           xj=c(1,j)
16045           yj=c(2,j)
16046           zj=c(3,j)
16047           xj=mod(xj,boxxsize)
16048           if (xj.lt.0) xj=xj+boxxsize
16049           yj=mod(yj,boxysize)
16050           if (yj.lt.0) yj=yj+boxysize
16051           zj=mod(zj,boxzsize)
16052           if (zj.lt.0) zj=zj+boxzsize
16053       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16054       xj_safe=xj
16055       yj_safe=yj
16056       zj_safe=zj
16057       subchap=0
16058       do xshift=-1,1
16059       do yshift=-1,1
16060       do zshift=-1,1
16061           xj=xj_safe+xshift*boxxsize
16062           yj=yj_safe+yshift*boxysize
16063           zj=zj_safe+zshift*boxzsize
16064           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16065           if(dist_temp.lt.dist_init) then
16066             dist_init=dist_temp
16067             xj_temp=xj
16068             yj_temp=yj
16069             zj_temp=zj
16070             subchap=1
16071           endif
16072        enddo
16073        enddo
16074        enddo
16075        if (subchap.eq.1) then
16076           xj=xj_temp-xi
16077           yj=yj_temp-yi
16078           zj=zj_temp-zi
16079        else
16080           xj=xj_safe-xi
16081           yj=yj_safe-yi
16082           zj=zj_safe-zi
16083        endif
16084
16085           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16086           rij=dsqrt(1.0d0/rrij)
16087             sss_ele_cut=sscale_ele(rij)
16088             sss_ele_grad=sscagrad_ele(rij)
16089 !            print *,sss_ele_cut,sss_ele_grad,&
16090 !            (rij),r_cut_ele,rlamb_ele
16091             if (sss_ele_cut.le.0.0) cycle
16092           sss=sscale(rij/rscp(itypj,iteli))
16093           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16094           if (sss.gt.0.0d0) then
16095
16096             fac=rrij**expon2
16097             e1=fac*fac*aad(itypj,iteli)
16098             e2=fac*bad(itypj,iteli)
16099             if (iabs(j-i) .le. 2) then
16100               e1=scal14*e1
16101               e2=scal14*e2
16102               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16103             endif
16104             evdwij=e1+e2
16105             evdw2=evdw2+evdwij*sss*sss_ele_cut
16106             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16107                 'evdw2',i,j,sss,evdwij
16108 !
16109 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16110 !
16111             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16112             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16113             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16114
16115             ggg(1)=xj*fac
16116             ggg(2)=yj*fac
16117             ggg(3)=zj*fac
16118 ! Uncomment following three lines for SC-p interactions
16119 !           do k=1,3
16120 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16121 !           enddo
16122 ! Uncomment following line for SC-p interactions
16123 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16124             do k=1,3
16125               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16126               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16127             enddo
16128           endif
16129         enddo
16130
16131         enddo ! iint
16132       enddo ! i
16133       do i=1,nct
16134         do j=1,3
16135           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16136           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16137           gradx_scp(j,i)=expon*gradx_scp(j,i)
16138         enddo
16139       enddo
16140 !******************************************************************************
16141 !
16142 !                              N O T E !!!
16143 !
16144 ! To save time the factor EXPON has been extracted from ALL components
16145 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16146 ! use!
16147 !
16148 !******************************************************************************
16149       return
16150       end subroutine escp_short
16151 !-----------------------------------------------------------------------------
16152 ! energy_p_new-sep_barrier.F
16153 !-----------------------------------------------------------------------------
16154       subroutine sc_grad_scale(scalfac)
16155 !      implicit real*8 (a-h,o-z)
16156       use calc_data
16157 !      include 'DIMENSIONS'
16158 !      include 'COMMON.CHAIN'
16159 !      include 'COMMON.DERIV'
16160 !      include 'COMMON.CALC'
16161 !      include 'COMMON.IOUNITS'
16162       real(kind=8),dimension(3) :: dcosom1,dcosom2
16163       real(kind=8) :: scalfac
16164 !el local variables
16165 !      integer :: i,j,k,l
16166
16167       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16168       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16169       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16170            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16171 ! diagnostics only
16172 !      eom1=0.0d0
16173 !      eom2=0.0d0
16174 !      eom12=evdwij*eps1_om12
16175 ! end diagnostics
16176 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16177 !     &  " sigder",sigder
16178 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16179 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16180       do k=1,3
16181         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16182         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16183       enddo
16184       do k=1,3
16185         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16186          *sss_ele_cut
16187       enddo
16188 !      write (iout,*) "gg",(gg(k),k=1,3)
16189       do k=1,3
16190         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16191                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16192                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16193                  *sss_ele_cut
16194         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16195                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16196                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16197          *sss_ele_cut
16198 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16199 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16200 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16201 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16202       enddo
16203 !
16204 ! Calculate the components of the gradient in DC and X
16205 !
16206       do l=1,3
16207         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16208         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16209       enddo
16210       return
16211       end subroutine sc_grad_scale
16212 !-----------------------------------------------------------------------------
16213 ! energy_split-sep.F
16214 !-----------------------------------------------------------------------------
16215       subroutine etotal_long(energia)
16216 !
16217 ! Compute the long-range slow-varying contributions to the energy
16218 !
16219 !      implicit real*8 (a-h,o-z)
16220 !      include 'DIMENSIONS'
16221       use MD_data, only: totT,usampl,eq_time
16222 #ifndef ISNAN
16223       external proc_proc
16224 #ifdef WINPGI
16225 !MS$ATTRIBUTES C ::  proc_proc
16226 #endif
16227 #endif
16228 #ifdef MPI
16229       include "mpif.h"
16230       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16231 #endif
16232 !      include 'COMMON.SETUP'
16233 !      include 'COMMON.IOUNITS'
16234 !      include 'COMMON.FFIELD'
16235 !      include 'COMMON.DERIV'
16236 !      include 'COMMON.INTERACT'
16237 !      include 'COMMON.SBRIDGE'
16238 !      include 'COMMON.CHAIN'
16239 !      include 'COMMON.VAR'
16240 !      include 'COMMON.LOCAL'
16241 !      include 'COMMON.MD'
16242       real(kind=8),dimension(0:n_ene) :: energia
16243 !el local variables
16244       integer :: i,n_corr,n_corr1,ierror,ierr
16245       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16246                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16247                   ecorr,ecorr5,ecorr6,eturn6,time00
16248 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16249 !elwrite(iout,*)"in etotal long"
16250
16251       if (modecalc.eq.12.or.modecalc.eq.14) then
16252 #ifdef MPI
16253 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16254 #else
16255         call int_from_cart1(.false.)
16256 #endif
16257       endif
16258 !elwrite(iout,*)"in etotal long"
16259
16260 #ifdef MPI
16261 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16262 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16263       call flush(iout)
16264       if (nfgtasks.gt.1) then
16265         time00=MPI_Wtime()
16266 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16267         if (fg_rank.eq.0) then
16268           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16269 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16270 !          call flush(iout)
16271 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16272 ! FG slaves as WEIGHTS array.
16273           weights_(1)=wsc
16274           weights_(2)=wscp
16275           weights_(3)=welec
16276           weights_(4)=wcorr
16277           weights_(5)=wcorr5
16278           weights_(6)=wcorr6
16279           weights_(7)=wel_loc
16280           weights_(8)=wturn3
16281           weights_(9)=wturn4
16282           weights_(10)=wturn6
16283           weights_(11)=wang
16284           weights_(12)=wscloc
16285           weights_(13)=wtor
16286           weights_(14)=wtor_d
16287           weights_(15)=wstrain
16288           weights_(16)=wvdwpp
16289           weights_(17)=wbond
16290           weights_(18)=scal14
16291           weights_(21)=wsccor
16292 ! FG Master broadcasts the WEIGHTS_ array
16293           call MPI_Bcast(weights_(1),n_ene,&
16294               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16295         else
16296 ! FG slaves receive the WEIGHTS array
16297           call MPI_Bcast(weights(1),n_ene,&
16298               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16299           wsc=weights(1)
16300           wscp=weights(2)
16301           welec=weights(3)
16302           wcorr=weights(4)
16303           wcorr5=weights(5)
16304           wcorr6=weights(6)
16305           wel_loc=weights(7)
16306           wturn3=weights(8)
16307           wturn4=weights(9)
16308           wturn6=weights(10)
16309           wang=weights(11)
16310           wscloc=weights(12)
16311           wtor=weights(13)
16312           wtor_d=weights(14)
16313           wstrain=weights(15)
16314           wvdwpp=weights(16)
16315           wbond=weights(17)
16316           scal14=weights(18)
16317           wsccor=weights(21)
16318         endif
16319         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16320           king,FG_COMM,IERR)
16321          time_Bcast=time_Bcast+MPI_Wtime()-time00
16322          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16323 !        call chainbuild_cart
16324 !        call int_from_cart1(.false.)
16325       endif
16326 !      write (iout,*) 'Processor',myrank,
16327 !     &  ' calling etotal_short ipot=',ipot
16328 !      call flush(iout)
16329 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16330 #endif
16331 !d    print *,'nnt=',nnt,' nct=',nct
16332 !
16333 !elwrite(iout,*)"in etotal long"
16334 ! Compute the side-chain and electrostatic interaction energy
16335 !
16336       goto (101,102,103,104,105,106) ipot
16337 ! Lennard-Jones potential.
16338   101 call elj_long(evdw)
16339 !d    print '(a)','Exit ELJ'
16340       goto 107
16341 ! Lennard-Jones-Kihara potential (shifted).
16342   102 call eljk_long(evdw)
16343       goto 107
16344 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16345   103 call ebp_long(evdw)
16346       goto 107
16347 ! Gay-Berne potential (shifted LJ, angular dependence).
16348   104 call egb_long(evdw)
16349       goto 107
16350 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16351   105 call egbv_long(evdw)
16352       goto 107
16353 ! Soft-sphere potential
16354   106 call e_softsphere(evdw)
16355 !
16356 ! Calculate electrostatic (H-bonding) energy of the main chain.
16357 !
16358   107 continue
16359       call vec_and_deriv
16360       if (ipot.lt.6) then
16361 #ifdef SPLITELE
16362          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16363              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16364              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16365              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16366 #else
16367          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16368              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16369              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16370              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16371 #endif
16372            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16373          else
16374             ees=0
16375             evdw1=0
16376             eel_loc=0
16377             eello_turn3=0
16378             eello_turn4=0
16379          endif
16380       else
16381 !        write (iout,*) "Soft-spheer ELEC potential"
16382         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16383          eello_turn4)
16384       endif
16385 !
16386 ! Calculate excluded-volume interaction energy between peptide groups
16387 ! and side chains.
16388 !
16389       if (ipot.lt.6) then
16390        if(wscp.gt.0d0) then
16391         call escp_long(evdw2,evdw2_14)
16392        else
16393         evdw2=0
16394         evdw2_14=0
16395        endif
16396       else
16397         call escp_soft_sphere(evdw2,evdw2_14)
16398       endif
16399 !
16400 ! 12/1/95 Multi-body terms
16401 !
16402       n_corr=0
16403       n_corr1=0
16404       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16405           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16406          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16407 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16408 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16409       else
16410          ecorr=0.0d0
16411          ecorr5=0.0d0
16412          ecorr6=0.0d0
16413          eturn6=0.0d0
16414       endif
16415       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16416          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16417       endif
16418 !
16419 ! If performing constraint dynamics, call the constraint energy
16420 !  after the equilibration time
16421       if(usampl.and.totT.gt.eq_time) then
16422          call EconstrQ
16423          call Econstr_back
16424       else
16425          Uconst=0.0d0
16426          Uconst_back=0.0d0
16427       endif
16428 !
16429 ! Sum the energies
16430 !
16431       do i=1,n_ene
16432         energia(i)=0.0d0
16433       enddo
16434       energia(1)=evdw
16435 #ifdef SCP14
16436       energia(2)=evdw2-evdw2_14
16437       energia(18)=evdw2_14
16438 #else
16439       energia(2)=evdw2
16440       energia(18)=0.0d0
16441 #endif
16442 #ifdef SPLITELE
16443       energia(3)=ees
16444       energia(16)=evdw1
16445 #else
16446       energia(3)=ees+evdw1
16447       energia(16)=0.0d0
16448 #endif
16449       energia(4)=ecorr
16450       energia(5)=ecorr5
16451       energia(6)=ecorr6
16452       energia(7)=eel_loc
16453       energia(8)=eello_turn3
16454       energia(9)=eello_turn4
16455       energia(10)=eturn6
16456       energia(20)=Uconst+Uconst_back
16457       call sum_energy(energia,.true.)
16458 !      write (iout,*) "Exit ETOTAL_LONG"
16459       call flush(iout)
16460       return
16461       end subroutine etotal_long
16462 !-----------------------------------------------------------------------------
16463       subroutine etotal_short(energia)
16464 !
16465 ! Compute the short-range fast-varying contributions to the energy
16466 !
16467 !      implicit real*8 (a-h,o-z)
16468 !      include 'DIMENSIONS'
16469 #ifndef ISNAN
16470       external proc_proc
16471 #ifdef WINPGI
16472 !MS$ATTRIBUTES C ::  proc_proc
16473 #endif
16474 #endif
16475 #ifdef MPI
16476       include "mpif.h"
16477       integer :: ierror,ierr
16478       real(kind=8),dimension(n_ene) :: weights_
16479       real(kind=8) :: time00
16480 #endif
16481 !      include 'COMMON.SETUP'
16482 !      include 'COMMON.IOUNITS'
16483 !      include 'COMMON.FFIELD'
16484 !      include 'COMMON.DERIV'
16485 !      include 'COMMON.INTERACT'
16486 !      include 'COMMON.SBRIDGE'
16487 !      include 'COMMON.CHAIN'
16488 !      include 'COMMON.VAR'
16489 !      include 'COMMON.LOCAL'
16490       real(kind=8),dimension(0:n_ene) :: energia
16491 !el local variables
16492       integer :: i,nres6
16493       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16494       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16495       nres6=6*nres
16496
16497 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16498 !      call flush(iout)
16499       if (modecalc.eq.12.or.modecalc.eq.14) then
16500 #ifdef MPI
16501         if (fg_rank.eq.0) call int_from_cart1(.false.)
16502 #else
16503         call int_from_cart1(.false.)
16504 #endif
16505       endif
16506 #ifdef MPI
16507 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16508 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16509 !      call flush(iout)
16510       if (nfgtasks.gt.1) then
16511         time00=MPI_Wtime()
16512 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16513         if (fg_rank.eq.0) then
16514           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16515 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16516 !          call flush(iout)
16517 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16518 ! FG slaves as WEIGHTS array.
16519           weights_(1)=wsc
16520           weights_(2)=wscp
16521           weights_(3)=welec
16522           weights_(4)=wcorr
16523           weights_(5)=wcorr5
16524           weights_(6)=wcorr6
16525           weights_(7)=wel_loc
16526           weights_(8)=wturn3
16527           weights_(9)=wturn4
16528           weights_(10)=wturn6
16529           weights_(11)=wang
16530           weights_(12)=wscloc
16531           weights_(13)=wtor
16532           weights_(14)=wtor_d
16533           weights_(15)=wstrain
16534           weights_(16)=wvdwpp
16535           weights_(17)=wbond
16536           weights_(18)=scal14
16537           weights_(21)=wsccor
16538 ! FG Master broadcasts the WEIGHTS_ array
16539           call MPI_Bcast(weights_(1),n_ene,&
16540               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16541         else
16542 ! FG slaves receive the WEIGHTS array
16543           call MPI_Bcast(weights(1),n_ene,&
16544               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16545           wsc=weights(1)
16546           wscp=weights(2)
16547           welec=weights(3)
16548           wcorr=weights(4)
16549           wcorr5=weights(5)
16550           wcorr6=weights(6)
16551           wel_loc=weights(7)
16552           wturn3=weights(8)
16553           wturn4=weights(9)
16554           wturn6=weights(10)
16555           wang=weights(11)
16556           wscloc=weights(12)
16557           wtor=weights(13)
16558           wtor_d=weights(14)
16559           wstrain=weights(15)
16560           wvdwpp=weights(16)
16561           wbond=weights(17)
16562           scal14=weights(18)
16563           wsccor=weights(21)
16564         endif
16565 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16566         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16567           king,FG_COMM,IERR)
16568 !        write (iout,*) "Processor",myrank," BROADCAST c"
16569         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16570           king,FG_COMM,IERR)
16571 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16572         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16573           king,FG_COMM,IERR)
16574 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16575         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16576           king,FG_COMM,IERR)
16577 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16578         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16579           king,FG_COMM,IERR)
16580 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16581         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16582           king,FG_COMM,IERR)
16583 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16584         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16585           king,FG_COMM,IERR)
16586 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16587         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16588           king,FG_COMM,IERR)
16589 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16590         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16591           king,FG_COMM,IERR)
16592          time_Bcast=time_Bcast+MPI_Wtime()-time00
16593 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16594       endif
16595 !      write (iout,*) 'Processor',myrank,
16596 !     &  ' calling etotal_short ipot=',ipot
16597 !      call flush(iout)
16598 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16599 #endif
16600 !      call int_from_cart1(.false.)
16601 !
16602 ! Compute the side-chain and electrostatic interaction energy
16603 !
16604       goto (101,102,103,104,105,106) ipot
16605 ! Lennard-Jones potential.
16606   101 call elj_short(evdw)
16607 !d    print '(a)','Exit ELJ'
16608       goto 107
16609 ! Lennard-Jones-Kihara potential (shifted).
16610   102 call eljk_short(evdw)
16611       goto 107
16612 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16613   103 call ebp_short(evdw)
16614       goto 107
16615 ! Gay-Berne potential (shifted LJ, angular dependence).
16616   104 call egb_short(evdw)
16617       goto 107
16618 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16619   105 call egbv_short(evdw)
16620       goto 107
16621 ! Soft-sphere potential - already dealt with in the long-range part
16622   106 evdw=0.0d0
16623 !  106 call e_softsphere_short(evdw)
16624 !
16625 ! Calculate electrostatic (H-bonding) energy of the main chain.
16626 !
16627   107 continue
16628 !
16629 ! Calculate the short-range part of Evdwpp
16630 !
16631       call evdwpp_short(evdw1)
16632 !
16633 ! Calculate the short-range part of ESCp
16634 !
16635       if (ipot.lt.6) then
16636         call escp_short(evdw2,evdw2_14)
16637       endif
16638 !
16639 ! Calculate the bond-stretching energy
16640 !
16641       call ebond(estr)
16642 !
16643 ! Calculate the disulfide-bridge and other energy and the contributions
16644 ! from other distance constraints.
16645       call edis(ehpb)
16646 !
16647 ! Calculate the virtual-bond-angle energy.
16648 !
16649 ! Calculate the SC local energy.
16650 !
16651       call vec_and_deriv
16652       call esc(escloc)
16653 !
16654       if (wang.gt.0d0) then
16655        if (tor_mode.eq.0) then
16656          call ebend(ebe)
16657        else
16658 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16659 !C energy function
16660          call ebend_kcc(ebe)
16661        endif
16662       else
16663         ebe=0.0d0
16664       endif
16665       ethetacnstr=0.0d0
16666       if (with_theta_constr) call etheta_constr(ethetacnstr)
16667
16668 !       write(iout,*) "in etotal afer ebe",ipot
16669
16670 !      print *,"Processor",myrank," computed UB"
16671 !
16672 ! Calculate the SC local energy.
16673 !
16674       call esc(escloc)
16675 !elwrite(iout,*) "in etotal afer esc",ipot
16676 !      print *,"Processor",myrank," computed USC"
16677 !
16678 ! Calculate the virtual-bond torsional energy.
16679 !
16680 !d    print *,'nterm=',nterm
16681 !      if (wtor.gt.0) then
16682 !       call etor(etors,edihcnstr)
16683 !      else
16684 !       etors=0
16685 !       edihcnstr=0
16686 !      endif
16687       if (wtor.gt.0.0d0) then
16688          if (tor_mode.eq.0) then
16689            call etor(etors)
16690          else
16691 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16692 !C energy function
16693            call etor_kcc(etors)
16694          endif
16695       else
16696         etors=0.0d0
16697       endif
16698       edihcnstr=0.0d0
16699       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16700
16701 ! Calculate the virtual-bond torsional energy.
16702 !
16703 !
16704 ! 6/23/01 Calculate double-torsional energy
16705 !
16706       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16707       call etor_d(etors_d)
16708       endif
16709 !
16710 ! 21/5/07 Calculate local sicdechain correlation energy
16711 !
16712       if (wsccor.gt.0.0d0) then
16713         call eback_sc_corr(esccor)
16714       else
16715         esccor=0.0d0
16716       endif
16717 !
16718 ! Put energy components into an array
16719 !
16720       do i=1,n_ene
16721         energia(i)=0.0d0
16722       enddo
16723       energia(1)=evdw
16724 #ifdef SCP14
16725       energia(2)=evdw2-evdw2_14
16726       energia(18)=evdw2_14
16727 #else
16728       energia(2)=evdw2
16729       energia(18)=0.0d0
16730 #endif
16731 #ifdef SPLITELE
16732       energia(16)=evdw1
16733 #else
16734       energia(3)=evdw1
16735 #endif
16736       energia(11)=ebe
16737       energia(12)=escloc
16738       energia(13)=etors
16739       energia(14)=etors_d
16740       energia(15)=ehpb
16741       energia(17)=estr
16742       energia(19)=edihcnstr
16743       energia(21)=esccor
16744 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16745       call flush(iout)
16746       call sum_energy(energia,.true.)
16747 !      write (iout,*) "Exit ETOTAL_SHORT"
16748       call flush(iout)
16749       return
16750       end subroutine etotal_short
16751 !-----------------------------------------------------------------------------
16752 ! gnmr1.f
16753 !-----------------------------------------------------------------------------
16754       real(kind=8) function gnmr1(y,ymin,ymax)
16755 !      implicit none
16756       real(kind=8) :: y,ymin,ymax
16757       real(kind=8) :: wykl=4.0d0
16758       if (y.lt.ymin) then
16759         gnmr1=(ymin-y)**wykl/wykl
16760       else if (y.gt.ymax) then
16761         gnmr1=(y-ymax)**wykl/wykl
16762       else
16763         gnmr1=0.0d0
16764       endif
16765       return
16766       end function gnmr1
16767 !-----------------------------------------------------------------------------
16768       real(kind=8) function gnmr1prim(y,ymin,ymax)
16769 !      implicit none
16770       real(kind=8) :: y,ymin,ymax
16771       real(kind=8) :: wykl=4.0d0
16772       if (y.lt.ymin) then
16773         gnmr1prim=-(ymin-y)**(wykl-1)
16774       else if (y.gt.ymax) then
16775         gnmr1prim=(y-ymax)**(wykl-1)
16776       else
16777         gnmr1prim=0.0d0
16778       endif
16779       return
16780       end function gnmr1prim
16781 !----------------------------------------------------------------------------
16782       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16783       real(kind=8) y,ymin,ymax,sigma
16784       real(kind=8) wykl /4.0d0/
16785       if (y.lt.ymin) then
16786         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16787       else if (y.gt.ymax) then
16788         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16789       else
16790         rlornmr1=0.0d0
16791       endif
16792       return
16793       end function rlornmr1
16794 !------------------------------------------------------------------------------
16795       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16796       real(kind=8) y,ymin,ymax,sigma
16797       real(kind=8) wykl /4.0d0/
16798       if (y.lt.ymin) then
16799         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16800         ((ymin-y)**wykl+sigma**wykl)**2
16801       else if (y.gt.ymax) then
16802         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16803         ((y-ymax)**wykl+sigma**wykl)**2
16804       else
16805         rlornmr1prim=0.0d0
16806       endif
16807       return
16808       end function rlornmr1prim
16809
16810       real(kind=8) function harmonic(y,ymax)
16811 !      implicit none
16812       real(kind=8) :: y,ymax
16813       real(kind=8) :: wykl=2.0d0
16814       harmonic=(y-ymax)**wykl
16815       return
16816       end function harmonic
16817 !-----------------------------------------------------------------------------
16818       real(kind=8) function harmonicprim(y,ymax)
16819       real(kind=8) :: y,ymin,ymax
16820       real(kind=8) :: wykl=2.0d0
16821       harmonicprim=(y-ymax)*wykl
16822       return
16823       end function harmonicprim
16824 !-----------------------------------------------------------------------------
16825 ! gradient_p.F
16826 !-----------------------------------------------------------------------------
16827       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16828
16829       use io_base, only:intout,briefout
16830 !      implicit real*8 (a-h,o-z)
16831 !      include 'DIMENSIONS'
16832 !      include 'COMMON.CHAIN'
16833 !      include 'COMMON.DERIV'
16834 !      include 'COMMON.VAR'
16835 !      include 'COMMON.INTERACT'
16836 !      include 'COMMON.FFIELD'
16837 !      include 'COMMON.MD'
16838 !      include 'COMMON.IOUNITS'
16839       real(kind=8),external :: ufparm
16840       integer :: uiparm(1)
16841       real(kind=8) :: urparm(1)
16842       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16843       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16844       integer :: n,nf,ind,ind1,i,k,j
16845 !
16846 ! This subroutine calculates total internal coordinate gradient.
16847 ! Depending on the number of function evaluations, either whole energy
16848 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16849 ! internal coordinates are reevaluated or only the cartesian-in-internal
16850 ! coordinate derivatives are evaluated. The subroutine was designed to work
16851 ! with SUMSL.
16852 !
16853 !
16854       icg=mod(nf,2)+1
16855
16856 !d      print *,'grad',nf,icg
16857       if (nf-nfl+1) 20,30,40
16858    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16859 !    write (iout,*) 'grad 20'
16860       if (nf.eq.0) return
16861       goto 40
16862    30 call var_to_geom(n,x)
16863       call chainbuild
16864 !    write (iout,*) 'grad 30'
16865 !
16866 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16867 !
16868    40 call cartder
16869 !     write (iout,*) 'grad 40'
16870 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16871 !
16872 ! Convert the Cartesian gradient into internal-coordinate gradient.
16873 !
16874       ind=0
16875       ind1=0
16876       do i=1,nres-2
16877       gthetai=0.0D0
16878       gphii=0.0D0
16879       do j=i+1,nres-1
16880           ind=ind+1
16881 !         ind=indmat(i,j)
16882 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16883         do k=1,3
16884             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16885           enddo
16886         do k=1,3
16887           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16888           enddo
16889         enddo
16890       do j=i+1,nres-1
16891           ind1=ind1+1
16892 !         ind1=indmat(i,j)
16893 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16894         do k=1,3
16895           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16896           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16897           enddo
16898         enddo
16899       if (i.gt.1) g(i-1)=gphii
16900       if (n.gt.nphi) g(nphi+i)=gthetai
16901       enddo
16902       if (n.le.nphi+ntheta) goto 10
16903       do i=2,nres-1
16904       if (itype(i,1).ne.10) then
16905           galphai=0.0D0
16906         gomegai=0.0D0
16907         do k=1,3
16908           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16909           enddo
16910         do k=1,3
16911           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16912           enddo
16913           g(ialph(i,1))=galphai
16914         g(ialph(i,1)+nside)=gomegai
16915         endif
16916       enddo
16917 !
16918 ! Add the components corresponding to local energy terms.
16919 !
16920    10 continue
16921       do i=1,nvar
16922 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16923         g(i)=g(i)+gloc(i,icg)
16924       enddo
16925 ! Uncomment following three lines for diagnostics.
16926 !d    call intout
16927 !elwrite(iout,*) "in gradient after calling intout"
16928 !d    call briefout(0,0.0d0)
16929 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16930       return
16931       end subroutine gradient
16932 !-----------------------------------------------------------------------------
16933       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16934
16935       use comm_chu
16936 !      implicit real*8 (a-h,o-z)
16937 !      include 'DIMENSIONS'
16938 !      include 'COMMON.DERIV'
16939 !      include 'COMMON.IOUNITS'
16940 !      include 'COMMON.GEO'
16941       integer :: n,nf
16942 !el      integer :: jjj
16943 !el      common /chuju/ jjj
16944       real(kind=8) :: energia(0:n_ene)
16945       integer :: uiparm(1)
16946       real(kind=8) :: urparm(1)
16947       real(kind=8) :: f
16948       real(kind=8),external :: ufparm
16949       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16950 !     if (jjj.gt.0) then
16951 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16952 !     endif
16953       nfl=nf
16954       icg=mod(nf,2)+1
16955 !d      print *,'func',nf,nfl,icg
16956       call var_to_geom(n,x)
16957       call zerograd
16958       call chainbuild
16959 !d    write (iout,*) 'ETOTAL called from FUNC'
16960       call etotal(energia)
16961       call sum_gradient
16962       f=energia(0)
16963 !     if (jjj.gt.0) then
16964 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16965 !       write (iout,*) 'f=',etot
16966 !       jjj=0
16967 !     endif
16968       return
16969       end subroutine func
16970 !-----------------------------------------------------------------------------
16971       subroutine cartgrad
16972 !      implicit real*8 (a-h,o-z)
16973 !      include 'DIMENSIONS'
16974       use energy_data
16975       use MD_data, only: totT,usampl,eq_time
16976 #ifdef MPI
16977       include 'mpif.h'
16978 #endif
16979 !      include 'COMMON.CHAIN'
16980 !      include 'COMMON.DERIV'
16981 !      include 'COMMON.VAR'
16982 !      include 'COMMON.INTERACT'
16983 !      include 'COMMON.FFIELD'
16984 !      include 'COMMON.MD'
16985 !      include 'COMMON.IOUNITS'
16986 !      include 'COMMON.TIME1'
16987 !
16988       integer :: i,j
16989
16990 ! This subrouting calculates total Cartesian coordinate gradient.
16991 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16992 !
16993 !#define DEBUG
16994 #ifdef TIMING
16995       time00=MPI_Wtime()
16996 #endif
16997       icg=1
16998       call sum_gradient
16999 #ifdef TIMING
17000 #endif
17001 !#define DEBUG
17002 !el      write (iout,*) "After sum_gradient"
17003 #ifdef DEBUG
17004 !el      write (iout,*) "After sum_gradient"
17005       do i=1,nres-1
17006         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17007         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17008       enddo
17009 #endif
17010 !#undef DEBUG
17011 ! If performing constraint dynamics, add the gradients of the constraint energy
17012       if(usampl.and.totT.gt.eq_time) then
17013          do i=1,nct
17014            do j=1,3
17015              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17016              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17017            enddo
17018          enddo
17019          do i=1,nres-3
17020            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17021          enddo
17022          do i=1,nres-2
17023            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17024          enddo
17025       endif
17026 !elwrite (iout,*) "After sum_gradient"
17027 #ifdef TIMING
17028       time01=MPI_Wtime()
17029 #endif
17030       call intcartderiv
17031 !elwrite (iout,*) "After sum_gradient"
17032 #ifdef TIMING
17033       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17034 #endif
17035 !     call checkintcartgrad
17036 !     write(iout,*) 'calling int_to_cart'
17037 !#define DEBUG
17038 #ifdef DEBUG
17039       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17040 #endif
17041       do i=0,nct
17042         do j=1,3
17043           gcart(j,i)=gradc(j,i,icg)
17044           gxcart(j,i)=gradx(j,i,icg)
17045 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17046         enddo
17047 #ifdef DEBUG
17048         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17049           (gxcart(j,i),j=1,3),gloc(i,icg)
17050 #endif
17051       enddo
17052 #ifdef TIMING
17053       time01=MPI_Wtime()
17054 #endif
17055 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17056       call int_to_cart
17057 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17058
17059 #ifdef TIMING
17060             time_inttocart=time_inttocart+MPI_Wtime()-time01
17061 #endif
17062 #ifdef DEBUG
17063             write (iout,*) "gcart and gxcart after int_to_cart"
17064             do i=0,nres-1
17065             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17066                 (gxcart(j,i),j=1,3)
17067             enddo
17068 #endif
17069 !#undef DEBUG
17070 #ifdef CARGRAD
17071 #ifdef DEBUG
17072             write (iout,*) "CARGRAD"
17073 #endif
17074             do i=nres,0,-1
17075             do j=1,3
17076               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17077       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17078             enddo
17079       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17080       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17081             enddo
17082       ! Correction: dummy residues
17083             if (nnt.gt.1) then
17084               do j=1,3
17085       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17086                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17087               enddo
17088             endif
17089             if (nct.lt.nres) then
17090               do j=1,3
17091       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17092                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17093               enddo
17094             endif
17095 #endif
17096 #ifdef TIMING
17097             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17098 #endif
17099 !#undef DEBUG
17100             return
17101             end subroutine cartgrad
17102       !-----------------------------------------------------------------------------
17103             subroutine zerograd
17104       !      implicit real*8 (a-h,o-z)
17105       !      include 'DIMENSIONS'
17106       !      include 'COMMON.DERIV'
17107       !      include 'COMMON.CHAIN'
17108       !      include 'COMMON.VAR'
17109       !      include 'COMMON.MD'
17110       !      include 'COMMON.SCCOR'
17111       !
17112       !el local variables
17113             integer :: i,j,intertyp,k
17114       ! Initialize Cartesian-coordinate gradient
17115       !
17116       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17117       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17118
17119       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17120       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17121       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17122       !      allocate(gradcorr_long(3,nres))
17123       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17124       !      allocate(gcorr6_turn_long(3,nres))
17125       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17126
17127       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17128
17129       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17130       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17131
17132       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17133       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17134
17135       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17136       !      allocate(gscloc(3,nres)) !(3,maxres)
17137       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17138
17139
17140
17141       !      common /deriv_scloc/
17142       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17143       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17144       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17145       !      common /mpgrad/
17146       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17147
17148
17149
17150       !          gradc(j,i,icg)=0.0d0
17151       !          gradx(j,i,icg)=0.0d0
17152
17153       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17154       !elwrite(iout,*) "icg",icg
17155             do i=-1,nres
17156             do j=1,3
17157               gvdwx(j,i)=0.0D0
17158               gradx_scp(j,i)=0.0D0
17159               gvdwc(j,i)=0.0D0
17160               gvdwc_scp(j,i)=0.0D0
17161               gvdwc_scpp(j,i)=0.0d0
17162               gelc(j,i)=0.0D0
17163               gelc_long(j,i)=0.0D0
17164               gradb(j,i)=0.0d0
17165               gradbx(j,i)=0.0d0
17166               gvdwpp(j,i)=0.0d0
17167               gel_loc(j,i)=0.0d0
17168               gel_loc_long(j,i)=0.0d0
17169               ghpbc(j,i)=0.0D0
17170               ghpbx(j,i)=0.0D0
17171               gcorr3_turn(j,i)=0.0d0
17172               gcorr4_turn(j,i)=0.0d0
17173               gradcorr(j,i)=0.0d0
17174               gradcorr_long(j,i)=0.0d0
17175               gradcorr5_long(j,i)=0.0d0
17176               gradcorr6_long(j,i)=0.0d0
17177               gcorr6_turn_long(j,i)=0.0d0
17178               gradcorr5(j,i)=0.0d0
17179               gradcorr6(j,i)=0.0d0
17180               gcorr6_turn(j,i)=0.0d0
17181               gsccorc(j,i)=0.0d0
17182               gsccorx(j,i)=0.0d0
17183               gradc(j,i,icg)=0.0d0
17184               gradx(j,i,icg)=0.0d0
17185               gscloc(j,i)=0.0d0
17186               gsclocx(j,i)=0.0d0
17187               gliptran(j,i)=0.0d0
17188               gliptranx(j,i)=0.0d0
17189               gliptranc(j,i)=0.0d0
17190               gshieldx(j,i)=0.0d0
17191               gshieldc(j,i)=0.0d0
17192               gshieldc_loc(j,i)=0.0d0
17193               gshieldx_ec(j,i)=0.0d0
17194               gshieldc_ec(j,i)=0.0d0
17195               gshieldc_loc_ec(j,i)=0.0d0
17196               gshieldx_t3(j,i)=0.0d0
17197               gshieldc_t3(j,i)=0.0d0
17198               gshieldc_loc_t3(j,i)=0.0d0
17199               gshieldx_t4(j,i)=0.0d0
17200               gshieldc_t4(j,i)=0.0d0
17201               gshieldc_loc_t4(j,i)=0.0d0
17202               gshieldx_ll(j,i)=0.0d0
17203               gshieldc_ll(j,i)=0.0d0
17204               gshieldc_loc_ll(j,i)=0.0d0
17205               gg_tube(j,i)=0.0d0
17206               gg_tube_sc(j,i)=0.0d0
17207               gradafm(j,i)=0.0d0
17208               gradb_nucl(j,i)=0.0d0
17209               gradbx_nucl(j,i)=0.0d0
17210               gvdwpp_nucl(j,i)=0.0d0
17211               gvdwpp(j,i)=0.0d0
17212               gelpp(j,i)=0.0d0
17213               gvdwpsb(j,i)=0.0d0
17214               gvdwpsb1(j,i)=0.0d0
17215               gvdwsbc(j,i)=0.0d0
17216               gvdwsbx(j,i)=0.0d0
17217               gelsbc(j,i)=0.0d0
17218               gradcorr_nucl(j,i)=0.0d0
17219               gradcorr3_nucl(j,i)=0.0d0
17220               gradxorr_nucl(j,i)=0.0d0
17221               gradxorr3_nucl(j,i)=0.0d0
17222               gelsbx(j,i)=0.0d0
17223               gsbloc(j,i)=0.0d0
17224               gsblocx(j,i)=0.0d0
17225               gradpepcat(j,i)=0.0d0
17226               gradpepcatx(j,i)=0.0d0
17227               gradcatcat(j,i)=0.0d0
17228               gvdwx_scbase(j,i)=0.0d0
17229               gvdwc_scbase(j,i)=0.0d0
17230               gvdwx_pepbase(j,i)=0.0d0
17231               gvdwc_pepbase(j,i)=0.0d0
17232               gvdwx_scpho(j,i)=0.0d0
17233               gvdwc_scpho(j,i)=0.0d0
17234               gvdwc_peppho(j,i)=0.0d0
17235             enddo
17236              enddo
17237             do i=0,nres
17238             do j=1,3
17239               do intertyp=1,3
17240                gloc_sc(intertyp,i,icg)=0.0d0
17241               enddo
17242             enddo
17243             enddo
17244             do i=1,nres
17245              do j=1,maxcontsshi
17246              shield_list(j,i)=0
17247             do k=1,3
17248       !C           print *,i,j,k
17249                grad_shield_side(k,j,i)=0.0d0
17250                grad_shield_loc(k,j,i)=0.0d0
17251              enddo
17252              enddo
17253              ishield_list(i)=0
17254             enddo
17255
17256       !
17257       ! Initialize the gradient of local energy terms.
17258       !
17259       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17260       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17261       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17262       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17263       !      allocate(gel_loc_turn3(nres))
17264       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17265       !      allocate(gsccor_loc(nres))      !(maxres)
17266
17267             do i=1,4*nres
17268             gloc(i,icg)=0.0D0
17269             enddo
17270             do i=1,nres
17271             gel_loc_loc(i)=0.0d0
17272             gcorr_loc(i)=0.0d0
17273             g_corr5_loc(i)=0.0d0
17274             g_corr6_loc(i)=0.0d0
17275             gel_loc_turn3(i)=0.0d0
17276             gel_loc_turn4(i)=0.0d0
17277             gel_loc_turn6(i)=0.0d0
17278             gsccor_loc(i)=0.0d0
17279             enddo
17280       ! initialize gcart and gxcart
17281       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17282             do i=0,nres
17283             do j=1,3
17284               gcart(j,i)=0.0d0
17285               gxcart(j,i)=0.0d0
17286             enddo
17287             enddo
17288             return
17289             end subroutine zerograd
17290       !-----------------------------------------------------------------------------
17291             real(kind=8) function fdum()
17292             fdum=0.0D0
17293             return
17294             end function fdum
17295       !-----------------------------------------------------------------------------
17296       ! intcartderiv.F
17297       !-----------------------------------------------------------------------------
17298             subroutine intcartderiv
17299       !      implicit real*8 (a-h,o-z)
17300       !      include 'DIMENSIONS'
17301 #ifdef MPI
17302             include 'mpif.h'
17303 #endif
17304       !      include 'COMMON.SETUP'
17305       !      include 'COMMON.CHAIN'
17306       !      include 'COMMON.VAR'
17307       !      include 'COMMON.GEO'
17308       !      include 'COMMON.INTERACT'
17309       !      include 'COMMON.DERIV'
17310       !      include 'COMMON.IOUNITS'
17311       !      include 'COMMON.LOCAL'
17312       !      include 'COMMON.SCCOR'
17313             real(kind=8) :: pi4,pi34
17314             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17315             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17316                       dcosomega,dsinomega !(3,3,maxres)
17317             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17318
17319             integer :: i,j,k
17320             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17321                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17322                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17323                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17324             integer :: nres2
17325             nres2=2*nres
17326
17327       !el from module energy-------------
17328       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17329       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17330       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17331
17332       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17333       !el      allocate(dsintau(3,3,3,0:nres2))
17334       !el      allocate(dtauangle(3,3,3,0:nres2))
17335       !el      allocate(domicron(3,2,2,0:nres2))
17336       !el      allocate(dcosomicron(3,2,2,0:nres2))
17337
17338
17339
17340 #if defined(MPI) && defined(PARINTDER)
17341             if (nfgtasks.gt.1 .and. me.eq.king) &
17342             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17343 #endif
17344             pi4 = 0.5d0*pipol
17345             pi34 = 3*pi4
17346
17347       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17348       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17349
17350       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17351             do i=1,nres
17352             do j=1,3
17353               dtheta(j,1,i)=0.0d0
17354               dtheta(j,2,i)=0.0d0
17355               dphi(j,1,i)=0.0d0
17356               dphi(j,2,i)=0.0d0
17357               dphi(j,3,i)=0.0d0
17358             enddo
17359             enddo
17360       ! Derivatives of theta's
17361 #if defined(MPI) && defined(PARINTDER)
17362       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17363             do i=max0(ithet_start-1,3),ithet_end
17364 #else
17365             do i=3,nres
17366 #endif
17367             cost=dcos(theta(i))
17368             sint=sqrt(1-cost*cost)
17369             do j=1,3
17370               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17371               vbld(i-1)
17372               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17373               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17374               vbld(i)
17375               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17376             enddo
17377             enddo
17378 #if defined(MPI) && defined(PARINTDER)
17379       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17380             do i=max0(ithet_start-1,3),ithet_end
17381 #else
17382             do i=3,nres
17383 #endif
17384             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17385             cost1=dcos(omicron(1,i))
17386             sint1=sqrt(1-cost1*cost1)
17387             cost2=dcos(omicron(2,i))
17388             sint2=sqrt(1-cost2*cost2)
17389              do j=1,3
17390       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17391               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17392               cost1*dc_norm(j,i-2))/ &
17393               vbld(i-1)
17394               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17395               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17396               +cost1*(dc_norm(j,i-1+nres)))/ &
17397               vbld(i-1+nres)
17398               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17399       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17400       !C Looks messy but better than if in loop
17401               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17402               +cost2*dc_norm(j,i-1))/ &
17403               vbld(i)
17404               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17405               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17406                +cost2*(-dc_norm(j,i-1+nres)))/ &
17407               vbld(i-1+nres)
17408       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17409               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17410             enddo
17411              endif
17412             enddo
17413       !elwrite(iout,*) "after vbld write"
17414       ! Derivatives of phi:
17415       ! If phi is 0 or 180 degrees, then the formulas
17416       ! have to be derived by power series expansion of the
17417       ! conventional formulas around 0 and 180.
17418 #ifdef PARINTDER
17419             do i=iphi1_start,iphi1_end
17420 #else
17421             do i=4,nres
17422 #endif
17423       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17424       ! the conventional case
17425             sint=dsin(theta(i))
17426             sint1=dsin(theta(i-1))
17427             sing=dsin(phi(i))
17428             cost=dcos(theta(i))
17429             cost1=dcos(theta(i-1))
17430             cosg=dcos(phi(i))
17431             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17432             fac0=1.0d0/(sint1*sint)
17433             fac1=cost*fac0
17434             fac2=cost1*fac0
17435             fac3=cosg*cost1/(sint1*sint1)
17436             fac4=cosg*cost/(sint*sint)
17437       !    Obtaining the gamma derivatives from sine derivative
17438              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17439                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17440                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17441              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17442              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17443              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17444              do j=1,3
17445                 ctgt=cost/sint
17446                 ctgt1=cost1/sint1
17447                 cosg_inv=1.0d0/cosg
17448                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17449                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17450                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17451                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17452                 dsinphi(j,2,i)= &
17453                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17454                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17455                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17456                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17457                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17458       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17459                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17460                 endif
17461       ! Bug fixed 3/24/05 (AL)
17462              enddo
17463       !   Obtaining the gamma derivatives from cosine derivative
17464             else
17465                do j=1,3
17466                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17467                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17468                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17469                dc_norm(j,i-3))/vbld(i-2)
17470                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17471                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17472                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17473                dcostheta(j,1,i)
17474                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17475                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17476                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17477                dc_norm(j,i-1))/vbld(i)
17478                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17479 !#define DEBUG
17480 #ifdef DEBUG
17481                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17482 #endif
17483 !#undef DEBUG
17484                endif
17485              enddo
17486             endif
17487             enddo
17488       !alculate derivative of Tauangle
17489 #ifdef PARINTDER
17490             do i=itau_start,itau_end
17491 #else
17492             do i=3,nres
17493       !elwrite(iout,*) " vecpr",i,nres
17494 #endif
17495              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17496       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17497       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17498       !c dtauangle(j,intertyp,dervityp,residue number)
17499       !c INTERTYP=1 SC...Ca...Ca..Ca
17500       ! the conventional case
17501             sint=dsin(theta(i))
17502             sint1=dsin(omicron(2,i-1))
17503             sing=dsin(tauangle(1,i))
17504             cost=dcos(theta(i))
17505             cost1=dcos(omicron(2,i-1))
17506             cosg=dcos(tauangle(1,i))
17507       !elwrite(iout,*) " vecpr5",i,nres
17508             do j=1,3
17509       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17510       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17511             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17512       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17513             enddo
17514             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17515             fac0=1.0d0/(sint1*sint)
17516             fac1=cost*fac0
17517             fac2=cost1*fac0
17518             fac3=cosg*cost1/(sint1*sint1)
17519             fac4=cosg*cost/(sint*sint)
17520       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17521       !    Obtaining the gamma derivatives from sine derivative
17522              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17523                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17524                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17525              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17526              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17527              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17528             do j=1,3
17529                 ctgt=cost/sint
17530                 ctgt1=cost1/sint1
17531                 cosg_inv=1.0d0/cosg
17532                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17533              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17534              *vbld_inv(i-2+nres)
17535                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17536                 dsintau(j,1,2,i)= &
17537                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17538                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17539       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17540                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17541       ! Bug fixed 3/24/05 (AL)
17542                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17543                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17544       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17545                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17546              enddo
17547       !   Obtaining the gamma derivatives from cosine derivative
17548             else
17549                do j=1,3
17550                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17551                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17552                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17553                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17554                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17555                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17556                dcostheta(j,1,i)
17557                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17558                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17559                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17560                dc_norm(j,i-1))/vbld(i)
17561                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17562       !         write (iout,*) "else",i
17563              enddo
17564             endif
17565       !        do k=1,3
17566       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17567       !        enddo
17568             enddo
17569       !C Second case Ca...Ca...Ca...SC
17570 #ifdef PARINTDER
17571             do i=itau_start,itau_end
17572 #else
17573             do i=4,nres
17574 #endif
17575              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17576               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17577       ! the conventional case
17578             sint=dsin(omicron(1,i))
17579             sint1=dsin(theta(i-1))
17580             sing=dsin(tauangle(2,i))
17581             cost=dcos(omicron(1,i))
17582             cost1=dcos(theta(i-1))
17583             cosg=dcos(tauangle(2,i))
17584       !        do j=1,3
17585       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17586       !        enddo
17587             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17588             fac0=1.0d0/(sint1*sint)
17589             fac1=cost*fac0
17590             fac2=cost1*fac0
17591             fac3=cosg*cost1/(sint1*sint1)
17592             fac4=cosg*cost/(sint*sint)
17593       !    Obtaining the gamma derivatives from sine derivative
17594              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17595                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17596                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17597              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17598              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17599              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17600             do j=1,3
17601                 ctgt=cost/sint
17602                 ctgt1=cost1/sint1
17603                 cosg_inv=1.0d0/cosg
17604                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17605                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17606       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17607       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17608                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17609                 dsintau(j,2,2,i)= &
17610                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17611                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17612       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17613       !     & sing*ctgt*domicron(j,1,2,i),
17614       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17615                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17616       ! Bug fixed 3/24/05 (AL)
17617                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17618                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17619       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17620                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17621              enddo
17622       !   Obtaining the gamma derivatives from cosine derivative
17623             else
17624                do j=1,3
17625                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17626                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17627                dc_norm(j,i-3))/vbld(i-2)
17628                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17629                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17630                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17631                dcosomicron(j,1,1,i)
17632                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17633                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17634                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17635                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17636                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17637       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17638              enddo
17639             endif
17640             enddo
17641
17642       !CC third case SC...Ca...Ca...SC
17643 #ifdef PARINTDER
17644
17645             do i=itau_start,itau_end
17646 #else
17647             do i=3,nres
17648 #endif
17649       ! the conventional case
17650             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17651             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17652             sint=dsin(omicron(1,i))
17653             sint1=dsin(omicron(2,i-1))
17654             sing=dsin(tauangle(3,i))
17655             cost=dcos(omicron(1,i))
17656             cost1=dcos(omicron(2,i-1))
17657             cosg=dcos(tauangle(3,i))
17658             do j=1,3
17659             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17660       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17661             enddo
17662             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17663             fac0=1.0d0/(sint1*sint)
17664             fac1=cost*fac0
17665             fac2=cost1*fac0
17666             fac3=cosg*cost1/(sint1*sint1)
17667             fac4=cosg*cost/(sint*sint)
17668       !    Obtaining the gamma derivatives from sine derivative
17669              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17670                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17671                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17672              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17673              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17674              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17675             do j=1,3
17676                 ctgt=cost/sint
17677                 ctgt1=cost1/sint1
17678                 cosg_inv=1.0d0/cosg
17679                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17680                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17681                   *vbld_inv(i-2+nres)
17682                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17683                 dsintau(j,3,2,i)= &
17684                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17685                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17686                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17687       ! Bug fixed 3/24/05 (AL)
17688                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17689                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17690                   *vbld_inv(i-1+nres)
17691       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17692                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17693              enddo
17694       !   Obtaining the gamma derivatives from cosine derivative
17695             else
17696                do j=1,3
17697                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17698                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17699                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17700                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17701                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17702                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17703                dcosomicron(j,1,1,i)
17704                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17705                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17706                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17707                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17708                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17709       !          write(iout,*) "else",i
17710              enddo
17711             endif
17712             enddo
17713
17714 #ifdef CRYST_SC
17715       !   Derivatives of side-chain angles alpha and omega
17716 #if defined(MPI) && defined(PARINTDER)
17717             do i=ibond_start,ibond_end
17718 #else
17719             do i=2,nres-1
17720 #endif
17721               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17722                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17723                  fac6=fac5/vbld(i)
17724                  fac7=fac5*fac5
17725                  fac8=fac5/vbld(i+1)
17726                  fac9=fac5/vbld(i+nres)
17727                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17728                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17729                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17730                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17731                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17732                  sina=sqrt(1-cosa*cosa)
17733                  sino=dsin(omeg(i))
17734       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17735                  do j=1,3
17736                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17737                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17738                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17739                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17740                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17741                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17742                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17743                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17744                   vbld(i+nres))
17745                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17746                 enddo
17747       ! obtaining the derivatives of omega from sines
17748                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17749                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17750                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17751                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17752                    dsin(theta(i+1)))
17753                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17754                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17755                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17756                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17757                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17758                    coso_inv=1.0d0/dcos(omeg(i))
17759                    do j=1,3
17760                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17761                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17762                    (sino*dc_norm(j,i-1))/vbld(i)
17763                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17764                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17765                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17766                    -sino*dc_norm(j,i)/vbld(i+1)
17767                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17768                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17769                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17770                    vbld(i+nres)
17771                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17772                   enddo
17773                else
17774       !   obtaining the derivatives of omega from cosines
17775                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17776                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17777                  fac12=fac10*sina
17778                  fac13=fac12*fac12
17779                  fac14=sina*sina
17780                  do j=1,3
17781                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17782                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17783                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17784                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17785                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17786                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17787                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17788                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17789                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17790                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17791                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17792                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17793                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17794                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17795                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17796                 enddo
17797               endif
17798              else
17799                do j=1,3
17800                  do k=1,3
17801                    dalpha(k,j,i)=0.0d0
17802                    domega(k,j,i)=0.0d0
17803                  enddo
17804                enddo
17805              endif
17806              enddo
17807 #endif
17808 #if defined(MPI) && defined(PARINTDER)
17809             if (nfgtasks.gt.1) then
17810 #ifdef DEBUG
17811       !d      write (iout,*) "Gather dtheta"
17812       !d      call flush(iout)
17813             write (iout,*) "dtheta before gather"
17814             do i=1,nres
17815             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17816             enddo
17817 #endif
17818             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17819             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17820             king,FG_COMM,IERROR)
17821 !#define DEBUG
17822 #ifdef DEBUG
17823       !d      write (iout,*) "Gather dphi"
17824       !d      call flush(iout)
17825             write (iout,*) "dphi before gather"
17826             do i=1,nres
17827             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17828             enddo
17829 #endif
17830 !#undef DEBUG
17831             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17832             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17833             king,FG_COMM,IERROR)
17834       !d      write (iout,*) "Gather dalpha"
17835       !d      call flush(iout)
17836 #ifdef CRYST_SC
17837             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17838             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17839             king,FG_COMM,IERROR)
17840       !d      write (iout,*) "Gather domega"
17841       !d      call flush(iout)
17842             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17843             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17844             king,FG_COMM,IERROR)
17845 #endif
17846             endif
17847 #endif
17848 !#define DEBUG
17849 #ifdef DEBUG
17850             write (iout,*) "dtheta after gather"
17851             do i=1,nres
17852             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17853             enddo
17854             write (iout,*) "dphi after gather"
17855             do i=1,nres
17856             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17857             enddo
17858             write (iout,*) "dalpha after gather"
17859             do i=1,nres
17860             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17861             enddo
17862             write (iout,*) "domega after gather"
17863             do i=1,nres
17864             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17865             enddo
17866 #endif
17867 !#undef DEBUG
17868             return
17869             end subroutine intcartderiv
17870       !-----------------------------------------------------------------------------
17871             subroutine checkintcartgrad
17872       !      implicit real*8 (a-h,o-z)
17873       !      include 'DIMENSIONS'
17874 #ifdef MPI
17875             include 'mpif.h'
17876 #endif
17877       !      include 'COMMON.CHAIN'
17878       !      include 'COMMON.VAR'
17879       !      include 'COMMON.GEO'
17880       !      include 'COMMON.INTERACT'
17881       !      include 'COMMON.DERIV'
17882       !      include 'COMMON.IOUNITS'
17883       !      include 'COMMON.SETUP'
17884             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17885             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17886             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17887             real(kind=8),dimension(3) :: dc_norm_s
17888             real(kind=8) :: aincr=1.0d-5
17889             integer :: i,j
17890             real(kind=8) :: dcji
17891             do i=1,nres
17892             phi_s(i)=phi(i)
17893             theta_s(i)=theta(i)
17894             alph_s(i)=alph(i)
17895             omeg_s(i)=omeg(i)
17896             enddo
17897       ! Check theta gradient
17898             write (iout,*) &
17899              "Analytical (upper) and numerical (lower) gradient of theta"
17900             write (iout,*)
17901             do i=3,nres
17902             do j=1,3
17903               dcji=dc(j,i-2)
17904               dc(j,i-2)=dcji+aincr
17905               call chainbuild_cart
17906               call int_from_cart1(.false.)
17907           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17908           dc(j,i-2)=dcji
17909           dcji=dc(j,i-1)
17910           dc(j,i-1)=dc(j,i-1)+aincr
17911           call chainbuild_cart
17912           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17913           dc(j,i-1)=dcji
17914         enddo
17915 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17916 !el          (dtheta(j,2,i),j=1,3)
17917 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17918 !el          (dthetanum(j,2,i),j=1,3)
17919 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17920 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17921 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17922 !el        write (iout,*)
17923       enddo
17924 ! Check gamma gradient
17925       write (iout,*) &
17926        "Analytical (upper) and numerical (lower) gradient of gamma"
17927       do i=4,nres
17928         do j=1,3
17929           dcji=dc(j,i-3)
17930           dc(j,i-3)=dcji+aincr
17931           call chainbuild_cart
17932           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17933               dc(j,i-3)=dcji
17934           dcji=dc(j,i-2)
17935           dc(j,i-2)=dcji+aincr
17936           call chainbuild_cart
17937           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17938           dc(j,i-2)=dcji
17939           dcji=dc(j,i-1)
17940           dc(j,i-1)=dc(j,i-1)+aincr
17941           call chainbuild_cart
17942           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17943           dc(j,i-1)=dcji
17944         enddo
17945 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17946 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17947 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17948 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17949 !el        write (iout,'(5x,3(3f10.5,5x))') &
17950 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17951 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17952 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17953 !el        write (iout,*)
17954       enddo
17955 ! Check alpha gradient
17956       write (iout,*) &
17957        "Analytical (upper) and numerical (lower) gradient of alpha"
17958       do i=2,nres-1
17959        if(itype(i,1).ne.10) then
17960                  do j=1,3
17961                   dcji=dc(j,i-1)
17962                    dc(j,i-1)=dcji+aincr
17963               call chainbuild_cart
17964               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17965                  /aincr
17966                   dc(j,i-1)=dcji
17967               dcji=dc(j,i)
17968               dc(j,i)=dcji+aincr
17969               call chainbuild_cart
17970               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17971                  /aincr
17972               dc(j,i)=dcji
17973               dcji=dc(j,i+nres)
17974               dc(j,i+nres)=dc(j,i+nres)+aincr
17975               call chainbuild_cart
17976               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17977                  /aincr
17978              dc(j,i+nres)=dcji
17979             enddo
17980           endif
17981 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17982 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17983 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17984 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17985 !el        write (iout,'(5x,3(3f10.5,5x))') &
17986 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17987 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17988 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17989 !el        write (iout,*)
17990       enddo
17991 !     Check omega gradient
17992       write (iout,*) &
17993        "Analytical (upper) and numerical (lower) gradient of omega"
17994       do i=2,nres-1
17995        if(itype(i,1).ne.10) then
17996                  do j=1,3
17997                   dcji=dc(j,i-1)
17998                    dc(j,i-1)=dcji+aincr
17999               call chainbuild_cart
18000               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18001                  /aincr
18002                   dc(j,i-1)=dcji
18003               dcji=dc(j,i)
18004               dc(j,i)=dcji+aincr
18005               call chainbuild_cart
18006               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18007                  /aincr
18008               dc(j,i)=dcji
18009               dcji=dc(j,i+nres)
18010               dc(j,i+nres)=dc(j,i+nres)+aincr
18011               call chainbuild_cart
18012               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18013                  /aincr
18014              dc(j,i+nres)=dcji
18015             enddo
18016           endif
18017 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18018 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18019 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18020 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18021 !el        write (iout,'(5x,3(3f10.5,5x))') &
18022 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18023 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18024 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18025 !el        write (iout,*)
18026       enddo
18027       return
18028       end subroutine checkintcartgrad
18029 !-----------------------------------------------------------------------------
18030 ! q_measure.F
18031 !-----------------------------------------------------------------------------
18032       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18033 !      implicit real*8 (a-h,o-z)
18034 !      include 'DIMENSIONS'
18035 !      include 'COMMON.IOUNITS'
18036 !      include 'COMMON.CHAIN'
18037 !      include 'COMMON.INTERACT'
18038 !      include 'COMMON.VAR'
18039       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18040       integer :: kkk,nsep=3
18041       real(kind=8) :: qm      !dist,
18042       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18043       logical :: lprn=.false.
18044       logical :: flag
18045 !      real(kind=8) :: sigm,x
18046
18047 !el      sigm(x)=0.25d0*x     ! local function
18048       qqmax=1.0d10
18049       do kkk=1,nperm
18050       qq = 0.0d0
18051       nl=0
18052        if(flag) then
18053         do il=seg1+nsep,seg2
18054           do jl=seg1,il-nsep
18055             nl=nl+1
18056             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18057                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18058                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18059             dij=dist(il,jl)
18060             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18061             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18062               nl=nl+1
18063               d0ijCM=dsqrt( &
18064                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18065                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18066                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18067               dijCM=dist(il+nres,jl+nres)
18068               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18069             endif
18070             qq = qq+qqij+qqijCM
18071           enddo
18072         enddo
18073         qq = qq/nl
18074       else
18075       do il=seg1,seg2
18076         if((seg3-il).lt.3) then
18077              secseg=il+3
18078         else
18079              secseg=seg3
18080         endif
18081           do jl=secseg,seg4
18082             nl=nl+1
18083             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18084                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18085                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18086             dij=dist(il,jl)
18087             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18088             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18089               nl=nl+1
18090               d0ijCM=dsqrt( &
18091                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18092                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18093                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18094               dijCM=dist(il+nres,jl+nres)
18095               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18096             endif
18097             qq = qq+qqij+qqijCM
18098           enddo
18099         enddo
18100       qq = qq/nl
18101       endif
18102       if (qqmax.le.qq) qqmax=qq
18103       enddo
18104       qwolynes=1.0d0-qqmax
18105       return
18106       end function qwolynes
18107 !-----------------------------------------------------------------------------
18108       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18109 !      implicit real*8 (a-h,o-z)
18110 !      include 'DIMENSIONS'
18111 !      include 'COMMON.IOUNITS'
18112 !      include 'COMMON.CHAIN'
18113 !      include 'COMMON.INTERACT'
18114 !      include 'COMMON.VAR'
18115 !      include 'COMMON.MD'
18116       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18117       integer :: nsep=3, kkk
18118 !el      real(kind=8) :: dist
18119       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18120       logical :: lprn=.false.
18121       logical :: flag
18122       real(kind=8) :: sim,dd0,fac,ddqij
18123 !el      sigm(x)=0.25d0*x           ! local function
18124       do kkk=1,nperm
18125       do i=0,nres
18126         do j=1,3
18127           dqwol(j,i)=0.0d0
18128           dxqwol(j,i)=0.0d0
18129         enddo
18130       enddo
18131       nl=0
18132        if(flag) then
18133         do il=seg1+nsep,seg2
18134           do jl=seg1,il-nsep
18135             nl=nl+1
18136             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18137                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18138                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18139             dij=dist(il,jl)
18140             sim = 1.0d0/sigm(d0ij)
18141             sim = sim*sim
18142             dd0 = dij-d0ij
18143             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18144           do k=1,3
18145               ddqij = (c(k,il)-c(k,jl))*fac
18146               dqwol(k,il)=dqwol(k,il)+ddqij
18147               dqwol(k,jl)=dqwol(k,jl)-ddqij
18148             enddo
18149
18150             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18151               nl=nl+1
18152               d0ijCM=dsqrt( &
18153                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18154                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18155                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18156               dijCM=dist(il+nres,jl+nres)
18157               sim = 1.0d0/sigm(d0ijCM)
18158               sim = sim*sim
18159               dd0=dijCM-d0ijCM
18160               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18161               do k=1,3
18162                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18163                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18164                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18165               enddo
18166             endif
18167           enddo
18168         enddo
18169        else
18170         do il=seg1,seg2
18171         if((seg3-il).lt.3) then
18172              secseg=il+3
18173         else
18174              secseg=seg3
18175         endif
18176           do jl=secseg,seg4
18177             nl=nl+1
18178             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18179                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18180                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18181             dij=dist(il,jl)
18182             sim = 1.0d0/sigm(d0ij)
18183             sim = sim*sim
18184             dd0 = dij-d0ij
18185             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18186             do k=1,3
18187               ddqij = (c(k,il)-c(k,jl))*fac
18188               dqwol(k,il)=dqwol(k,il)+ddqij
18189               dqwol(k,jl)=dqwol(k,jl)-ddqij
18190             enddo
18191             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18192               nl=nl+1
18193               d0ijCM=dsqrt( &
18194                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18195                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18196                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18197               dijCM=dist(il+nres,jl+nres)
18198               sim = 1.0d0/sigm(d0ijCM)
18199               sim=sim*sim
18200               dd0 = dijCM-d0ijCM
18201               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18202               do k=1,3
18203                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18204                dxqwol(k,il)=dxqwol(k,il)+ddqij
18205                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18206               enddo
18207             endif
18208           enddo
18209         enddo
18210       endif
18211       enddo
18212        do i=0,nres
18213          do j=1,3
18214            dqwol(j,i)=dqwol(j,i)/nl
18215            dxqwol(j,i)=dxqwol(j,i)/nl
18216          enddo
18217        enddo
18218       return
18219       end subroutine qwolynes_prim
18220 !-----------------------------------------------------------------------------
18221       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18222 !      implicit real*8 (a-h,o-z)
18223 !      include 'DIMENSIONS'
18224 !      include 'COMMON.IOUNITS'
18225 !      include 'COMMON.CHAIN'
18226 !      include 'COMMON.INTERACT'
18227 !      include 'COMMON.VAR'
18228       integer :: seg1,seg2,seg3,seg4
18229       logical :: flag
18230       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18231       real(kind=8),dimension(3,0:2*nres) :: cdummy
18232       real(kind=8) :: q1,q2
18233       real(kind=8) :: delta=1.0d-10
18234       integer :: i,j
18235
18236       do i=0,nres
18237         do j=1,3
18238           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18239           cdummy(j,i)=c(j,i)
18240           c(j,i)=c(j,i)+delta
18241           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18242           qwolan(j,i)=(q2-q1)/delta
18243           c(j,i)=cdummy(j,i)
18244         enddo
18245       enddo
18246       do i=0,nres
18247         do j=1,3
18248           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18249           cdummy(j,i+nres)=c(j,i+nres)
18250           c(j,i+nres)=c(j,i+nres)+delta
18251           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18252           qwolxan(j,i)=(q2-q1)/delta
18253           c(j,i+nres)=cdummy(j,i+nres)
18254         enddo
18255       enddo
18256 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18257 !      do i=0,nct
18258 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18259 !      enddo
18260 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18261 !      do i=0,nct
18262 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18263 !      enddo
18264       return
18265       end subroutine qwol_num
18266 !-----------------------------------------------------------------------------
18267       subroutine EconstrQ
18268 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18269 !      implicit real*8 (a-h,o-z)
18270 !      include 'DIMENSIONS'
18271 !      include 'COMMON.CONTROL'
18272 !      include 'COMMON.VAR'
18273 !      include 'COMMON.MD'
18274       use MD_data
18275 !#ifndef LANG0
18276 !      include 'COMMON.LANGEVIN'
18277 !#else
18278 !      include 'COMMON.LANGEVIN.lang0'
18279 !#endif
18280 !      include 'COMMON.CHAIN'
18281 !      include 'COMMON.DERIV'
18282 !      include 'COMMON.GEO'
18283 !      include 'COMMON.LOCAL'
18284 !      include 'COMMON.INTERACT'
18285 !      include 'COMMON.IOUNITS'
18286 !      include 'COMMON.NAMES'
18287 !      include 'COMMON.TIME1'
18288       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18289       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18290                    duconst,duxconst
18291       integer :: kstart,kend,lstart,lend,idummy
18292       real(kind=8) :: delta=1.0d-7
18293       integer :: i,j,k,ii
18294       do i=0,nres
18295          do j=1,3
18296             duconst(j,i)=0.0d0
18297             dudconst(j,i)=0.0d0
18298             duxconst(j,i)=0.0d0
18299             dudxconst(j,i)=0.0d0
18300          enddo
18301       enddo
18302       Uconst=0.0d0
18303       do i=1,nfrag
18304          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18305            idummy,idummy)
18306          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18307 ! Calculating the derivatives of Constraint energy with respect to Q
18308          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18309            qinfrag(i,iset))
18310 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18311 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18312 !         hmnum=(hm2-hm1)/delta
18313 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18314 !     &   qinfrag(i,iset))
18315 !         write(iout,*) "harmonicnum frag", hmnum
18316 ! Calculating the derivatives of Q with respect to cartesian coordinates
18317          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18318           idummy,idummy)
18319 !         write(iout,*) "dqwol "
18320 !         do ii=1,nres
18321 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18322 !         enddo
18323 !         write(iout,*) "dxqwol "
18324 !         do ii=1,nres
18325 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18326 !         enddo
18327 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18328 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18329 !     &  ,idummy,idummy)
18330 !  The gradients of Uconst in Cs
18331          do ii=0,nres
18332             do j=1,3
18333                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18334                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18335             enddo
18336          enddo
18337       enddo
18338       do i=1,npair
18339          kstart=ifrag(1,ipair(1,i,iset),iset)
18340          kend=ifrag(2,ipair(1,i,iset),iset)
18341          lstart=ifrag(1,ipair(2,i,iset),iset)
18342          lend=ifrag(2,ipair(2,i,iset),iset)
18343          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18344          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18345 !  Calculating dU/dQ
18346          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18347 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18348 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18349 !         hmnum=(hm2-hm1)/delta
18350 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18351 !     &   qinpair(i,iset))
18352 !         write(iout,*) "harmonicnum pair ", hmnum
18353 ! Calculating dQ/dXi
18354          call qwolynes_prim(kstart,kend,.false.,&
18355           lstart,lend)
18356 !         write(iout,*) "dqwol "
18357 !         do ii=1,nres
18358 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18359 !         enddo
18360 !         write(iout,*) "dxqwol "
18361 !         do ii=1,nres
18362 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18363 !        enddo
18364 ! Calculating numerical gradients
18365 !        call qwol_num(kstart,kend,.false.
18366 !     &  ,lstart,lend)
18367 ! The gradients of Uconst in Cs
18368          do ii=0,nres
18369             do j=1,3
18370                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18371                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18372             enddo
18373          enddo
18374       enddo
18375 !      write(iout,*) "Uconst inside subroutine ", Uconst
18376 ! Transforming the gradients from Cs to dCs for the backbone
18377       do i=0,nres
18378          do j=i+1,nres
18379            do k=1,3
18380              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18381            enddo
18382          enddo
18383       enddo
18384 !  Transforming the gradients from Cs to dCs for the side chains
18385       do i=1,nres
18386          do j=1,3
18387            dudxconst(j,i)=duxconst(j,i)
18388          enddo
18389       enddo
18390 !      write(iout,*) "dU/ddc backbone "
18391 !       do ii=0,nres
18392 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18393 !      enddo
18394 !      write(iout,*) "dU/ddX side chain "
18395 !      do ii=1,nres
18396 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18397 !      enddo
18398 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18399 !      call dEconstrQ_num
18400       return
18401       end subroutine EconstrQ
18402 !-----------------------------------------------------------------------------
18403       subroutine dEconstrQ_num
18404 ! Calculating numerical dUconst/ddc and dUconst/ddx
18405 !      implicit real*8 (a-h,o-z)
18406 !      include 'DIMENSIONS'
18407 !      include 'COMMON.CONTROL'
18408 !      include 'COMMON.VAR'
18409 !      include 'COMMON.MD'
18410       use MD_data
18411 !#ifndef LANG0
18412 !      include 'COMMON.LANGEVIN'
18413 !#else
18414 !      include 'COMMON.LANGEVIN.lang0'
18415 !#endif
18416 !      include 'COMMON.CHAIN'
18417 !      include 'COMMON.DERIV'
18418 !      include 'COMMON.GEO'
18419 !      include 'COMMON.LOCAL'
18420 !      include 'COMMON.INTERACT'
18421 !      include 'COMMON.IOUNITS'
18422 !      include 'COMMON.NAMES'
18423 !      include 'COMMON.TIME1'
18424       real(kind=8) :: uzap1,uzap2
18425       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18426       integer :: kstart,kend,lstart,lend,idummy
18427       real(kind=8) :: delta=1.0d-7
18428 !el local variables
18429       integer :: i,ii,j
18430 !     real(kind=8) ::
18431 !     For the backbone
18432       do i=0,nres-1
18433          do j=1,3
18434             dUcartan(j,i)=0.0d0
18435             cdummy(j,i)=dc(j,i)
18436             dc(j,i)=dc(j,i)+delta
18437             call chainbuild_cart
18438           uzap2=0.0d0
18439             do ii=1,nfrag
18440              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18441                 idummy,idummy)
18442                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18443                 qinfrag(ii,iset))
18444             enddo
18445             do ii=1,npair
18446                kstart=ifrag(1,ipair(1,ii,iset),iset)
18447                kend=ifrag(2,ipair(1,ii,iset),iset)
18448                lstart=ifrag(1,ipair(2,ii,iset),iset)
18449                lend=ifrag(2,ipair(2,ii,iset),iset)
18450                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18451                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18452                  qinpair(ii,iset))
18453             enddo
18454             dc(j,i)=cdummy(j,i)
18455             call chainbuild_cart
18456             uzap1=0.0d0
18457              do ii=1,nfrag
18458              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18459                 idummy,idummy)
18460                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18461                 qinfrag(ii,iset))
18462             enddo
18463             do ii=1,npair
18464                kstart=ifrag(1,ipair(1,ii,iset),iset)
18465                kend=ifrag(2,ipair(1,ii,iset),iset)
18466                lstart=ifrag(1,ipair(2,ii,iset),iset)
18467                lend=ifrag(2,ipair(2,ii,iset),iset)
18468                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18469                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18470                 qinpair(ii,iset))
18471             enddo
18472             ducartan(j,i)=(uzap2-uzap1)/(delta)
18473          enddo
18474       enddo
18475 ! Calculating numerical gradients for dU/ddx
18476       do i=0,nres-1
18477          duxcartan(j,i)=0.0d0
18478          do j=1,3
18479             cdummy(j,i)=dc(j,i+nres)
18480             dc(j,i+nres)=dc(j,i+nres)+delta
18481             call chainbuild_cart
18482           uzap2=0.0d0
18483             do ii=1,nfrag
18484              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18485                 idummy,idummy)
18486                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18487                 qinfrag(ii,iset))
18488             enddo
18489             do ii=1,npair
18490                kstart=ifrag(1,ipair(1,ii,iset),iset)
18491                kend=ifrag(2,ipair(1,ii,iset),iset)
18492                lstart=ifrag(1,ipair(2,ii,iset),iset)
18493                lend=ifrag(2,ipair(2,ii,iset),iset)
18494                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18495                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18496                 qinpair(ii,iset))
18497             enddo
18498             dc(j,i+nres)=cdummy(j,i)
18499             call chainbuild_cart
18500             uzap1=0.0d0
18501              do ii=1,nfrag
18502                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18503                 ifrag(2,ii,iset),.true.,idummy,idummy)
18504                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18505                 qinfrag(ii,iset))
18506             enddo
18507             do ii=1,npair
18508                kstart=ifrag(1,ipair(1,ii,iset),iset)
18509                kend=ifrag(2,ipair(1,ii,iset),iset)
18510                lstart=ifrag(1,ipair(2,ii,iset),iset)
18511                lend=ifrag(2,ipair(2,ii,iset),iset)
18512                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18513                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18514                 qinpair(ii,iset))
18515             enddo
18516             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18517          enddo
18518       enddo
18519       write(iout,*) "Numerical dUconst/ddc backbone "
18520       do ii=0,nres
18521         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18522       enddo
18523 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18524 !      do ii=1,nres
18525 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18526 !      enddo
18527       return
18528       end subroutine dEconstrQ_num
18529 !-----------------------------------------------------------------------------
18530 ! ssMD.F
18531 !-----------------------------------------------------------------------------
18532       subroutine check_energies
18533
18534 !      use random, only: ran_number
18535
18536 !      implicit none
18537 !     Includes
18538 !      include 'DIMENSIONS'
18539 !      include 'COMMON.CHAIN'
18540 !      include 'COMMON.VAR'
18541 !      include 'COMMON.IOUNITS'
18542 !      include 'COMMON.SBRIDGE'
18543 !      include 'COMMON.LOCAL'
18544 !      include 'COMMON.GEO'
18545
18546 !     External functions
18547 !EL      double precision ran_number
18548 !EL      external ran_number
18549
18550 !     Local variables
18551       integer :: i,j,k,l,lmax,p,pmax
18552       real(kind=8) :: rmin,rmax
18553       real(kind=8) :: eij
18554
18555       real(kind=8) :: d
18556       real(kind=8) :: wi,rij,tj,pj
18557 !      return
18558
18559       i=5
18560       j=14
18561
18562       d=dsc(1)
18563       rmin=2.0D0
18564       rmax=12.0D0
18565
18566       lmax=10000
18567       pmax=1
18568
18569       do k=1,3
18570         c(k,i)=0.0D0
18571         c(k,j)=0.0D0
18572         c(k,nres+i)=0.0D0
18573         c(k,nres+j)=0.0D0
18574       enddo
18575
18576       do l=1,lmax
18577
18578 !t        wi=ran_number(0.0D0,pi)
18579 !        wi=ran_number(0.0D0,pi/6.0D0)
18580 !        wi=0.0D0
18581 !t        tj=ran_number(0.0D0,pi)
18582 !t        pj=ran_number(0.0D0,pi)
18583 !        pj=ran_number(0.0D0,pi/6.0D0)
18584 !        pj=0.0D0
18585
18586         do p=1,pmax
18587 !t           rij=ran_number(rmin,rmax)
18588
18589            c(1,j)=d*sin(pj)*cos(tj)
18590            c(2,j)=d*sin(pj)*sin(tj)
18591            c(3,j)=d*cos(pj)
18592
18593            c(3,nres+i)=-rij
18594
18595            c(1,i)=d*sin(wi)
18596            c(3,i)=-rij-d*cos(wi)
18597
18598            do k=1,3
18599               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18600               dc_norm(k,nres+i)=dc(k,nres+i)/d
18601               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18602               dc_norm(k,nres+j)=dc(k,nres+j)/d
18603            enddo
18604
18605            call dyn_ssbond_ene(i,j,eij)
18606         enddo
18607       enddo
18608       call exit(1)
18609       return
18610       end subroutine check_energies
18611 !-----------------------------------------------------------------------------
18612       subroutine dyn_ssbond_ene(resi,resj,eij)
18613 !      implicit none
18614 !      Includes
18615       use calc_data
18616       use comm_sschecks
18617 !      include 'DIMENSIONS'
18618 !      include 'COMMON.SBRIDGE'
18619 !      include 'COMMON.CHAIN'
18620 !      include 'COMMON.DERIV'
18621 !      include 'COMMON.LOCAL'
18622 !      include 'COMMON.INTERACT'
18623 !      include 'COMMON.VAR'
18624 !      include 'COMMON.IOUNITS'
18625 !      include 'COMMON.CALC'
18626 #ifndef CLUST
18627 #ifndef WHAM
18628        use MD_data
18629 !      include 'COMMON.MD'
18630 !      use MD, only: totT,t_bath
18631 #endif
18632 #endif
18633 !     External functions
18634 !EL      double precision h_base
18635 !EL      external h_base
18636
18637 !     Input arguments
18638       integer :: resi,resj
18639
18640 !     Output arguments
18641       real(kind=8) :: eij
18642
18643 !     Local variables
18644       logical :: havebond
18645       integer itypi,itypj
18646       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18647       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18648       real(kind=8),dimension(3) :: dcosom1,dcosom2
18649       real(kind=8) :: ed
18650       real(kind=8) :: pom1,pom2
18651       real(kind=8) :: ljA,ljB,ljXs
18652       real(kind=8),dimension(1:3) :: d_ljB
18653       real(kind=8) :: ssA,ssB,ssC,ssXs
18654       real(kind=8) :: ssxm,ljxm,ssm,ljm
18655       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18656       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18657       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18658 !-------FIRST METHOD
18659       real(kind=8) :: xm
18660       real(kind=8),dimension(1:3) :: d_xm
18661 !-------END FIRST METHOD
18662 !-------SECOND METHOD
18663 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18664 !-------END SECOND METHOD
18665
18666 !-------TESTING CODE
18667 !el      logical :: checkstop,transgrad
18668 !el      common /sschecks/ checkstop,transgrad
18669
18670       integer :: icheck,nicheck,jcheck,njcheck
18671       real(kind=8),dimension(-1:1) :: echeck
18672       real(kind=8) :: deps,ssx0,ljx0
18673 !-------END TESTING CODE
18674
18675       eij=0.0d0
18676       i=resi
18677       j=resj
18678
18679 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18680 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18681
18682       itypi=itype(i,1)
18683       dxi=dc_norm(1,nres+i)
18684       dyi=dc_norm(2,nres+i)
18685       dzi=dc_norm(3,nres+i)
18686       dsci_inv=vbld_inv(i+nres)
18687
18688       itypj=itype(j,1)
18689       xj=c(1,nres+j)-c(1,nres+i)
18690       yj=c(2,nres+j)-c(2,nres+i)
18691       zj=c(3,nres+j)-c(3,nres+i)
18692       dxj=dc_norm(1,nres+j)
18693       dyj=dc_norm(2,nres+j)
18694       dzj=dc_norm(3,nres+j)
18695       dscj_inv=vbld_inv(j+nres)
18696
18697       chi1=chi(itypi,itypj)
18698       chi2=chi(itypj,itypi)
18699       chi12=chi1*chi2
18700       chip1=chip(itypi)
18701       chip2=chip(itypj)
18702       chip12=chip1*chip2
18703       alf1=alp(itypi)
18704       alf2=alp(itypj)
18705       alf12=0.5D0*(alf1+alf2)
18706
18707       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18708       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18709 !     The following are set in sc_angular
18710 !      erij(1)=xj*rij
18711 !      erij(2)=yj*rij
18712 !      erij(3)=zj*rij
18713 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18714 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18715 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18716       call sc_angular
18717       rij=1.0D0/rij  ! Reset this so it makes sense
18718
18719       sig0ij=sigma(itypi,itypj)
18720       sig=sig0ij*dsqrt(1.0D0/sigsq)
18721
18722       ljXs=sig-sig0ij
18723       ljA=eps1*eps2rt**2*eps3rt**2
18724       ljB=ljA*bb_aq(itypi,itypj)
18725       ljA=ljA*aa_aq(itypi,itypj)
18726       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18727
18728       ssXs=d0cm
18729       deltat1=1.0d0-om1
18730       deltat2=1.0d0+om2
18731       deltat12=om2-om1+2.0d0
18732       cosphi=om12-om1*om2
18733       ssA=akcm
18734       ssB=akct*deltat12
18735       ssC=ss_depth &
18736            +akth*(deltat1*deltat1+deltat2*deltat2) &
18737            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18738       ssxm=ssXs-0.5D0*ssB/ssA
18739
18740 !-------TESTING CODE
18741 !$$$c     Some extra output
18742 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18743 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18744 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18745 !$$$      if (ssx0.gt.0.0d0) then
18746 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18747 !$$$      else
18748 !$$$        ssx0=ssxm
18749 !$$$      endif
18750 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18751 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18752 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18753 !$$$      return
18754 !-------END TESTING CODE
18755
18756 !-------TESTING CODE
18757 !     Stop and plot energy and derivative as a function of distance
18758       if (checkstop) then
18759         ssm=ssC-0.25D0*ssB*ssB/ssA
18760         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18761         if (ssm.lt.ljm .and. &
18762              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18763           nicheck=1000
18764           njcheck=1
18765           deps=0.5d-7
18766         else
18767           checkstop=.false.
18768         endif
18769       endif
18770       if (.not.checkstop) then
18771         nicheck=0
18772         njcheck=-1
18773       endif
18774
18775       do icheck=0,nicheck
18776       do jcheck=-1,njcheck
18777       if (checkstop) rij=(ssxm-1.0d0)+ &
18778              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18779 !-------END TESTING CODE
18780
18781       if (rij.gt.ljxm) then
18782         havebond=.false.
18783         ljd=rij-ljXs
18784         fac=(1.0D0/ljd)**expon
18785         e1=fac*fac*aa_aq(itypi,itypj)
18786         e2=fac*bb_aq(itypi,itypj)
18787         eij=eps1*eps2rt*eps3rt*(e1+e2)
18788         eps2der=eij*eps3rt
18789         eps3der=eij*eps2rt
18790         eij=eij*eps2rt*eps3rt
18791
18792         sigder=-sig/sigsq
18793         e1=e1*eps1*eps2rt**2*eps3rt**2
18794         ed=-expon*(e1+eij)/ljd
18795         sigder=ed*sigder
18796         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18797         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18798         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18799              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18800       else if (rij.lt.ssxm) then
18801         havebond=.true.
18802         ssd=rij-ssXs
18803         eij=ssA*ssd*ssd+ssB*ssd+ssC
18804
18805         ed=2*akcm*ssd+akct*deltat12
18806         pom1=akct*ssd
18807         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18808         eom1=-2*akth*deltat1-pom1-om2*pom2
18809         eom2= 2*akth*deltat2+pom1-om1*pom2
18810         eom12=pom2
18811       else
18812         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18813
18814         d_ssxm(1)=0.5D0*akct/ssA
18815         d_ssxm(2)=-d_ssxm(1)
18816         d_ssxm(3)=0.0D0
18817
18818         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18819         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18820         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18821         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18822
18823 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18824         xm=0.5d0*(ssxm+ljxm)
18825         do k=1,3
18826           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18827         enddo
18828         if (rij.lt.xm) then
18829           havebond=.true.
18830           ssm=ssC-0.25D0*ssB*ssB/ssA
18831           d_ssm(1)=0.5D0*akct*ssB/ssA
18832           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18833           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18834           d_ssm(3)=omega
18835           f1=(rij-xm)/(ssxm-xm)
18836           f2=(rij-ssxm)/(xm-ssxm)
18837           h1=h_base(f1,hd1)
18838           h2=h_base(f2,hd2)
18839           eij=ssm*h1+Ht*h2
18840           delta_inv=1.0d0/(xm-ssxm)
18841           deltasq_inv=delta_inv*delta_inv
18842           fac=ssm*hd1-Ht*hd2
18843           fac1=deltasq_inv*fac*(xm-rij)
18844           fac2=deltasq_inv*fac*(rij-ssxm)
18845           ed=delta_inv*(Ht*hd2-ssm*hd1)
18846           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18847           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18848           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18849         else
18850           havebond=.false.
18851           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18852           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18853           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18854           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18855                alf12/eps3rt)
18856           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18857           f1=(rij-ljxm)/(xm-ljxm)
18858           f2=(rij-xm)/(ljxm-xm)
18859           h1=h_base(f1,hd1)
18860           h2=h_base(f2,hd2)
18861           eij=Ht*h1+ljm*h2
18862           delta_inv=1.0d0/(ljxm-xm)
18863           deltasq_inv=delta_inv*delta_inv
18864           fac=Ht*hd1-ljm*hd2
18865           fac1=deltasq_inv*fac*(ljxm-rij)
18866           fac2=deltasq_inv*fac*(rij-xm)
18867           ed=delta_inv*(ljm*hd2-Ht*hd1)
18868           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18869           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18870           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18871         endif
18872 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18873
18874 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18875 !$$$        ssd=rij-ssXs
18876 !$$$        ljd=rij-ljXs
18877 !$$$        fac1=rij-ljxm
18878 !$$$        fac2=rij-ssxm
18879 !$$$
18880 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18881 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18882 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18883 !$$$
18884 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18885 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18886 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18887 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18888 !$$$        d_ssm(3)=omega
18889 !$$$
18890 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18891 !$$$        do k=1,3
18892 !$$$          d_ljm(k)=ljm*d_ljB(k)
18893 !$$$        enddo
18894 !$$$        ljm=ljm*ljB
18895 !$$$
18896 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18897 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18898 !$$$        d_ss(2)=akct*ssd
18899 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18900 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18901 !$$$        d_ss(3)=omega
18902 !$$$
18903 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18904 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18905 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18906 !$$$        do k=1,3
18907 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18908 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18909 !$$$        enddo
18910 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18911 !$$$
18912 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18913 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18914 !$$$        h1=h_base(f1,hd1)
18915 !$$$        h2=h_base(f2,hd2)
18916 !$$$        eij=ss*h1+ljf*h2
18917 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18918 !$$$        deltasq_inv=delta_inv*delta_inv
18919 !$$$        fac=ljf*hd2-ss*hd1
18920 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18921 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18922 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18923 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18924 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18925 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18926 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18927 !$$$
18928 !$$$        havebond=.false.
18929 !$$$        if (ed.gt.0.0d0) havebond=.true.
18930 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18931
18932       endif
18933
18934       if (havebond) then
18935 !#ifndef CLUST
18936 !#ifndef WHAM
18937 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18938 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18939 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18940 !        endif
18941 !#endif
18942 !#endif
18943         dyn_ssbond_ij(i,j)=eij
18944       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18945         dyn_ssbond_ij(i,j)=1.0d300
18946 !#ifndef CLUST
18947 !#ifndef WHAM
18948 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18949 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18950 !#endif
18951 !#endif
18952       endif
18953
18954 !-------TESTING CODE
18955 !el      if (checkstop) then
18956         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18957              "CHECKSTOP",rij,eij,ed
18958         echeck(jcheck)=eij
18959 !el      endif
18960       enddo
18961       if (checkstop) then
18962         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18963       endif
18964       enddo
18965       if (checkstop) then
18966         transgrad=.true.
18967         checkstop=.false.
18968       endif
18969 !-------END TESTING CODE
18970
18971       do k=1,3
18972         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18973         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18974       enddo
18975       do k=1,3
18976         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18977       enddo
18978       do k=1,3
18979         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18980              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18981              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18982         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18983              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18984              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18985       enddo
18986 !grad      do k=i,j-1
18987 !grad        do l=1,3
18988 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18989 !grad        enddo
18990 !grad      enddo
18991
18992       do l=1,3
18993         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18994         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18995       enddo
18996
18997       return
18998       end subroutine dyn_ssbond_ene
18999 !--------------------------------------------------------------------------
19000          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19001 !      implicit none
19002 !      Includes
19003       use calc_data
19004       use comm_sschecks
19005 !      include 'DIMENSIONS'
19006 !      include 'COMMON.SBRIDGE'
19007 !      include 'COMMON.CHAIN'
19008 !      include 'COMMON.DERIV'
19009 !      include 'COMMON.LOCAL'
19010 !      include 'COMMON.INTERACT'
19011 !      include 'COMMON.VAR'
19012 !      include 'COMMON.IOUNITS'
19013 !      include 'COMMON.CALC'
19014 #ifndef CLUST
19015 #ifndef WHAM
19016        use MD_data
19017 !      include 'COMMON.MD'
19018 !      use MD, only: totT,t_bath
19019 #endif
19020 #endif
19021       double precision h_base
19022       external h_base
19023
19024 !c     Input arguments
19025       integer resi,resj,resk,m,itypi,itypj,itypk
19026
19027 !c     Output arguments
19028       double precision eij,eij1,eij2,eij3
19029
19030 !c     Local variables
19031       logical havebond
19032 !c      integer itypi,itypj,k,l
19033       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19034       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19035       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19036       double precision sig0ij,ljd,sig,fac,e1,e2
19037       double precision dcosom1(3),dcosom2(3),ed
19038       double precision pom1,pom2
19039       double precision ljA,ljB,ljXs
19040       double precision d_ljB(1:3)
19041       double precision ssA,ssB,ssC,ssXs
19042       double precision ssxm,ljxm,ssm,ljm
19043       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19044       eij=0.0
19045       if (dtriss.eq.0) return
19046       i=resi
19047       j=resj
19048       k=resk
19049 !C      write(iout,*) resi,resj,resk
19050       itypi=itype(i,1)
19051       dxi=dc_norm(1,nres+i)
19052       dyi=dc_norm(2,nres+i)
19053       dzi=dc_norm(3,nres+i)
19054       dsci_inv=vbld_inv(i+nres)
19055       xi=c(1,nres+i)
19056       yi=c(2,nres+i)
19057       zi=c(3,nres+i)
19058       itypj=itype(j,1)
19059       xj=c(1,nres+j)
19060       yj=c(2,nres+j)
19061       zj=c(3,nres+j)
19062
19063       dxj=dc_norm(1,nres+j)
19064       dyj=dc_norm(2,nres+j)
19065       dzj=dc_norm(3,nres+j)
19066       dscj_inv=vbld_inv(j+nres)
19067       itypk=itype(k,1)
19068       xk=c(1,nres+k)
19069       yk=c(2,nres+k)
19070       zk=c(3,nres+k)
19071
19072       dxk=dc_norm(1,nres+k)
19073       dyk=dc_norm(2,nres+k)
19074       dzk=dc_norm(3,nres+k)
19075       dscj_inv=vbld_inv(k+nres)
19076       xij=xj-xi
19077       xik=xk-xi
19078       xjk=xk-xj
19079       yij=yj-yi
19080       yik=yk-yi
19081       yjk=yk-yj
19082       zij=zj-zi
19083       zik=zk-zi
19084       zjk=zk-zj
19085       rrij=(xij*xij+yij*yij+zij*zij)
19086       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19087       rrik=(xik*xik+yik*yik+zik*zik)
19088       rik=dsqrt(rrik)
19089       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19090       rjk=dsqrt(rrjk)
19091 !C there are three combination of distances for each trisulfide bonds
19092 !C The first case the ith atom is the center
19093 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19094 !C distance y is second distance the a,b,c,d are parameters derived for
19095 !C this problem d parameter was set as a penalty currenlty set to 1.
19096       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19097       eij1=0.0d0
19098       else
19099       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19100       endif
19101 !C second case jth atom is center
19102       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19103       eij2=0.0d0
19104       else
19105       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19106       endif
19107 !C the third case kth atom is the center
19108       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19109       eij3=0.0d0
19110       else
19111       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19112       endif
19113 !C      eij2=0.0
19114 !C      eij3=0.0
19115 !C      eij1=0.0
19116       eij=eij1+eij2+eij3
19117 !C      write(iout,*)i,j,k,eij
19118 !C The energy penalty calculated now time for the gradient part
19119 !C derivative over rij
19120       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19121       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19122             gg(1)=xij*fac/rij
19123             gg(2)=yij*fac/rij
19124             gg(3)=zij*fac/rij
19125       do m=1,3
19126         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19127         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19128       enddo
19129
19130       do l=1,3
19131         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19132         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19133       enddo
19134 !C now derivative over rik
19135       fac=-eij1**2/dtriss* &
19136       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19137       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19138             gg(1)=xik*fac/rik
19139             gg(2)=yik*fac/rik
19140             gg(3)=zik*fac/rik
19141       do m=1,3
19142         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19143         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19144       enddo
19145       do l=1,3
19146         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19147         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19148       enddo
19149 !C now derivative over rjk
19150       fac=-eij2**2/dtriss* &
19151       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19152       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19153             gg(1)=xjk*fac/rjk
19154             gg(2)=yjk*fac/rjk
19155             gg(3)=zjk*fac/rjk
19156       do m=1,3
19157         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19158         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19159       enddo
19160       do l=1,3
19161         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19162         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19163       enddo
19164       return
19165       end subroutine triple_ssbond_ene
19166
19167
19168
19169 !-----------------------------------------------------------------------------
19170       real(kind=8) function h_base(x,deriv)
19171 !     A smooth function going 0->1 in range [0,1]
19172 !     It should NOT be called outside range [0,1], it will not work there.
19173       implicit none
19174
19175 !     Input arguments
19176       real(kind=8) :: x
19177
19178 !     Output arguments
19179       real(kind=8) :: deriv
19180
19181 !     Local variables
19182       real(kind=8) :: xsq
19183
19184
19185 !     Two parabolas put together.  First derivative zero at extrema
19186 !$$$      if (x.lt.0.5D0) then
19187 !$$$        h_base=2.0D0*x*x
19188 !$$$        deriv=4.0D0*x
19189 !$$$      else
19190 !$$$        deriv=1.0D0-x
19191 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19192 !$$$        deriv=4.0D0*deriv
19193 !$$$      endif
19194
19195 !     Third degree polynomial.  First derivative zero at extrema
19196       h_base=x*x*(3.0d0-2.0d0*x)
19197       deriv=6.0d0*x*(1.0d0-x)
19198
19199 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19200 !$$$      xsq=x*x
19201 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19202 !$$$      deriv=x-1.0d0
19203 !$$$      deriv=deriv*deriv
19204 !$$$      deriv=30.0d0*xsq*deriv
19205
19206       return
19207       end function h_base
19208 !-----------------------------------------------------------------------------
19209       subroutine dyn_set_nss
19210 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19211 !      implicit none
19212       use MD_data, only: totT,t_bath
19213 !     Includes
19214 !      include 'DIMENSIONS'
19215 #ifdef MPI
19216       include "mpif.h"
19217 #endif
19218 !      include 'COMMON.SBRIDGE'
19219 !      include 'COMMON.CHAIN'
19220 !      include 'COMMON.IOUNITS'
19221 !      include 'COMMON.SETUP'
19222 !      include 'COMMON.MD'
19223 !     Local variables
19224       real(kind=8) :: emin
19225       integer :: i,j,imin,ierr
19226       integer :: diff,allnss,newnss
19227       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19228                 newihpb,newjhpb
19229       logical :: found
19230       integer,dimension(0:nfgtasks) :: i_newnss
19231       integer,dimension(0:nfgtasks) :: displ
19232       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19233       integer :: g_newnss
19234
19235       allnss=0
19236       do i=1,nres-1
19237         do j=i+1,nres
19238           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19239             allnss=allnss+1
19240             allflag(allnss)=0
19241             allihpb(allnss)=i
19242             alljhpb(allnss)=j
19243           endif
19244         enddo
19245       enddo
19246
19247 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19248
19249  1    emin=1.0d300
19250       do i=1,allnss
19251         if (allflag(i).eq.0 .and. &
19252              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19253           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19254           imin=i
19255         endif
19256       enddo
19257       if (emin.lt.1.0d300) then
19258         allflag(imin)=1
19259         do i=1,allnss
19260           if (allflag(i).eq.0 .and. &
19261                (allihpb(i).eq.allihpb(imin) .or. &
19262                alljhpb(i).eq.allihpb(imin) .or. &
19263                allihpb(i).eq.alljhpb(imin) .or. &
19264                alljhpb(i).eq.alljhpb(imin))) then
19265             allflag(i)=-1
19266           endif
19267         enddo
19268         goto 1
19269       endif
19270
19271 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19272
19273       newnss=0
19274       do i=1,allnss
19275         if (allflag(i).eq.1) then
19276           newnss=newnss+1
19277           newihpb(newnss)=allihpb(i)
19278           newjhpb(newnss)=alljhpb(i)
19279         endif
19280       enddo
19281
19282 #ifdef MPI
19283       if (nfgtasks.gt.1)then
19284
19285         call MPI_Reduce(newnss,g_newnss,1,&
19286           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19287         call MPI_Gather(newnss,1,MPI_INTEGER,&
19288                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19289         displ(0)=0
19290         do i=1,nfgtasks-1,1
19291           displ(i)=i_newnss(i-1)+displ(i-1)
19292         enddo
19293         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19294                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19295                          king,FG_COMM,IERR)
19296         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19297                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19298                          king,FG_COMM,IERR)
19299         if(fg_rank.eq.0) then
19300 !         print *,'g_newnss',g_newnss
19301 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19302 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19303          newnss=g_newnss
19304          do i=1,newnss
19305           newihpb(i)=g_newihpb(i)
19306           newjhpb(i)=g_newjhpb(i)
19307          enddo
19308         endif
19309       endif
19310 #endif
19311
19312       diff=newnss-nss
19313
19314 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19315 !       print *,newnss,nss,maxdim
19316       do i=1,nss
19317         found=.false.
19318 !        print *,newnss
19319         do j=1,newnss
19320 !!          print *,j
19321           if (idssb(i).eq.newihpb(j) .and. &
19322                jdssb(i).eq.newjhpb(j)) found=.true.
19323         enddo
19324 #ifndef CLUST
19325 #ifndef WHAM
19326 !        write(iout,*) "found",found,i,j
19327         if (.not.found.and.fg_rank.eq.0) &
19328             write(iout,'(a15,f12.2,f8.1,2i5)') &
19329              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19330 #endif
19331 #endif
19332       enddo
19333
19334       do i=1,newnss
19335         found=.false.
19336         do j=1,nss
19337 !          print *,i,j
19338           if (newihpb(i).eq.idssb(j) .and. &
19339                newjhpb(i).eq.jdssb(j)) found=.true.
19340         enddo
19341 #ifndef CLUST
19342 #ifndef WHAM
19343 !        write(iout,*) "found",found,i,j
19344         if (.not.found.and.fg_rank.eq.0) &
19345             write(iout,'(a15,f12.2,f8.1,2i5)') &
19346              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19347 #endif
19348 #endif
19349       enddo
19350
19351       nss=newnss
19352       do i=1,nss
19353         idssb(i)=newihpb(i)
19354         jdssb(i)=newjhpb(i)
19355       enddo
19356
19357       return
19358       end subroutine dyn_set_nss
19359 ! Lipid transfer energy function
19360       subroutine Eliptransfer(eliptran)
19361 !C this is done by Adasko
19362 !C      print *,"wchodze"
19363 !C structure of box:
19364 !C      water
19365 !C--bordliptop-- buffore starts
19366 !C--bufliptop--- here true lipid starts
19367 !C      lipid
19368 !C--buflipbot--- lipid ends buffore starts
19369 !C--bordlipbot--buffore ends
19370       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19371       integer :: i
19372       eliptran=0.0
19373 !      print *, "I am in eliptran"
19374       do i=ilip_start,ilip_end
19375 !C       do i=1,1
19376         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19377          cycle
19378
19379         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19380         if (positi.le.0.0) positi=positi+boxzsize
19381 !C        print *,i
19382 !C first for peptide groups
19383 !c for each residue check if it is in lipid or lipid water border area
19384        if ((positi.gt.bordlipbot)  &
19385       .and.(positi.lt.bordliptop)) then
19386 !C the energy transfer exist
19387         if (positi.lt.buflipbot) then
19388 !C what fraction I am in
19389          fracinbuf=1.0d0-      &
19390              ((positi-bordlipbot)/lipbufthick)
19391 !C lipbufthick is thickenes of lipid buffore
19392          sslip=sscalelip(fracinbuf)
19393          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19394          eliptran=eliptran+sslip*pepliptran
19395          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19396          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19397 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19398
19399 !C        print *,"doing sccale for lower part"
19400 !C         print *,i,sslip,fracinbuf,ssgradlip
19401         elseif (positi.gt.bufliptop) then
19402          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19403          sslip=sscalelip(fracinbuf)
19404          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19405          eliptran=eliptran+sslip*pepliptran
19406          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19407          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19408 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19409 !C          print *, "doing sscalefor top part"
19410 !C         print *,i,sslip,fracinbuf,ssgradlip
19411         else
19412          eliptran=eliptran+pepliptran
19413 !C         print *,"I am in true lipid"
19414         endif
19415 !C       else
19416 !C       eliptran=elpitran+0.0 ! I am in water
19417        endif
19418        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19419        enddo
19420 ! here starts the side chain transfer
19421        do i=ilip_start,ilip_end
19422         if (itype(i,1).eq.ntyp1) cycle
19423         positi=(mod(c(3,i+nres),boxzsize))
19424         if (positi.le.0) positi=positi+boxzsize
19425 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19426 !c for each residue check if it is in lipid or lipid water border area
19427 !C       respos=mod(c(3,i+nres),boxzsize)
19428 !C       print *,positi,bordlipbot,buflipbot
19429        if ((positi.gt.bordlipbot) &
19430        .and.(positi.lt.bordliptop)) then
19431 !C the energy transfer exist
19432         if (positi.lt.buflipbot) then
19433          fracinbuf=1.0d0-   &
19434            ((positi-bordlipbot)/lipbufthick)
19435 !C lipbufthick is thickenes of lipid buffore
19436          sslip=sscalelip(fracinbuf)
19437          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19438          eliptran=eliptran+sslip*liptranene(itype(i,1))
19439          gliptranx(3,i)=gliptranx(3,i) &
19440       +ssgradlip*liptranene(itype(i,1))
19441          gliptranc(3,i-1)= gliptranc(3,i-1) &
19442       +ssgradlip*liptranene(itype(i,1))
19443 !C         print *,"doing sccale for lower part"
19444         elseif (positi.gt.bufliptop) then
19445          fracinbuf=1.0d0-  &
19446       ((bordliptop-positi)/lipbufthick)
19447          sslip=sscalelip(fracinbuf)
19448          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19449          eliptran=eliptran+sslip*liptranene(itype(i,1))
19450          gliptranx(3,i)=gliptranx(3,i)  &
19451        +ssgradlip*liptranene(itype(i,1))
19452          gliptranc(3,i-1)= gliptranc(3,i-1) &
19453       +ssgradlip*liptranene(itype(i,1))
19454 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19455         else
19456          eliptran=eliptran+liptranene(itype(i,1))
19457 !C         print *,"I am in true lipid"
19458         endif
19459         endif ! if in lipid or buffor
19460 !C       else
19461 !C       eliptran=elpitran+0.0 ! I am in water
19462         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19463        enddo
19464        return
19465        end  subroutine Eliptransfer
19466 !----------------------------------NANO FUNCTIONS
19467 !C-----------------------------------------------------------------------
19468 !C-----------------------------------------------------------
19469 !C This subroutine is to mimic the histone like structure but as well can be
19470 !C utilizet to nanostructures (infinit) small modification has to be used to
19471 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19472 !C gradient has to be modified at the ends
19473 !C The energy function is Kihara potential
19474 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19475 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19476 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19477 !C simple Kihara potential
19478       subroutine calctube(Etube)
19479       real(kind=8),dimension(3) :: vectube
19480       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19481        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19482        sc_aa_tube,sc_bb_tube
19483       integer :: i,j,iti
19484       Etube=0.0d0
19485       do i=itube_start,itube_end
19486         enetube(i)=0.0d0
19487         enetube(i+nres)=0.0d0
19488       enddo
19489 !C first we calculate the distance from tube center
19490 !C for UNRES
19491        do i=itube_start,itube_end
19492 !C lets ommit dummy atoms for now
19493        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19494 !C now calculate distance from center of tube and direction vectors
19495       xmin=boxxsize
19496       ymin=boxysize
19497 ! Find minimum distance in periodic box
19498         do j=-1,1
19499          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19500          vectube(1)=vectube(1)+boxxsize*j
19501          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19502          vectube(2)=vectube(2)+boxysize*j
19503          xminact=abs(vectube(1)-tubecenter(1))
19504          yminact=abs(vectube(2)-tubecenter(2))
19505            if (xmin.gt.xminact) then
19506             xmin=xminact
19507             xtemp=vectube(1)
19508            endif
19509            if (ymin.gt.yminact) then
19510              ymin=yminact
19511              ytemp=vectube(2)
19512             endif
19513          enddo
19514       vectube(1)=xtemp
19515       vectube(2)=ytemp
19516       vectube(1)=vectube(1)-tubecenter(1)
19517       vectube(2)=vectube(2)-tubecenter(2)
19518
19519 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19520 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19521
19522 !C as the tube is infinity we do not calculate the Z-vector use of Z
19523 !C as chosen axis
19524       vectube(3)=0.0d0
19525 !C now calculte the distance
19526        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19527 !C now normalize vector
19528       vectube(1)=vectube(1)/tub_r
19529       vectube(2)=vectube(2)/tub_r
19530 !C calculte rdiffrence between r and r0
19531       rdiff=tub_r-tubeR0
19532 !C and its 6 power
19533       rdiff6=rdiff**6.0d0
19534 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19535        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19536 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19537 !C       print *,rdiff,rdiff6,pep_aa_tube
19538 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19539 !C now we calculate gradient
19540        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19541             6.0d0*pep_bb_tube)/rdiff6/rdiff
19542 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19543 !C     &rdiff,fac
19544 !C now direction of gg_tube vector
19545         do j=1,3
19546         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19547         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19548         enddo
19549         enddo
19550 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19551 !C        print *,gg_tube(1,0),"TU"
19552
19553
19554        do i=itube_start,itube_end
19555 !C Lets not jump over memory as we use many times iti
19556          iti=itype(i,1)
19557 !C lets ommit dummy atoms for now
19558          if ((iti.eq.ntyp1)  &
19559 !C in UNRES uncomment the line below as GLY has no side-chain...
19560 !C      .or.(iti.eq.10)
19561         ) cycle
19562       xmin=boxxsize
19563       ymin=boxysize
19564         do j=-1,1
19565          vectube(1)=mod((c(1,i+nres)),boxxsize)
19566          vectube(1)=vectube(1)+boxxsize*j
19567          vectube(2)=mod((c(2,i+nres)),boxysize)
19568          vectube(2)=vectube(2)+boxysize*j
19569
19570          xminact=abs(vectube(1)-tubecenter(1))
19571          yminact=abs(vectube(2)-tubecenter(2))
19572            if (xmin.gt.xminact) then
19573             xmin=xminact
19574             xtemp=vectube(1)
19575            endif
19576            if (ymin.gt.yminact) then
19577              ymin=yminact
19578              ytemp=vectube(2)
19579             endif
19580          enddo
19581       vectube(1)=xtemp
19582       vectube(2)=ytemp
19583 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19584 !C     &     tubecenter(2)
19585       vectube(1)=vectube(1)-tubecenter(1)
19586       vectube(2)=vectube(2)-tubecenter(2)
19587
19588 !C as the tube is infinity we do not calculate the Z-vector use of Z
19589 !C as chosen axis
19590       vectube(3)=0.0d0
19591 !C now calculte the distance
19592        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19593 !C now normalize vector
19594       vectube(1)=vectube(1)/tub_r
19595       vectube(2)=vectube(2)/tub_r
19596
19597 !C calculte rdiffrence between r and r0
19598       rdiff=tub_r-tubeR0
19599 !C and its 6 power
19600       rdiff6=rdiff**6.0d0
19601 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19602        sc_aa_tube=sc_aa_tube_par(iti)
19603        sc_bb_tube=sc_bb_tube_par(iti)
19604        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19605        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19606              6.0d0*sc_bb_tube/rdiff6/rdiff
19607 !C now direction of gg_tube vector
19608          do j=1,3
19609           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19610           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19611          enddo
19612         enddo
19613         do i=itube_start,itube_end
19614           Etube=Etube+enetube(i)+enetube(i+nres)
19615         enddo
19616 !C        print *,"ETUBE", etube
19617         return
19618         end subroutine calctube
19619 !C TO DO 1) add to total energy
19620 !C       2) add to gradient summation
19621 !C       3) add reading parameters (AND of course oppening of PARAM file)
19622 !C       4) add reading the center of tube
19623 !C       5) add COMMONs
19624 !C       6) add to zerograd
19625 !C       7) allocate matrices
19626
19627
19628 !C-----------------------------------------------------------------------
19629 !C-----------------------------------------------------------
19630 !C This subroutine is to mimic the histone like structure but as well can be
19631 !C utilizet to nanostructures (infinit) small modification has to be used to
19632 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19633 !C gradient has to be modified at the ends
19634 !C The energy function is Kihara potential
19635 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19636 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19637 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19638 !C simple Kihara potential
19639       subroutine calctube2(Etube)
19640             real(kind=8),dimension(3) :: vectube
19641       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19642        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19643        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19644       integer:: i,j,iti
19645       Etube=0.0d0
19646       do i=itube_start,itube_end
19647         enetube(i)=0.0d0
19648         enetube(i+nres)=0.0d0
19649       enddo
19650 !C first we calculate the distance from tube center
19651 !C first sugare-phosphate group for NARES this would be peptide group
19652 !C for UNRES
19653        do i=itube_start,itube_end
19654 !C lets ommit dummy atoms for now
19655
19656        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19657 !C now calculate distance from center of tube and direction vectors
19658 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19659 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19660 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19661 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19662       xmin=boxxsize
19663       ymin=boxysize
19664         do j=-1,1
19665          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19666          vectube(1)=vectube(1)+boxxsize*j
19667          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19668          vectube(2)=vectube(2)+boxysize*j
19669
19670          xminact=abs(vectube(1)-tubecenter(1))
19671          yminact=abs(vectube(2)-tubecenter(2))
19672            if (xmin.gt.xminact) then
19673             xmin=xminact
19674             xtemp=vectube(1)
19675            endif
19676            if (ymin.gt.yminact) then
19677              ymin=yminact
19678              ytemp=vectube(2)
19679             endif
19680          enddo
19681       vectube(1)=xtemp
19682       vectube(2)=ytemp
19683       vectube(1)=vectube(1)-tubecenter(1)
19684       vectube(2)=vectube(2)-tubecenter(2)
19685
19686 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19687 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19688
19689 !C as the tube is infinity we do not calculate the Z-vector use of Z
19690 !C as chosen axis
19691       vectube(3)=0.0d0
19692 !C now calculte the distance
19693        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19694 !C now normalize vector
19695       vectube(1)=vectube(1)/tub_r
19696       vectube(2)=vectube(2)/tub_r
19697 !C calculte rdiffrence between r and r0
19698       rdiff=tub_r-tubeR0
19699 !C and its 6 power
19700       rdiff6=rdiff**6.0d0
19701 !C THIS FRAGMENT MAKES TUBE FINITE
19702         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19703         if (positi.le.0) positi=positi+boxzsize
19704 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19705 !c for each residue check if it is in lipid or lipid water border area
19706 !C       respos=mod(c(3,i+nres),boxzsize)
19707 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19708        if ((positi.gt.bordtubebot)  &
19709         .and.(positi.lt.bordtubetop)) then
19710 !C the energy transfer exist
19711         if (positi.lt.buftubebot) then
19712          fracinbuf=1.0d0-  &
19713            ((positi-bordtubebot)/tubebufthick)
19714 !C lipbufthick is thickenes of lipid buffore
19715          sstube=sscalelip(fracinbuf)
19716          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19717 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19718          enetube(i)=enetube(i)+sstube*tubetranenepep
19719 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19720 !C     &+ssgradtube*tubetranene(itype(i,1))
19721 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19722 !C     &+ssgradtube*tubetranene(itype(i,1))
19723 !C         print *,"doing sccale for lower part"
19724         elseif (positi.gt.buftubetop) then
19725          fracinbuf=1.0d0-  &
19726         ((bordtubetop-positi)/tubebufthick)
19727          sstube=sscalelip(fracinbuf)
19728          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19729          enetube(i)=enetube(i)+sstube*tubetranenepep
19730 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19731 !C     &+ssgradtube*tubetranene(itype(i,1))
19732 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19733 !C     &+ssgradtube*tubetranene(itype(i,1))
19734 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19735         else
19736          sstube=1.0d0
19737          ssgradtube=0.0d0
19738          enetube(i)=enetube(i)+sstube*tubetranenepep
19739 !C         print *,"I am in true lipid"
19740         endif
19741         else
19742 !C          sstube=0.0d0
19743 !C          ssgradtube=0.0d0
19744         cycle
19745         endif ! if in lipid or buffor
19746
19747 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19748        enetube(i)=enetube(i)+sstube* &
19749         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19750 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19751 !C       print *,rdiff,rdiff6,pep_aa_tube
19752 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19753 !C now we calculate gradient
19754        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19755              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19756 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19757 !C     &rdiff,fac
19758
19759 !C now direction of gg_tube vector
19760        do j=1,3
19761         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19762         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19763         enddo
19764          gg_tube(3,i)=gg_tube(3,i)  &
19765        +ssgradtube*enetube(i)/sstube/2.0d0
19766          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19767        +ssgradtube*enetube(i)/sstube/2.0d0
19768
19769         enddo
19770 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19771 !C        print *,gg_tube(1,0),"TU"
19772         do i=itube_start,itube_end
19773 !C Lets not jump over memory as we use many times iti
19774          iti=itype(i,1)
19775 !C lets ommit dummy atoms for now
19776          if ((iti.eq.ntyp1) &
19777 !!C in UNRES uncomment the line below as GLY has no side-chain...
19778            .or.(iti.eq.10) &
19779           ) cycle
19780           vectube(1)=c(1,i+nres)
19781           vectube(1)=mod(vectube(1),boxxsize)
19782           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19783           vectube(2)=c(2,i+nres)
19784           vectube(2)=mod(vectube(2),boxysize)
19785           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19786
19787       vectube(1)=vectube(1)-tubecenter(1)
19788       vectube(2)=vectube(2)-tubecenter(2)
19789 !C THIS FRAGMENT MAKES TUBE FINITE
19790         positi=(mod(c(3,i+nres),boxzsize))
19791         if (positi.le.0) positi=positi+boxzsize
19792 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19793 !c for each residue check if it is in lipid or lipid water border area
19794 !C       respos=mod(c(3,i+nres),boxzsize)
19795 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19796
19797        if ((positi.gt.bordtubebot)  &
19798         .and.(positi.lt.bordtubetop)) then
19799 !C the energy transfer exist
19800         if (positi.lt.buftubebot) then
19801          fracinbuf=1.0d0- &
19802             ((positi-bordtubebot)/tubebufthick)
19803 !C lipbufthick is thickenes of lipid buffore
19804          sstube=sscalelip(fracinbuf)
19805          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19806 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19807          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19808 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19809 !C     &+ssgradtube*tubetranene(itype(i,1))
19810 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19811 !C     &+ssgradtube*tubetranene(itype(i,1))
19812 !C         print *,"doing sccale for lower part"
19813         elseif (positi.gt.buftubetop) then
19814          fracinbuf=1.0d0- &
19815         ((bordtubetop-positi)/tubebufthick)
19816
19817          sstube=sscalelip(fracinbuf)
19818          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19819          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19820 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19821 !C     &+ssgradtube*tubetranene(itype(i,1))
19822 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19823 !C     &+ssgradtube*tubetranene(itype(i,1))
19824 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19825         else
19826          sstube=1.0d0
19827          ssgradtube=0.0d0
19828          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19829 !C         print *,"I am in true lipid"
19830         endif
19831         else
19832 !C          sstube=0.0d0
19833 !C          ssgradtube=0.0d0
19834         cycle
19835         endif ! if in lipid or buffor
19836 !CEND OF FINITE FRAGMENT
19837 !C as the tube is infinity we do not calculate the Z-vector use of Z
19838 !C as chosen axis
19839       vectube(3)=0.0d0
19840 !C now calculte the distance
19841        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19842 !C now normalize vector
19843       vectube(1)=vectube(1)/tub_r
19844       vectube(2)=vectube(2)/tub_r
19845 !C calculte rdiffrence between r and r0
19846       rdiff=tub_r-tubeR0
19847 !C and its 6 power
19848       rdiff6=rdiff**6.0d0
19849 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19850        sc_aa_tube=sc_aa_tube_par(iti)
19851        sc_bb_tube=sc_bb_tube_par(iti)
19852        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19853                        *sstube+enetube(i+nres)
19854 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19855 !C now we calculate gradient
19856        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19857             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19858 !C now direction of gg_tube vector
19859          do j=1,3
19860           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19861           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19862          enddo
19863          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19864        +ssgradtube*enetube(i+nres)/sstube
19865          gg_tube(3,i-1)= gg_tube(3,i-1) &
19866        +ssgradtube*enetube(i+nres)/sstube
19867
19868         enddo
19869         do i=itube_start,itube_end
19870           Etube=Etube+enetube(i)+enetube(i+nres)
19871         enddo
19872 !C        print *,"ETUBE", etube
19873         return
19874         end subroutine calctube2
19875 !=====================================================================================================================================
19876       subroutine calcnano(Etube)
19877       real(kind=8),dimension(3) :: vectube
19878
19879       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19880        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19881        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19882        integer:: i,j,iti,r
19883
19884       Etube=0.0d0
19885 !      print *,itube_start,itube_end,"poczatek"
19886       do i=itube_start,itube_end
19887         enetube(i)=0.0d0
19888         enetube(i+nres)=0.0d0
19889       enddo
19890 !C first we calculate the distance from tube center
19891 !C first sugare-phosphate group for NARES this would be peptide group
19892 !C for UNRES
19893        do i=itube_start,itube_end
19894 !C lets ommit dummy atoms for now
19895        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19896 !C now calculate distance from center of tube and direction vectors
19897       xmin=boxxsize
19898       ymin=boxysize
19899       zmin=boxzsize
19900
19901         do j=-1,1
19902          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19903          vectube(1)=vectube(1)+boxxsize*j
19904          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19905          vectube(2)=vectube(2)+boxysize*j
19906          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19907          vectube(3)=vectube(3)+boxzsize*j
19908
19909
19910          xminact=dabs(vectube(1)-tubecenter(1))
19911          yminact=dabs(vectube(2)-tubecenter(2))
19912          zminact=dabs(vectube(3)-tubecenter(3))
19913
19914            if (xmin.gt.xminact) then
19915             xmin=xminact
19916             xtemp=vectube(1)
19917            endif
19918            if (ymin.gt.yminact) then
19919              ymin=yminact
19920              ytemp=vectube(2)
19921             endif
19922            if (zmin.gt.zminact) then
19923              zmin=zminact
19924              ztemp=vectube(3)
19925             endif
19926          enddo
19927       vectube(1)=xtemp
19928       vectube(2)=ytemp
19929       vectube(3)=ztemp
19930
19931       vectube(1)=vectube(1)-tubecenter(1)
19932       vectube(2)=vectube(2)-tubecenter(2)
19933       vectube(3)=vectube(3)-tubecenter(3)
19934
19935 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19936 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19937 !C as the tube is infinity we do not calculate the Z-vector use of Z
19938 !C as chosen axis
19939 !C      vectube(3)=0.0d0
19940 !C now calculte the distance
19941        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19942 !C now normalize vector
19943       vectube(1)=vectube(1)/tub_r
19944       vectube(2)=vectube(2)/tub_r
19945       vectube(3)=vectube(3)/tub_r
19946 !C calculte rdiffrence between r and r0
19947       rdiff=tub_r-tubeR0
19948 !C and its 6 power
19949       rdiff6=rdiff**6.0d0
19950 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19951        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19952 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19953 !C       print *,rdiff,rdiff6,pep_aa_tube
19954 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19955 !C now we calculate gradient
19956        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19957             6.0d0*pep_bb_tube)/rdiff6/rdiff
19958 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19959 !C     &rdiff,fac
19960          if (acavtubpep.eq.0.0d0) then
19961 !C go to 667
19962          enecavtube(i)=0.0
19963          faccav=0.0
19964          else
19965          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19966          enecavtube(i)=  &
19967         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19968         /denominator
19969          enecavtube(i)=0.0
19970          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19971         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19972         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19973         /denominator**2.0d0
19974 !C         faccav=0.0
19975 !C         fac=fac+faccav
19976 !C 667     continue
19977          endif
19978           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19979         do j=1,3
19980         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19981         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19982         enddo
19983         enddo
19984
19985        do i=itube_start,itube_end
19986         enecavtube(i)=0.0d0
19987 !C Lets not jump over memory as we use many times iti
19988          iti=itype(i,1)
19989 !C lets ommit dummy atoms for now
19990          if ((iti.eq.ntyp1) &
19991 !C in UNRES uncomment the line below as GLY has no side-chain...
19992 !C      .or.(iti.eq.10)
19993          ) cycle
19994       xmin=boxxsize
19995       ymin=boxysize
19996       zmin=boxzsize
19997         do j=-1,1
19998          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19999          vectube(1)=vectube(1)+boxxsize*j
20000          vectube(2)=dmod((c(2,i+nres)),boxysize)
20001          vectube(2)=vectube(2)+boxysize*j
20002          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20003          vectube(3)=vectube(3)+boxzsize*j
20004
20005
20006          xminact=dabs(vectube(1)-tubecenter(1))
20007          yminact=dabs(vectube(2)-tubecenter(2))
20008          zminact=dabs(vectube(3)-tubecenter(3))
20009
20010            if (xmin.gt.xminact) then
20011             xmin=xminact
20012             xtemp=vectube(1)
20013            endif
20014            if (ymin.gt.yminact) then
20015              ymin=yminact
20016              ytemp=vectube(2)
20017             endif
20018            if (zmin.gt.zminact) then
20019              zmin=zminact
20020              ztemp=vectube(3)
20021             endif
20022          enddo
20023       vectube(1)=xtemp
20024       vectube(2)=ytemp
20025       vectube(3)=ztemp
20026
20027 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20028 !C     &     tubecenter(2)
20029       vectube(1)=vectube(1)-tubecenter(1)
20030       vectube(2)=vectube(2)-tubecenter(2)
20031       vectube(3)=vectube(3)-tubecenter(3)
20032 !C now calculte the distance
20033        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20034 !C now normalize vector
20035       vectube(1)=vectube(1)/tub_r
20036       vectube(2)=vectube(2)/tub_r
20037       vectube(3)=vectube(3)/tub_r
20038
20039 !C calculte rdiffrence between r and r0
20040       rdiff=tub_r-tubeR0
20041 !C and its 6 power
20042       rdiff6=rdiff**6.0d0
20043        sc_aa_tube=sc_aa_tube_par(iti)
20044        sc_bb_tube=sc_bb_tube_par(iti)
20045        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20046 !C       enetube(i+nres)=0.0d0
20047 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20048 !C now we calculate gradient
20049        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20050             6.0d0*sc_bb_tube/rdiff6/rdiff
20051 !C       fac=0.0
20052 !C now direction of gg_tube vector
20053 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20054          if (acavtub(iti).eq.0.0d0) then
20055 !C go to 667
20056          enecavtube(i+nres)=0.0d0
20057          faccav=0.0d0
20058          else
20059          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20060          enecavtube(i+nres)=   &
20061         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20062         /denominator
20063 !C         enecavtube(i)=0.0
20064          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20065         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20066         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20067         /denominator**2.0d0
20068 !C         faccav=0.0
20069          fac=fac+faccav
20070 !C 667     continue
20071          endif
20072 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20073 !C     &   enecavtube(i),faccav
20074 !C         print *,"licz=",
20075 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20076 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20077          do j=1,3
20078           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20079           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20080          enddo
20081           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20082         enddo
20083
20084
20085
20086         do i=itube_start,itube_end
20087           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20088          +enecavtube(i+nres)
20089         enddo
20090 !        do i=1,20
20091 !         print *,"begin", i,"a"
20092 !         do r=1,10000
20093 !          rdiff=r/100.0d0
20094 !          rdiff6=rdiff**6.0d0
20095 !          sc_aa_tube=sc_aa_tube_par(i)
20096 !          sc_bb_tube=sc_bb_tube_par(i)
20097 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20098 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20099 !          enecavtube(i)=   &
20100 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20101 !         /denominator
20102
20103 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20104 !         enddo
20105 !         print *,"end",i,"a"
20106 !        enddo
20107 !C        print *,"ETUBE", etube
20108         return
20109         end subroutine calcnano
20110
20111 !===============================================
20112 !--------------------------------------------------------------------------------
20113 !C first for shielding is setting of function of side-chains
20114
20115        subroutine set_shield_fac2
20116        real(kind=8) :: div77_81=0.974996043d0, &
20117         div4_81=0.2222222222d0
20118        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20119          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20120          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20121          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20122 !C the vector between center of side_chain and peptide group
20123        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20124          pept_group,costhet_grad,cosphi_grad_long, &
20125          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20126          sh_frac_dist_grad,pep_side
20127         integer i,j,k
20128 !C      write(2,*) "ivec",ivec_start,ivec_end
20129       do i=1,nres
20130         fac_shield(i)=0.0d0
20131         ishield_list(i)=0
20132         do j=1,3
20133         grad_shield(j,i)=0.0d0
20134         enddo
20135       enddo
20136       do i=ivec_start,ivec_end
20137 !C      do i=1,nres-1
20138 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20139 !      ishield_list(i)=0
20140       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20141 !Cif there two consequtive dummy atoms there is no peptide group between them
20142 !C the line below has to be changed for FGPROC>1
20143       VolumeTotal=0.0
20144       do k=1,nres
20145        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20146        dist_pep_side=0.0
20147        dist_side_calf=0.0
20148        do j=1,3
20149 !C first lets set vector conecting the ithe side-chain with kth side-chain
20150       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20151 !C      pep_side(j)=2.0d0
20152 !C and vector conecting the side-chain with its proper calfa
20153       side_calf(j)=c(j,k+nres)-c(j,k)
20154 !C      side_calf(j)=2.0d0
20155       pept_group(j)=c(j,i)-c(j,i+1)
20156 !C lets have their lenght
20157       dist_pep_side=pep_side(j)**2+dist_pep_side
20158       dist_side_calf=dist_side_calf+side_calf(j)**2
20159       dist_pept_group=dist_pept_group+pept_group(j)**2
20160       enddo
20161        dist_pep_side=sqrt(dist_pep_side)
20162        dist_pept_group=sqrt(dist_pept_group)
20163        dist_side_calf=sqrt(dist_side_calf)
20164       do j=1,3
20165         pep_side_norm(j)=pep_side(j)/dist_pep_side
20166         side_calf_norm(j)=dist_side_calf
20167       enddo
20168 !C now sscale fraction
20169        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20170 !       print *,buff_shield,"buff",sh_frac_dist
20171 !C now sscale
20172         if (sh_frac_dist.le.0.0) cycle
20173 !C        print *,ishield_list(i),i
20174 !C If we reach here it means that this side chain reaches the shielding sphere
20175 !C Lets add him to the list for gradient
20176         ishield_list(i)=ishield_list(i)+1
20177 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20178 !C this list is essential otherwise problem would be O3
20179         shield_list(ishield_list(i),i)=k
20180 !C Lets have the sscale value
20181         if (sh_frac_dist.gt.1.0) then
20182          scale_fac_dist=1.0d0
20183          do j=1,3
20184          sh_frac_dist_grad(j)=0.0d0
20185          enddo
20186         else
20187          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20188                         *(2.0d0*sh_frac_dist-3.0d0)
20189          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20190                        /dist_pep_side/buff_shield*0.5d0
20191          do j=1,3
20192          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20193 !C         sh_frac_dist_grad(j)=0.0d0
20194 !C         scale_fac_dist=1.0d0
20195 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20196 !C     &                    sh_frac_dist_grad(j)
20197          enddo
20198         endif
20199 !C this is what is now we have the distance scaling now volume...
20200       short=short_r_sidechain(itype(k,1))
20201       long=long_r_sidechain(itype(k,1))
20202       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20203       sinthet=short/dist_pep_side*costhet
20204 !      print *,"SORT",short,long,sinthet,costhet
20205 !C now costhet_grad
20206 !C       costhet=0.6d0
20207 !C       sinthet=0.8
20208        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20209 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20210 !C     &             -short/dist_pep_side**2/costhet)
20211 !C       costhet_fac=0.0d0
20212        do j=1,3
20213          costhet_grad(j)=costhet_fac*pep_side(j)
20214        enddo
20215 !C remember for the final gradient multiply costhet_grad(j)
20216 !C for side_chain by factor -2 !
20217 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20218 !C pep_side0pept_group is vector multiplication
20219       pep_side0pept_group=0.0d0
20220       do j=1,3
20221       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20222       enddo
20223       cosalfa=(pep_side0pept_group/ &
20224       (dist_pep_side*dist_side_calf))
20225       fac_alfa_sin=1.0d0-cosalfa**2
20226       fac_alfa_sin=dsqrt(fac_alfa_sin)
20227       rkprim=fac_alfa_sin*(long-short)+short
20228 !C      rkprim=short
20229
20230 !C now costhet_grad
20231        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20232 !C       cosphi=0.6
20233        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20234        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20235            dist_pep_side**2)
20236 !C       sinphi=0.8
20237        do j=1,3
20238          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20239       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20240       *(long-short)/fac_alfa_sin*cosalfa/ &
20241       ((dist_pep_side*dist_side_calf))* &
20242       ((side_calf(j))-cosalfa* &
20243       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20244 !C       cosphi_grad_long(j)=0.0d0
20245         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20246       *(long-short)/fac_alfa_sin*cosalfa &
20247       /((dist_pep_side*dist_side_calf))* &
20248       (pep_side(j)- &
20249       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20250 !C       cosphi_grad_loc(j)=0.0d0
20251        enddo
20252 !C      print *,sinphi,sinthet
20253       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20254                          /VSolvSphere_div
20255 !C     &                    *wshield
20256 !C now the gradient...
20257       do j=1,3
20258       grad_shield(j,i)=grad_shield(j,i) &
20259 !C gradient po skalowaniu
20260                      +(sh_frac_dist_grad(j)*VofOverlap &
20261 !C  gradient po costhet
20262             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20263         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20264             sinphi/sinthet*costhet*costhet_grad(j) &
20265            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20266         )*wshield
20267 !C grad_shield_side is Cbeta sidechain gradient
20268       grad_shield_side(j,ishield_list(i),i)=&
20269              (sh_frac_dist_grad(j)*-2.0d0&
20270              *VofOverlap&
20271             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20272        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20273             sinphi/sinthet*costhet*costhet_grad(j)&
20274            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20275             )*wshield
20276 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20277 !            sinphi/sinthet,&
20278 !           +sinthet/sinphi,"HERE"
20279        grad_shield_loc(j,ishield_list(i),i)=   &
20280             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20281       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20282             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20283              ))&
20284              *wshield
20285 !         print *,grad_shield_loc(j,ishield_list(i),i)
20286       enddo
20287       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20288       enddo
20289       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20290
20291 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20292       enddo
20293       return
20294       end subroutine set_shield_fac2
20295 !----------------------------------------------------------------------------
20296 ! SOUBROUTINE FOR AFM
20297        subroutine AFMvel(Eafmforce)
20298        use MD_data, only:totTafm
20299       real(kind=8),dimension(3) :: diffafm
20300       real(kind=8) :: afmdist,Eafmforce
20301        integer :: i
20302 !C Only for check grad COMMENT if not used for checkgrad
20303 !C      totT=3.0d0
20304 !C--------------------------------------------------------
20305 !C      print *,"wchodze"
20306       afmdist=0.0d0
20307       Eafmforce=0.0d0
20308       do i=1,3
20309       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20310       afmdist=afmdist+diffafm(i)**2
20311       enddo
20312       afmdist=dsqrt(afmdist)
20313 !      totTafm=3.0
20314       Eafmforce=0.5d0*forceAFMconst &
20315       *(distafminit+totTafm*velAFMconst-afmdist)**2
20316 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20317       do i=1,3
20318       gradafm(i,afmend-1)=-forceAFMconst* &
20319        (distafminit+totTafm*velAFMconst-afmdist) &
20320        *diffafm(i)/afmdist
20321       gradafm(i,afmbeg-1)=forceAFMconst* &
20322       (distafminit+totTafm*velAFMconst-afmdist) &
20323       *diffafm(i)/afmdist
20324       enddo
20325 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20326       return
20327       end subroutine AFMvel
20328 !---------------------------------------------------------
20329        subroutine AFMforce(Eafmforce)
20330
20331       real(kind=8),dimension(3) :: diffafm
20332 !      real(kind=8) ::afmdist
20333       real(kind=8) :: afmdist,Eafmforce
20334       integer :: i
20335       afmdist=0.0d0
20336       Eafmforce=0.0d0
20337       do i=1,3
20338       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20339       afmdist=afmdist+diffafm(i)**2
20340       enddo
20341       afmdist=dsqrt(afmdist)
20342 !      print *,afmdist,distafminit
20343       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20344       do i=1,3
20345       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20346       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20347       enddo
20348 !C      print *,'AFM',Eafmforce
20349       return
20350       end subroutine AFMforce
20351
20352 !-----------------------------------------------------------------------------
20353 #ifdef WHAM
20354       subroutine read_ssHist
20355 !      implicit none
20356 !      Includes
20357 !      include 'DIMENSIONS'
20358 !      include "DIMENSIONS.FREE"
20359 !      include 'COMMON.FREE'
20360 !     Local variables
20361       integer :: i,j
20362       character(len=80) :: controlcard
20363
20364       do i=1,dyn_nssHist
20365         call card_concat(controlcard,.true.)
20366         read(controlcard,*) &
20367              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20368       enddo
20369
20370       return
20371       end subroutine read_ssHist
20372 #endif
20373 !-----------------------------------------------------------------------------
20374       integer function indmat(i,j)
20375 !el
20376 ! get the position of the jth ijth fragment of the chain coordinate system
20377 ! in the fromto array.
20378         integer :: i,j
20379
20380         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20381       return
20382       end function indmat
20383 !-----------------------------------------------------------------------------
20384       real(kind=8) function sigm(x)
20385 !el
20386        real(kind=8) :: x
20387         sigm=0.25d0*x
20388       return
20389       end function sigm
20390 !-----------------------------------------------------------------------------
20391 !-----------------------------------------------------------------------------
20392       subroutine alloc_ener_arrays
20393 !EL Allocation of arrays used by module energy
20394       use MD_data, only: mset
20395 !el local variables
20396       integer :: i,j
20397
20398       if(nres.lt.100) then
20399         maxconts=nres
20400       elseif(nres.lt.200) then
20401         maxconts=0.8*nres      ! Max. number of contacts per residue
20402       else
20403         maxconts=0.6*nres ! (maxconts=maxres/4)
20404       endif
20405       maxcont=12*nres      ! Max. number of SC contacts
20406       maxvar=6*nres      ! Max. number of variables
20407 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20408       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20409 !----------------------
20410 ! arrays in subroutine init_int_table
20411 !el#ifdef MPI
20412 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20413 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20414 !el#endif
20415       allocate(nint_gr(nres))
20416       allocate(nscp_gr(nres))
20417       allocate(ielstart(nres))
20418       allocate(ielend(nres))
20419 !(maxres)
20420       allocate(istart(nres,maxint_gr))
20421       allocate(iend(nres,maxint_gr))
20422 !(maxres,maxint_gr)
20423       allocate(iscpstart(nres,maxint_gr))
20424       allocate(iscpend(nres,maxint_gr))
20425 !(maxres,maxint_gr)
20426       allocate(ielstart_vdw(nres))
20427       allocate(ielend_vdw(nres))
20428 !(maxres)
20429       allocate(nint_gr_nucl(nres))
20430       allocate(nscp_gr_nucl(nres))
20431       allocate(ielstart_nucl(nres))
20432       allocate(ielend_nucl(nres))
20433 !(maxres)
20434       allocate(istart_nucl(nres,maxint_gr))
20435       allocate(iend_nucl(nres,maxint_gr))
20436 !(maxres,maxint_gr)
20437       allocate(iscpstart_nucl(nres,maxint_gr))
20438       allocate(iscpend_nucl(nres,maxint_gr))
20439 !(maxres,maxint_gr)
20440       allocate(ielstart_vdw_nucl(nres))
20441       allocate(ielend_vdw_nucl(nres))
20442
20443       allocate(lentyp(0:nfgtasks-1))
20444 !(0:maxprocs-1)
20445 !----------------------
20446 ! commom.contacts
20447 !      common /contacts/
20448       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20449       allocate(icont(2,maxcont))
20450 !(2,maxcont)
20451 !      common /contacts1/
20452       allocate(num_cont(0:nres+4))
20453 !(maxres)
20454       allocate(jcont(maxconts,nres))
20455 !(maxconts,maxres)
20456       allocate(facont(maxconts,nres))
20457 !(maxconts,maxres)
20458       allocate(gacont(3,maxconts,nres))
20459 !(3,maxconts,maxres)
20460 !      common /contacts_hb/
20461       allocate(gacontp_hb1(3,maxconts,nres))
20462       allocate(gacontp_hb2(3,maxconts,nres))
20463       allocate(gacontp_hb3(3,maxconts,nres))
20464       allocate(gacontm_hb1(3,maxconts,nres))
20465       allocate(gacontm_hb2(3,maxconts,nres))
20466       allocate(gacontm_hb3(3,maxconts,nres))
20467       allocate(gacont_hbr(3,maxconts,nres))
20468       allocate(grij_hb_cont(3,maxconts,nres))
20469 !(3,maxconts,maxres)
20470       allocate(facont_hb(maxconts,nres))
20471
20472       allocate(ees0p(maxconts,nres))
20473       allocate(ees0m(maxconts,nres))
20474       allocate(d_cont(maxconts,nres))
20475       allocate(ees0plist(maxconts,nres))
20476
20477 !(maxconts,maxres)
20478       allocate(num_cont_hb(nres))
20479 !(maxres)
20480       allocate(jcont_hb(maxconts,nres))
20481 !(maxconts,maxres)
20482 !      common /rotat/
20483       allocate(Ug(2,2,nres))
20484       allocate(Ugder(2,2,nres))
20485       allocate(Ug2(2,2,nres))
20486       allocate(Ug2der(2,2,nres))
20487 !(2,2,maxres)
20488       allocate(obrot(2,nres))
20489       allocate(obrot2(2,nres))
20490       allocate(obrot_der(2,nres))
20491       allocate(obrot2_der(2,nres))
20492 !(2,maxres)
20493 !      common /precomp1/
20494       allocate(mu(2,nres))
20495       allocate(muder(2,nres))
20496       allocate(Ub2(2,nres))
20497       Ub2(1,:)=0.0d0
20498       Ub2(2,:)=0.0d0
20499       allocate(Ub2der(2,nres))
20500       allocate(Ctobr(2,nres))
20501       allocate(Ctobrder(2,nres))
20502       allocate(Dtobr2(2,nres))
20503       allocate(Dtobr2der(2,nres))
20504 !(2,maxres)
20505       allocate(EUg(2,2,nres))
20506       allocate(EUgder(2,2,nres))
20507       allocate(CUg(2,2,nres))
20508       allocate(CUgder(2,2,nres))
20509       allocate(DUg(2,2,nres))
20510       allocate(Dugder(2,2,nres))
20511       allocate(DtUg2(2,2,nres))
20512       allocate(DtUg2der(2,2,nres))
20513 !(2,2,maxres)
20514 !      common /precomp2/
20515       allocate(Ug2Db1t(2,nres))
20516       allocate(Ug2Db1tder(2,nres))
20517       allocate(CUgb2(2,nres))
20518       allocate(CUgb2der(2,nres))
20519 !(2,maxres)
20520       allocate(EUgC(2,2,nres))
20521       allocate(EUgCder(2,2,nres))
20522       allocate(EUgD(2,2,nres))
20523       allocate(EUgDder(2,2,nres))
20524       allocate(DtUg2EUg(2,2,nres))
20525       allocate(Ug2DtEUg(2,2,nres))
20526 !(2,2,maxres)
20527       allocate(Ug2DtEUgder(2,2,2,nres))
20528       allocate(DtUg2EUgder(2,2,2,nres))
20529 !(2,2,2,maxres)
20530       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20531       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20532       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20533       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20534
20535       allocate(ctilde(2,2,nres))
20536       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20537       allocate(gtb1(2,nres))
20538       allocate(gtb2(2,nres))
20539       allocate(cc(2,2,nres))
20540       allocate(dd(2,2,nres))
20541       allocate(ee(2,2,nres))
20542       allocate(gtcc(2,2,nres))
20543       allocate(gtdd(2,2,nres))
20544       allocate(gtee(2,2,nres))
20545       allocate(gUb2(2,nres))
20546       allocate(gteUg(2,2,nres))
20547
20548 !      common /rotat_old/
20549       allocate(costab(nres))
20550       allocate(sintab(nres))
20551       allocate(costab2(nres))
20552       allocate(sintab2(nres))
20553 !(maxres)
20554 !      common /dipmat/
20555       allocate(a_chuj(2,2,maxconts,nres))
20556 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20557       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20558 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20559 !      common /contdistrib/
20560       allocate(ncont_sent(nres))
20561       allocate(ncont_recv(nres))
20562
20563       allocate(iat_sent(nres))
20564 !(maxres)
20565       allocate(iint_sent(4,nres,nres))
20566       allocate(iint_sent_local(4,nres,nres))
20567 !(4,maxres,maxres)
20568       allocate(iturn3_sent(4,0:nres+4))
20569       allocate(iturn4_sent(4,0:nres+4))
20570       allocate(iturn3_sent_local(4,nres))
20571       allocate(iturn4_sent_local(4,nres))
20572 !(4,maxres)
20573       allocate(itask_cont_from(0:nfgtasks-1))
20574       allocate(itask_cont_to(0:nfgtasks-1))
20575 !(0:max_fg_procs-1)
20576
20577
20578
20579 !----------------------
20580 ! commom.deriv;
20581 !      common /derivat/
20582       allocate(dcdv(6,maxdim))
20583       allocate(dxdv(6,maxdim))
20584 !(6,maxdim)
20585       allocate(dxds(6,nres))
20586 !(6,maxres)
20587       allocate(gradx(3,-1:nres,0:2))
20588       allocate(gradc(3,-1:nres,0:2))
20589 !(3,maxres,2)
20590       allocate(gvdwx(3,-1:nres))
20591       allocate(gvdwc(3,-1:nres))
20592       allocate(gelc(3,-1:nres))
20593       allocate(gelc_long(3,-1:nres))
20594       allocate(gvdwpp(3,-1:nres))
20595       allocate(gvdwc_scpp(3,-1:nres))
20596       allocate(gradx_scp(3,-1:nres))
20597       allocate(gvdwc_scp(3,-1:nres))
20598       allocate(ghpbx(3,-1:nres))
20599       allocate(ghpbc(3,-1:nres))
20600       allocate(gradcorr(3,-1:nres))
20601       allocate(gradcorr_long(3,-1:nres))
20602       allocate(gradcorr5_long(3,-1:nres))
20603       allocate(gradcorr6_long(3,-1:nres))
20604       allocate(gcorr6_turn_long(3,-1:nres))
20605       allocate(gradxorr(3,-1:nres))
20606       allocate(gradcorr5(3,-1:nres))
20607       allocate(gradcorr6(3,-1:nres))
20608       allocate(gliptran(3,-1:nres))
20609       allocate(gliptranc(3,-1:nres))
20610       allocate(gliptranx(3,-1:nres))
20611       allocate(gshieldx(3,-1:nres))
20612       allocate(gshieldc(3,-1:nres))
20613       allocate(gshieldc_loc(3,-1:nres))
20614       allocate(gshieldx_ec(3,-1:nres))
20615       allocate(gshieldc_ec(3,-1:nres))
20616       allocate(gshieldc_loc_ec(3,-1:nres))
20617       allocate(gshieldx_t3(3,-1:nres))
20618       allocate(gshieldc_t3(3,-1:nres))
20619       allocate(gshieldc_loc_t3(3,-1:nres))
20620       allocate(gshieldx_t4(3,-1:nres))
20621       allocate(gshieldc_t4(3,-1:nres))
20622       allocate(gshieldc_loc_t4(3,-1:nres))
20623       allocate(gshieldx_ll(3,-1:nres))
20624       allocate(gshieldc_ll(3,-1:nres))
20625       allocate(gshieldc_loc_ll(3,-1:nres))
20626       allocate(grad_shield(3,-1:nres))
20627       allocate(gg_tube_sc(3,-1:nres))
20628       allocate(gg_tube(3,-1:nres))
20629       allocate(gradafm(3,-1:nres))
20630       allocate(gradb_nucl(3,-1:nres))
20631       allocate(gradbx_nucl(3,-1:nres))
20632       allocate(gvdwpsb1(3,-1:nres))
20633       allocate(gelpp(3,-1:nres))
20634       allocate(gvdwpsb(3,-1:nres))
20635       allocate(gelsbc(3,-1:nres))
20636       allocate(gelsbx(3,-1:nres))
20637       allocate(gvdwsbx(3,-1:nres))
20638       allocate(gvdwsbc(3,-1:nres))
20639       allocate(gsbloc(3,-1:nres))
20640       allocate(gsblocx(3,-1:nres))
20641       allocate(gradcorr_nucl(3,-1:nres))
20642       allocate(gradxorr_nucl(3,-1:nres))
20643       allocate(gradcorr3_nucl(3,-1:nres))
20644       allocate(gradxorr3_nucl(3,-1:nres))
20645       allocate(gvdwpp_nucl(3,-1:nres))
20646       allocate(gradpepcat(3,-1:nres))
20647       allocate(gradpepcatx(3,-1:nres))
20648       allocate(gradcatcat(3,-1:nres))
20649 !(3,maxres)
20650       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20651       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20652 ! grad for shielding surroing
20653       allocate(gloc(0:maxvar,0:2))
20654       allocate(gloc_x(0:maxvar,2))
20655 !(maxvar,2)
20656       allocate(gel_loc(3,-1:nres))
20657       allocate(gel_loc_long(3,-1:nres))
20658       allocate(gcorr3_turn(3,-1:nres))
20659       allocate(gcorr4_turn(3,-1:nres))
20660       allocate(gcorr6_turn(3,-1:nres))
20661       allocate(gradb(3,-1:nres))
20662       allocate(gradbx(3,-1:nres))
20663 !(3,maxres)
20664       allocate(gel_loc_loc(maxvar))
20665       allocate(gel_loc_turn3(maxvar))
20666       allocate(gel_loc_turn4(maxvar))
20667       allocate(gel_loc_turn6(maxvar))
20668       allocate(gcorr_loc(maxvar))
20669       allocate(g_corr5_loc(maxvar))
20670       allocate(g_corr6_loc(maxvar))
20671 !(maxvar)
20672       allocate(gsccorc(3,-1:nres))
20673       allocate(gsccorx(3,-1:nres))
20674 !(3,maxres)
20675       allocate(gsccor_loc(-1:nres))
20676 !(maxres)
20677       allocate(gvdwx_scbase(3,-1:nres))
20678       allocate(gvdwc_scbase(3,-1:nres))
20679       allocate(gvdwx_pepbase(3,-1:nres))
20680       allocate(gvdwc_pepbase(3,-1:nres))
20681       allocate(gvdwx_scpho(3,-1:nres))
20682       allocate(gvdwc_scpho(3,-1:nres))
20683       allocate(gvdwc_peppho(3,-1:nres))
20684
20685       allocate(dtheta(3,2,-1:nres))
20686 !(3,2,maxres)
20687       allocate(gscloc(3,-1:nres))
20688       allocate(gsclocx(3,-1:nres))
20689 !(3,maxres)
20690       allocate(dphi(3,3,-1:nres))
20691       allocate(dalpha(3,3,-1:nres))
20692       allocate(domega(3,3,-1:nres))
20693 !(3,3,maxres)
20694 !      common /deriv_scloc/
20695       allocate(dXX_C1tab(3,nres))
20696       allocate(dYY_C1tab(3,nres))
20697       allocate(dZZ_C1tab(3,nres))
20698       allocate(dXX_Ctab(3,nres))
20699       allocate(dYY_Ctab(3,nres))
20700       allocate(dZZ_Ctab(3,nres))
20701       allocate(dXX_XYZtab(3,nres))
20702       allocate(dYY_XYZtab(3,nres))
20703       allocate(dZZ_XYZtab(3,nres))
20704 !(3,maxres)
20705 !      common /mpgrad/
20706       allocate(jgrad_start(nres))
20707       allocate(jgrad_end(nres))
20708 !(maxres)
20709 !----------------------
20710
20711 !      common /indices/
20712       allocate(ibond_displ(0:nfgtasks-1))
20713       allocate(ibond_count(0:nfgtasks-1))
20714       allocate(ithet_displ(0:nfgtasks-1))
20715       allocate(ithet_count(0:nfgtasks-1))
20716       allocate(iphi_displ(0:nfgtasks-1))
20717       allocate(iphi_count(0:nfgtasks-1))
20718       allocate(iphi1_displ(0:nfgtasks-1))
20719       allocate(iphi1_count(0:nfgtasks-1))
20720       allocate(ivec_displ(0:nfgtasks-1))
20721       allocate(ivec_count(0:nfgtasks-1))
20722       allocate(iset_displ(0:nfgtasks-1))
20723       allocate(iset_count(0:nfgtasks-1))
20724       allocate(iint_count(0:nfgtasks-1))
20725       allocate(iint_displ(0:nfgtasks-1))
20726 !(0:max_fg_procs-1)
20727 !----------------------
20728 ! common.MD
20729 !      common /mdgrad/
20730       allocate(gcart(3,-1:nres))
20731       allocate(gxcart(3,-1:nres))
20732 !(3,0:MAXRES)
20733       allocate(gradcag(3,-1:nres))
20734       allocate(gradxag(3,-1:nres))
20735 !(3,MAXRES)
20736 !      common /back_constr/
20737 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20738       allocate(dutheta(nres))
20739       allocate(dugamma(nres))
20740 !(maxres)
20741       allocate(duscdiff(3,nres))
20742       allocate(duscdiffx(3,nres))
20743 !(3,maxres)
20744 !el i io:read_fragments
20745 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20746 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20747 !      common /qmeas/
20748 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20749 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20750       allocate(mset(0:nprocs))  !(maxprocs/20)
20751       mset(:)=0
20752 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20753 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20754       allocate(dUdconst(3,0:nres))
20755       allocate(dUdxconst(3,0:nres))
20756       allocate(dqwol(3,0:nres))
20757       allocate(dxqwol(3,0:nres))
20758 !(3,0:MAXRES)
20759 !----------------------
20760 ! common.sbridge
20761 !      common /sbridge/ in io_common: read_bridge
20762 !el    allocate((:),allocatable :: iss      !(maxss)
20763 !      common /links/  in io_common: read_bridge
20764 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20765 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20766 !      common /dyn_ssbond/
20767 ! and side-chain vectors in theta or phi.
20768       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20769 !(maxres,maxres)
20770 !      do i=1,nres
20771 !        do j=i+1,nres
20772       dyn_ssbond_ij(:,:)=1.0d300
20773 !        enddo
20774 !      enddo
20775
20776 !      if (nss.gt.0) then
20777         allocate(idssb(maxdim),jdssb(maxdim))
20778 !        allocate(newihpb(nss),newjhpb(nss))
20779 !(maxdim)
20780 !      endif
20781       allocate(ishield_list(-1:nres))
20782       allocate(shield_list(maxcontsshi,-1:nres))
20783       allocate(dyn_ss_mask(nres))
20784       allocate(fac_shield(-1:nres))
20785       allocate(enetube(nres*2))
20786       allocate(enecavtube(nres*2))
20787
20788 !(maxres)
20789       dyn_ss_mask(:)=.false.
20790 !----------------------
20791 ! common.sccor
20792 ! Parameters of the SCCOR term
20793 !      common/sccor/
20794 !el in io_conf: parmread
20795 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20796 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20797 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20798 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20799 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20800 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20801 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20802 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20803 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20804 !----------------
20805       allocate(gloc_sc(3,0:2*nres,0:10))
20806 !(3,0:maxres2,10)maxres2=2*maxres
20807       allocate(dcostau(3,3,3,2*nres))
20808       allocate(dsintau(3,3,3,2*nres))
20809       allocate(dtauangle(3,3,3,2*nres))
20810       allocate(dcosomicron(3,3,3,2*nres))
20811       allocate(domicron(3,3,3,2*nres))
20812 !(3,3,3,maxres2)maxres2=2*maxres
20813 !----------------------
20814 ! common.var
20815 !      common /restr/
20816       allocate(varall(maxvar))
20817 !(maxvar)(maxvar=6*maxres)
20818       allocate(mask_theta(nres))
20819       allocate(mask_phi(nres))
20820       allocate(mask_side(nres))
20821 !(maxres)
20822 !----------------------
20823 ! common.vectors
20824 !      common /vectors/
20825       allocate(uy(3,nres))
20826       allocate(uz(3,nres))
20827 !(3,maxres)
20828       allocate(uygrad(3,3,2,nres))
20829       allocate(uzgrad(3,3,2,nres))
20830 !(3,3,2,maxres)
20831
20832       return
20833       end subroutine alloc_ener_arrays
20834 !-----------------------------------------------------------------
20835       subroutine ebond_nucl(estr_nucl)
20836 !c
20837 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20838 !c
20839
20840       real(kind=8),dimension(3) :: u,ud
20841       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20842       real(kind=8) :: estr_nucl,diff
20843       integer :: iti,i,j,k,nbi
20844       estr_nucl=0.0d0
20845 !C      print *,"I enter ebond"
20846       if (energy_dec) &
20847       write (iout,*) "ibondp_start,ibondp_end",&
20848        ibondp_nucl_start,ibondp_nucl_end
20849       do i=ibondp_nucl_start,ibondp_nucl_end
20850         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20851          itype(i,2).eq.ntyp1_molec(2)) cycle
20852 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20853 !          do j=1,3
20854 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20855 !     &      *dc(j,i-1)/vbld(i)
20856 !          enddo
20857 !          if (energy_dec) write(iout,*)
20858 !     &       "estr1",i,vbld(i),distchainmax,
20859 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20860
20861           diff = vbld(i)-vbldp0_nucl
20862           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20863           vbldp0_nucl,diff,AKP_nucl*diff*diff
20864           estr_nucl=estr_nucl+diff*diff
20865 !          print *,estr_nucl
20866           do j=1,3
20867             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20868           enddo
20869 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20870       enddo
20871       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20872 !      print *,"partial sum", estr_nucl,AKP_nucl
20873
20874       if (energy_dec) &
20875       write (iout,*) "ibondp_start,ibondp_end",&
20876        ibond_nucl_start,ibond_nucl_end
20877
20878       do i=ibond_nucl_start,ibond_nucl_end
20879 !C        print *, "I am stuck",i
20880         iti=itype(i,2)
20881         if (iti.eq.ntyp1_molec(2)) cycle
20882           nbi=nbondterm_nucl(iti)
20883 !C        print *,iti,nbi
20884           if (nbi.eq.1) then
20885             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20886
20887             if (energy_dec) &
20888            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20889            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20890             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20891 !            print *,estr_nucl
20892             do j=1,3
20893               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20894             enddo
20895           else
20896             do j=1,nbi
20897               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20898               ud(j)=aksc_nucl(j,iti)*diff
20899               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20900             enddo
20901             uprod=u(1)
20902             do j=2,nbi
20903               uprod=uprod*u(j)
20904             enddo
20905             usum=0.0d0
20906             usumsqder=0.0d0
20907             do j=1,nbi
20908               uprod1=1.0d0
20909               uprod2=1.0d0
20910               do k=1,nbi
20911                 if (k.ne.j) then
20912                   uprod1=uprod1*u(k)
20913                   uprod2=uprod2*u(k)*u(k)
20914                 endif
20915               enddo
20916               usum=usum+uprod1
20917               usumsqder=usumsqder+ud(j)*uprod2
20918             enddo
20919             estr_nucl=estr_nucl+uprod/usum
20920             do j=1,3
20921              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20922             enddo
20923         endif
20924       enddo
20925 !C      print *,"I am about to leave ebond"
20926       return
20927       end subroutine ebond_nucl
20928
20929 !-----------------------------------------------------------------------------
20930       subroutine ebend_nucl(etheta_nucl)
20931       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20932       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20933       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20934       logical :: lprn=.false., lprn1=.false.
20935 !el local variables
20936       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20937       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20938       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20939 ! local variables for constrains
20940       real(kind=8) :: difi,thetiii
20941        integer itheta
20942       etheta_nucl=0.0D0
20943 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20944       do i=ithet_nucl_start,ithet_nucl_end
20945         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20946         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20947         (itype(i,2).eq.ntyp1_molec(2))) cycle
20948         dethetai=0.0d0
20949         dephii=0.0d0
20950         dephii1=0.0d0
20951         theti2=0.5d0*theta(i)
20952         ityp2=ithetyp_nucl(itype(i-1,2))
20953         do k=1,nntheterm_nucl
20954           coskt(k)=dcos(k*theti2)
20955           sinkt(k)=dsin(k*theti2)
20956         enddo
20957         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20958 #ifdef OSF
20959           phii=phi(i)
20960           if (phii.ne.phii) phii=150.0
20961 #else
20962           phii=phi(i)
20963 #endif
20964           ityp1=ithetyp_nucl(itype(i-2,2))
20965           do k=1,nsingle_nucl
20966             cosph1(k)=dcos(k*phii)
20967             sinph1(k)=dsin(k*phii)
20968           enddo
20969         else
20970           phii=0.0d0
20971           ityp1=nthetyp_nucl+1
20972           do k=1,nsingle_nucl
20973             cosph1(k)=0.0d0
20974             sinph1(k)=0.0d0
20975           enddo
20976         endif
20977
20978         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20979 #ifdef OSF
20980           phii1=phi(i+1)
20981           if (phii1.ne.phii1) phii1=150.0
20982           phii1=pinorm(phii1)
20983 #else
20984           phii1=phi(i+1)
20985 #endif
20986           ityp3=ithetyp_nucl(itype(i,2))
20987           do k=1,nsingle_nucl
20988             cosph2(k)=dcos(k*phii1)
20989             sinph2(k)=dsin(k*phii1)
20990           enddo
20991         else
20992           phii1=0.0d0
20993           ityp3=nthetyp_nucl+1
20994           do k=1,nsingle_nucl
20995             cosph2(k)=0.0d0
20996             sinph2(k)=0.0d0
20997           enddo
20998         endif
20999         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21000         do k=1,ndouble_nucl
21001           do l=1,k-1
21002             ccl=cosph1(l)*cosph2(k-l)
21003             ssl=sinph1(l)*sinph2(k-l)
21004             scl=sinph1(l)*cosph2(k-l)
21005             csl=cosph1(l)*sinph2(k-l)
21006             cosph1ph2(l,k)=ccl-ssl
21007             cosph1ph2(k,l)=ccl+ssl
21008             sinph1ph2(l,k)=scl+csl
21009             sinph1ph2(k,l)=scl-csl
21010           enddo
21011         enddo
21012         if (lprn) then
21013         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21014          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21015         write (iout,*) "coskt and sinkt",nntheterm_nucl
21016         do k=1,nntheterm_nucl
21017           write (iout,*) k,coskt(k),sinkt(k)
21018         enddo
21019         endif
21020         do k=1,ntheterm_nucl
21021           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21022           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21023            *coskt(k)
21024           if (lprn)&
21025          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21026           " ethetai",ethetai
21027         enddo
21028         if (lprn) then
21029         write (iout,*) "cosph and sinph"
21030         do k=1,nsingle_nucl
21031           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21032         enddo
21033         write (iout,*) "cosph1ph2 and sinph2ph2"
21034         do k=2,ndouble_nucl
21035           do l=1,k-1
21036             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21037               sinph1ph2(l,k),sinph1ph2(k,l)
21038           enddo
21039         enddo
21040         write(iout,*) "ethetai",ethetai
21041         endif
21042         do m=1,ntheterm2_nucl
21043           do k=1,nsingle_nucl
21044             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21045               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21046               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21047               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21048             ethetai=ethetai+sinkt(m)*aux
21049             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21050             dephii=dephii+k*sinkt(m)*(&
21051                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21052                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21053             dephii1=dephii1+k*sinkt(m)*(&
21054                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21055                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21056             if (lprn) &
21057            write (iout,*) "m",m," k",k," bbthet",&
21058               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21059               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21060               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21061               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21062           enddo
21063         enddo
21064         if (lprn) &
21065         write(iout,*) "ethetai",ethetai
21066         do m=1,ntheterm3_nucl
21067           do k=2,ndouble_nucl
21068             do l=1,k-1
21069               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21070                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21071                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21072                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21073               ethetai=ethetai+sinkt(m)*aux
21074               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21075               dephii=dephii+l*sinkt(m)*(&
21076                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21077                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21078                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21079                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21080               dephii1=dephii1+(k-l)*sinkt(m)*( &
21081                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21082                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21083                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21084                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21085               if (lprn) then
21086               write (iout,*) "m",m," k",k," l",l," ffthet", &
21087                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21088                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21089                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21090                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21091               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21092                  cosph1ph2(k,l)*sinkt(m),&
21093                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21094               endif
21095             enddo
21096           enddo
21097         enddo
21098 10      continue
21099         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21100         i,theta(i)*rad2deg,phii*rad2deg, &
21101         phii1*rad2deg,ethetai
21102         etheta_nucl=etheta_nucl+ethetai
21103 !        print *,i,"partial sum",etheta_nucl
21104         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21105         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21106         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21107       enddo
21108       return
21109       end subroutine ebend_nucl
21110 !----------------------------------------------------
21111       subroutine etor_nucl(etors_nucl)
21112 !      implicit real*8 (a-h,o-z)
21113 !      include 'DIMENSIONS'
21114 !      include 'COMMON.VAR'
21115 !      include 'COMMON.GEO'
21116 !      include 'COMMON.LOCAL'
21117 !      include 'COMMON.TORSION'
21118 !      include 'COMMON.INTERACT'
21119 !      include 'COMMON.DERIV'
21120 !      include 'COMMON.CHAIN'
21121 !      include 'COMMON.NAMES'
21122 !      include 'COMMON.IOUNITS'
21123 !      include 'COMMON.FFIELD'
21124 !      include 'COMMON.TORCNSTR'
21125 !      include 'COMMON.CONTROL'
21126       real(kind=8) :: etors_nucl,edihcnstr
21127       logical :: lprn
21128 !el local variables
21129       integer :: i,j,iblock,itori,itori1
21130       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21131                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21132 ! Set lprn=.true. for debugging
21133       lprn=.false.
21134 !     lprn=.true.
21135       etors_nucl=0.0D0
21136 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21137       do i=iphi_nucl_start,iphi_nucl_end
21138         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21139              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21140              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21141         etors_ii=0.0D0
21142         itori=itortyp_nucl(itype(i-2,2))
21143         itori1=itortyp_nucl(itype(i-1,2))
21144         phii=phi(i)
21145 !         print *,i,itori,itori1
21146         gloci=0.0D0
21147 !C Regular cosine and sine terms
21148         do j=1,nterm_nucl(itori,itori1)
21149           v1ij=v1_nucl(j,itori,itori1)
21150           v2ij=v2_nucl(j,itori,itori1)
21151           cosphi=dcos(j*phii)
21152           sinphi=dsin(j*phii)
21153           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21154           if (energy_dec) etors_ii=etors_ii+&
21155                      v1ij*cosphi+v2ij*sinphi
21156           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21157         enddo
21158 !C Lorentz terms
21159 !C                         v1
21160 !C  E = SUM ----------------------------------- - v1
21161 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21162 !C
21163         cosphi=dcos(0.5d0*phii)
21164         sinphi=dsin(0.5d0*phii)
21165         do j=1,nlor_nucl(itori,itori1)
21166           vl1ij=vlor1_nucl(j,itori,itori1)
21167           vl2ij=vlor2_nucl(j,itori,itori1)
21168           vl3ij=vlor3_nucl(j,itori,itori1)
21169           pom=vl2ij*cosphi+vl3ij*sinphi
21170           pom1=1.0d0/(pom*pom+1.0d0)
21171           etors_nucl=etors_nucl+vl1ij*pom1
21172           if (energy_dec) etors_ii=etors_ii+ &
21173                      vl1ij*pom1
21174           pom=-pom*pom1*pom1
21175           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21176         enddo
21177 !C Subtract the constant term
21178         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21179           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21180               'etor',i,etors_ii-v0_nucl(itori,itori1)
21181         if (lprn) &
21182        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21183        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21184        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21185         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21186 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21187       enddo
21188       return
21189       end subroutine etor_nucl
21190 !------------------------------------------------------------
21191       subroutine epp_nucl_sub(evdw1,ees)
21192 !C
21193 !C This subroutine calculates the average interaction energy and its gradient
21194 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21195 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21196 !C The potential depends both on the distance of peptide-group centers and on
21197 !C the orientation of the CA-CA virtual bonds.
21198 !C
21199       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21200       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21201       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21202                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21203                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21204       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21205                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21206       integer xshift,yshift,zshift
21207       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21208       real(kind=8) :: ees,eesij
21209 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21210       real(kind=8) scal_el /0.5d0/
21211       t_eelecij=0.0d0
21212       ees=0.0D0
21213       evdw1=0.0D0
21214       ind=0
21215 !c
21216 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21217 !c
21218 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21219       do i=iatel_s_nucl,iatel_e_nucl
21220         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21221         dxi=dc(1,i)
21222         dyi=dc(2,i)
21223         dzi=dc(3,i)
21224         dx_normi=dc_norm(1,i)
21225         dy_normi=dc_norm(2,i)
21226         dz_normi=dc_norm(3,i)
21227         xmedi=c(1,i)+0.5d0*dxi
21228         ymedi=c(2,i)+0.5d0*dyi
21229         zmedi=c(3,i)+0.5d0*dzi
21230           xmedi=dmod(xmedi,boxxsize)
21231           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21232           ymedi=dmod(ymedi,boxysize)
21233           if (ymedi.lt.0) ymedi=ymedi+boxysize
21234           zmedi=dmod(zmedi,boxzsize)
21235           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21236
21237         do j=ielstart_nucl(i),ielend_nucl(i)
21238           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21239           ind=ind+1
21240           dxj=dc(1,j)
21241           dyj=dc(2,j)
21242           dzj=dc(3,j)
21243 !          xj=c(1,j)+0.5D0*dxj-xmedi
21244 !          yj=c(2,j)+0.5D0*dyj-ymedi
21245 !          zj=c(3,j)+0.5D0*dzj-zmedi
21246           xj=c(1,j)+0.5D0*dxj
21247           yj=c(2,j)+0.5D0*dyj
21248           zj=c(3,j)+0.5D0*dzj
21249           xj=mod(xj,boxxsize)
21250           if (xj.lt.0) xj=xj+boxxsize
21251           yj=mod(yj,boxysize)
21252           if (yj.lt.0) yj=yj+boxysize
21253           zj=mod(zj,boxzsize)
21254           if (zj.lt.0) zj=zj+boxzsize
21255       isubchap=0
21256       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21257       xj_safe=xj
21258       yj_safe=yj
21259       zj_safe=zj
21260       do xshift=-1,1
21261       do yshift=-1,1
21262       do zshift=-1,1
21263           xj=xj_safe+xshift*boxxsize
21264           yj=yj_safe+yshift*boxysize
21265           zj=zj_safe+zshift*boxzsize
21266           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21267           if(dist_temp.lt.dist_init) then
21268             dist_init=dist_temp
21269             xj_temp=xj
21270             yj_temp=yj
21271             zj_temp=zj
21272             isubchap=1
21273           endif
21274        enddo
21275        enddo
21276        enddo
21277        if (isubchap.eq.1) then
21278 !C          print *,i,j
21279           xj=xj_temp-xmedi
21280           yj=yj_temp-ymedi
21281           zj=zj_temp-zmedi
21282        else
21283           xj=xj_safe-xmedi
21284           yj=yj_safe-ymedi
21285           zj=zj_safe-zmedi
21286        endif
21287
21288           rij=xj*xj+yj*yj+zj*zj
21289 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21290           fac=(r0pp**2/rij)**3
21291           ev1=epspp*fac*fac
21292           ev2=epspp*fac
21293           evdw1ij=ev1-2*ev2
21294           fac=(-ev1-evdw1ij)/rij
21295 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21296           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21297           evdw1=evdw1+evdw1ij
21298 !C
21299 !C Calculate contributions to the Cartesian gradient.
21300 !C
21301           ggg(1)=fac*xj
21302           ggg(2)=fac*yj
21303           ggg(3)=fac*zj
21304           do k=1,3
21305             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21306             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21307           enddo
21308 !c phoshate-phosphate electrostatic interactions
21309           rij=dsqrt(rij)
21310           fac=1.0d0/rij
21311           eesij=dexp(-BEES*rij)*fac
21312 !          write (2,*)"fac",fac," eesijpp",eesij
21313           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21314           ees=ees+eesij
21315 !c          fac=-eesij*fac
21316           fac=-(fac+BEES)*eesij*fac
21317           ggg(1)=fac*xj
21318           ggg(2)=fac*yj
21319           ggg(3)=fac*zj
21320 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21321 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21322 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21323           do k=1,3
21324             gelpp(k,i)=gelpp(k,i)-ggg(k)
21325             gelpp(k,j)=gelpp(k,j)+ggg(k)
21326           enddo
21327         enddo ! j
21328       enddo   ! i
21329 !c      ees=332.0d0*ees
21330       ees=AEES*ees
21331       do i=nnt,nct
21332 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21333         do k=1,3
21334           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21335 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21336           gelpp(k,i)=AEES*gelpp(k,i)
21337         enddo
21338 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21339       enddo
21340 !c      write (2,*) "total EES",ees
21341       return
21342       end subroutine epp_nucl_sub
21343 !---------------------------------------------------------------------
21344       subroutine epsb(evdwpsb,eelpsb)
21345 !      use comm_locel
21346 !C
21347 !C This subroutine calculates the excluded-volume interaction energy between
21348 !C peptide-group centers and side chains and its gradient in virtual-bond and
21349 !C side-chain vectors.
21350 !C
21351       real(kind=8),dimension(3):: ggg
21352       integer :: i,iint,j,k,iteli,itypj,subchap
21353       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21354                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21355       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21356                     dist_temp, dist_init
21357       integer xshift,yshift,zshift
21358
21359 !cd    print '(a)','Enter ESCP'
21360 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21361       eelpsb=0.0d0
21362       evdwpsb=0.0d0
21363 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21364       do i=iatscp_s_nucl,iatscp_e_nucl
21365         if (itype(i,2).eq.ntyp1_molec(2) &
21366          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21367         xi=0.5D0*(c(1,i)+c(1,i+1))
21368         yi=0.5D0*(c(2,i)+c(2,i+1))
21369         zi=0.5D0*(c(3,i)+c(3,i+1))
21370           xi=mod(xi,boxxsize)
21371           if (xi.lt.0) xi=xi+boxxsize
21372           yi=mod(yi,boxysize)
21373           if (yi.lt.0) yi=yi+boxysize
21374           zi=mod(zi,boxzsize)
21375           if (zi.lt.0) zi=zi+boxzsize
21376
21377         do iint=1,nscp_gr_nucl(i)
21378
21379         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21380           itypj=itype(j,2)
21381           if (itypj.eq.ntyp1_molec(2)) cycle
21382 !C Uncomment following three lines for SC-p interactions
21383 !c         xj=c(1,nres+j)-xi
21384 !c         yj=c(2,nres+j)-yi
21385 !c         zj=c(3,nres+j)-zi
21386 !C Uncomment following three lines for Ca-p interactions
21387 !          xj=c(1,j)-xi
21388 !          yj=c(2,j)-yi
21389 !          zj=c(3,j)-zi
21390           xj=c(1,j)
21391           yj=c(2,j)
21392           zj=c(3,j)
21393           xj=mod(xj,boxxsize)
21394           if (xj.lt.0) xj=xj+boxxsize
21395           yj=mod(yj,boxysize)
21396           if (yj.lt.0) yj=yj+boxysize
21397           zj=mod(zj,boxzsize)
21398           if (zj.lt.0) zj=zj+boxzsize
21399       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21400       xj_safe=xj
21401       yj_safe=yj
21402       zj_safe=zj
21403       subchap=0
21404       do xshift=-1,1
21405       do yshift=-1,1
21406       do zshift=-1,1
21407           xj=xj_safe+xshift*boxxsize
21408           yj=yj_safe+yshift*boxysize
21409           zj=zj_safe+zshift*boxzsize
21410           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21411           if(dist_temp.lt.dist_init) then
21412             dist_init=dist_temp
21413             xj_temp=xj
21414             yj_temp=yj
21415             zj_temp=zj
21416             subchap=1
21417           endif
21418        enddo
21419        enddo
21420        enddo
21421        if (subchap.eq.1) then
21422           xj=xj_temp-xi
21423           yj=yj_temp-yi
21424           zj=zj_temp-zi
21425        else
21426           xj=xj_safe-xi
21427           yj=yj_safe-yi
21428           zj=zj_safe-zi
21429        endif
21430
21431           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21432           fac=rrij**expon2
21433           e1=fac*fac*aad_nucl(itypj)
21434           e2=fac*bad_nucl(itypj)
21435           if (iabs(j-i) .le. 2) then
21436             e1=scal14*e1
21437             e2=scal14*e2
21438           endif
21439           evdwij=e1+e2
21440           evdwpsb=evdwpsb+evdwij
21441           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21442              'evdw2',i,j,evdwij,"tu4"
21443 !C
21444 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21445 !C
21446           fac=-(evdwij+e1)*rrij
21447           ggg(1)=xj*fac
21448           ggg(2)=yj*fac
21449           ggg(3)=zj*fac
21450           do k=1,3
21451             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21452             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21453           enddo
21454         enddo
21455
21456         enddo ! iint
21457       enddo ! i
21458       do i=1,nct
21459         do j=1,3
21460           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21461           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21462         enddo
21463       enddo
21464       return
21465       end subroutine epsb
21466
21467 !------------------------------------------------------
21468       subroutine esb_gb(evdwsb,eelsb)
21469       use comm_locel
21470       use calc_data_nucl
21471       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21472       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21473       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21474       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21475                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21476       integer :: ii
21477       logical lprn
21478       evdw=0.0D0
21479       eelsb=0.0d0
21480       ecorr=0.0d0
21481       evdwsb=0.0D0
21482       lprn=.false.
21483       ind=0
21484 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21485       do i=iatsc_s_nucl,iatsc_e_nucl
21486         num_conti=0
21487         num_conti2=0
21488         itypi=itype(i,2)
21489 !        PRINT *,"I=",i,itypi
21490         if (itypi.eq.ntyp1_molec(2)) cycle
21491         itypi1=itype(i+1,2)
21492         xi=c(1,nres+i)
21493         yi=c(2,nres+i)
21494         zi=c(3,nres+i)
21495           xi=dmod(xi,boxxsize)
21496           if (xi.lt.0) xi=xi+boxxsize
21497           yi=dmod(yi,boxysize)
21498           if (yi.lt.0) yi=yi+boxysize
21499           zi=dmod(zi,boxzsize)
21500           if (zi.lt.0) zi=zi+boxzsize
21501
21502         dxi=dc_norm(1,nres+i)
21503         dyi=dc_norm(2,nres+i)
21504         dzi=dc_norm(3,nres+i)
21505         dsci_inv=vbld_inv(i+nres)
21506 !C
21507 !C Calculate SC interaction energy.
21508 !C
21509         do iint=1,nint_gr_nucl(i)
21510 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21511           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21512             ind=ind+1
21513 !            print *,"JESTEM"
21514             itypj=itype(j,2)
21515             if (itypj.eq.ntyp1_molec(2)) cycle
21516             dscj_inv=vbld_inv(j+nres)
21517             sig0ij=sigma_nucl(itypi,itypj)
21518             chi1=chi_nucl(itypi,itypj)
21519             chi2=chi_nucl(itypj,itypi)
21520             chi12=chi1*chi2
21521             chip1=chip_nucl(itypi,itypj)
21522             chip2=chip_nucl(itypj,itypi)
21523             chip12=chip1*chip2
21524 !            xj=c(1,nres+j)-xi
21525 !            yj=c(2,nres+j)-yi
21526 !            zj=c(3,nres+j)-zi
21527            xj=c(1,nres+j)
21528            yj=c(2,nres+j)
21529            zj=c(3,nres+j)
21530           xj=dmod(xj,boxxsize)
21531           if (xj.lt.0) xj=xj+boxxsize
21532           yj=dmod(yj,boxysize)
21533           if (yj.lt.0) yj=yj+boxysize
21534           zj=dmod(zj,boxzsize)
21535           if (zj.lt.0) zj=zj+boxzsize
21536       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21537       xj_safe=xj
21538       yj_safe=yj
21539       zj_safe=zj
21540       subchap=0
21541       do xshift=-1,1
21542       do yshift=-1,1
21543       do zshift=-1,1
21544           xj=xj_safe+xshift*boxxsize
21545           yj=yj_safe+yshift*boxysize
21546           zj=zj_safe+zshift*boxzsize
21547           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21548           if(dist_temp.lt.dist_init) then
21549             dist_init=dist_temp
21550             xj_temp=xj
21551             yj_temp=yj
21552             zj_temp=zj
21553             subchap=1
21554           endif
21555        enddo
21556        enddo
21557        enddo
21558        if (subchap.eq.1) then
21559           xj=xj_temp-xi
21560           yj=yj_temp-yi
21561           zj=zj_temp-zi
21562        else
21563           xj=xj_safe-xi
21564           yj=yj_safe-yi
21565           zj=zj_safe-zi
21566        endif
21567
21568             dxj=dc_norm(1,nres+j)
21569             dyj=dc_norm(2,nres+j)
21570             dzj=dc_norm(3,nres+j)
21571             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21572             rij=dsqrt(rrij)
21573 !C Calculate angle-dependent terms of energy and contributions to their
21574 !C derivatives.
21575             erij(1)=xj*rij
21576             erij(2)=yj*rij
21577             erij(3)=zj*rij
21578             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21579             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21580             om12=dxi*dxj+dyi*dyj+dzi*dzj
21581             call sc_angular_nucl
21582             sigsq=1.0D0/sigsq
21583             sig=sig0ij*dsqrt(sigsq)
21584             rij_shift=1.0D0/rij-sig+sig0ij
21585 !            print *,rij_shift,"rij_shift"
21586 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21587 !c     &       " rij_shift",rij_shift
21588             if (rij_shift.le.0.0D0) then
21589               evdw=1.0D20
21590               return
21591             endif
21592             sigder=-sig*sigsq
21593 !c---------------------------------------------------------------
21594             rij_shift=1.0D0/rij_shift
21595             fac=rij_shift**expon
21596             e1=fac*fac*aa_nucl(itypi,itypj)
21597             e2=fac*bb_nucl(itypi,itypj)
21598             evdwij=eps1*eps2rt*(e1+e2)
21599 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21600 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21601             eps2der=evdwij
21602             evdwij=evdwij*eps2rt
21603             evdwsb=evdwsb+evdwij
21604             if (lprn) then
21605             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21606             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21607             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21608              restyp(itypi,2),i,restyp(itypj,2),j, &
21609              epsi,sigm,chi1,chi2,chip1,chip2, &
21610              eps1,eps2rt**2,sig,sig0ij, &
21611              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21612             evdwij
21613             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21614             endif
21615
21616             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21617                              'evdw',i,j,evdwij,"tu3"
21618
21619
21620 !C Calculate gradient components.
21621             e1=e1*eps1*eps2rt**2
21622             fac=-expon*(e1+evdwij)*rij_shift
21623             sigder=fac*sigder
21624             fac=rij*fac
21625 !c            fac=0.0d0
21626 !C Calculate the radial part of the gradient
21627             gg(1)=xj*fac
21628             gg(2)=yj*fac
21629             gg(3)=zj*fac
21630 !C Calculate angular part of the gradient.
21631             call sc_grad_nucl
21632             call eelsbij(eelij,num_conti2)
21633             if (energy_dec .and. &
21634            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21635           write (istat,'(e14.5)') evdwij
21636             eelsb=eelsb+eelij
21637           enddo      ! j
21638         enddo        ! iint
21639         num_cont_hb(i)=num_conti2
21640       enddo          ! i
21641 !c      write (iout,*) "Number of loop steps in EGB:",ind
21642 !cccc      energy_dec=.false.
21643       return
21644       end subroutine esb_gb
21645 !-------------------------------------------------------------------------------
21646       subroutine eelsbij(eesij,num_conti2)
21647       use comm_locel
21648       use calc_data_nucl
21649       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21650       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21651       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21652                     dist_temp, dist_init,rlocshield,fracinbuf
21653       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21654
21655 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21656       real(kind=8) scal_el /0.5d0/
21657       integer :: iteli,itelj,kkk,kkll,m,isubchap
21658       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21659       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21660       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21661                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21662                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21663                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21664                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21665                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21666                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21667                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21668       ind=ind+1
21669       itypi=itype(i,2)
21670       itypj=itype(j,2)
21671 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21672       ael6i=ael6_nucl(itypi,itypj)
21673       ael3i=ael3_nucl(itypi,itypj)
21674       ael63i=ael63_nucl(itypi,itypj)
21675       ael32i=ael32_nucl(itypi,itypj)
21676 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21677 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21678       dxj=dc(1,j+nres)
21679       dyj=dc(2,j+nres)
21680       dzj=dc(3,j+nres)
21681       dx_normi=dc_norm(1,i+nres)
21682       dy_normi=dc_norm(2,i+nres)
21683       dz_normi=dc_norm(3,i+nres)
21684       dx_normj=dc_norm(1,j+nres)
21685       dy_normj=dc_norm(2,j+nres)
21686       dz_normj=dc_norm(3,j+nres)
21687 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21688 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21689 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21690       if (ipot_nucl.ne.2) then
21691         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21692         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21693         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21694       else
21695         cosa=om12
21696         cosb=om1
21697         cosg=om2
21698       endif
21699       r3ij=rij*rrij
21700       r6ij=r3ij*r3ij
21701       fac=cosa-3.0D0*cosb*cosg
21702       facfac=fac*fac
21703       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21704       fac3=ael6i*r6ij
21705       fac4=ael3i*r3ij
21706       fac5=ael63i*r6ij
21707       fac6=ael32i*r6ij
21708 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21709 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21710       el1=fac3*(4.0D0+facfac-fac1)
21711       el2=fac4*fac
21712       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21713       el4=fac6*facfac
21714       eesij=el1+el2+el3+el4
21715 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21716       ees0ij=4.0D0+facfac-fac1
21717
21718       if (energy_dec) then
21719           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21720           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21721            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21722            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21723            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21724           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21725       endif
21726
21727 !C
21728 !C Calculate contributions to the Cartesian gradient.
21729 !C
21730       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21731       fac1=fac
21732 !c      erij(1)=xj*rmij
21733 !c      erij(2)=yj*rmij
21734 !c      erij(3)=zj*rmij
21735 !*
21736 !* Radial derivatives. First process both termini of the fragment (i,j)
21737 !*
21738       ggg(1)=facel*xj
21739       ggg(2)=facel*yj
21740       ggg(3)=facel*zj
21741       do k=1,3
21742         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21743         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21744         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21745         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21746       enddo
21747 !*
21748 !* Angular part
21749 !*
21750       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21751       fac4=-3.0D0*fac4
21752       fac3=-6.0D0*fac3
21753       fac5= 6.0d0*fac5
21754       fac6=-6.0d0*fac6
21755       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21756        fac6*fac1*cosg
21757       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21758        fac6*fac1*cosb
21759       do k=1,3
21760         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21761         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21762       enddo
21763       do k=1,3
21764         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21765       enddo
21766       do k=1,3
21767         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21768              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21769              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21770         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21771              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21772              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21773         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21774         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21775       enddo
21776 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21777        IF ( j.gt.i+1 .and.&
21778           num_conti.le.maxconts) THEN
21779 !C
21780 !C Calculate the contact function. The ith column of the array JCONT will
21781 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21782 !C greater than I). The arrays FACONT and GACONT will contain the values of
21783 !C the contact function and its derivative.
21784         r0ij=2.20D0*sigma(itypi,itypj)
21785 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21786         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21787 !c        write (2,*) "fcont",fcont
21788         if (fcont.gt.0.0D0) then
21789           num_conti=num_conti+1
21790           num_conti2=num_conti2+1
21791
21792           if (num_conti.gt.maxconts) then
21793             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21794                           ' will skip next contacts for this conf.'
21795           else
21796             jcont_hb(num_conti,i)=j
21797 !c            write (iout,*) "num_conti",num_conti,
21798 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21799 !C Calculate contact energies
21800             cosa4=4.0D0*cosa
21801             wij=cosa-3.0D0*cosb*cosg
21802             cosbg1=cosb+cosg
21803             cosbg2=cosb-cosg
21804             fac3=dsqrt(-ael6i)*r3ij
21805 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21806             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21807             if (ees0tmp.gt.0) then
21808               ees0pij=dsqrt(ees0tmp)
21809             else
21810               ees0pij=0
21811             endif
21812             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21813             if (ees0tmp.gt.0) then
21814               ees0mij=dsqrt(ees0tmp)
21815             else
21816               ees0mij=0
21817             endif
21818             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21819             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21820 !c            write (iout,*) "i",i," j",j,
21821 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21822             ees0pij1=fac3/ees0pij
21823             ees0mij1=fac3/ees0mij
21824             fac3p=-3.0D0*fac3*rrij
21825             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21826             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21827             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21828             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21829             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21830             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21831             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21832             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21833             ecosap=ecosa1+ecosa2
21834             ecosbp=ecosb1+ecosb2
21835             ecosgp=ecosg1+ecosg2
21836             ecosam=ecosa1-ecosa2
21837             ecosbm=ecosb1-ecosb2
21838             ecosgm=ecosg1-ecosg2
21839 !C End diagnostics
21840             facont_hb(num_conti,i)=fcont
21841             fprimcont=fprimcont/rij
21842             do k=1,3
21843               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21844               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21845             enddo
21846             gggp(1)=gggp(1)+ees0pijp*xj
21847             gggp(2)=gggp(2)+ees0pijp*yj
21848             gggp(3)=gggp(3)+ees0pijp*zj
21849             gggm(1)=gggm(1)+ees0mijp*xj
21850             gggm(2)=gggm(2)+ees0mijp*yj
21851             gggm(3)=gggm(3)+ees0mijp*zj
21852 !C Derivatives due to the contact function
21853             gacont_hbr(1,num_conti,i)=fprimcont*xj
21854             gacont_hbr(2,num_conti,i)=fprimcont*yj
21855             gacont_hbr(3,num_conti,i)=fprimcont*zj
21856             do k=1,3
21857 !c
21858 !c Gradient of the correlation terms
21859 !c
21860               gacontp_hb1(k,num_conti,i)= &
21861              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21862             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21863               gacontp_hb2(k,num_conti,i)= &
21864              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21865             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21866               gacontp_hb3(k,num_conti,i)=gggp(k)
21867               gacontm_hb1(k,num_conti,i)= &
21868              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21869             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21870               gacontm_hb2(k,num_conti,i)= &
21871              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21872             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21873               gacontm_hb3(k,num_conti,i)=gggm(k)
21874             enddo
21875           endif
21876         endif
21877       ENDIF
21878       return
21879       end subroutine eelsbij
21880 !------------------------------------------------------------------
21881       subroutine sc_grad_nucl
21882       use comm_locel
21883       use calc_data_nucl
21884       real(kind=8),dimension(3) :: dcosom1,dcosom2
21885       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21886       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21887       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21888       do k=1,3
21889         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21890         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21891       enddo
21892       do k=1,3
21893         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21894       enddo
21895       do k=1,3
21896         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21897                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21898                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21899         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21900                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21901                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21902       enddo
21903 !C
21904 !C Calculate the components of the gradient in DC and X
21905 !C
21906       do l=1,3
21907         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21908         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21909       enddo
21910       return
21911       end subroutine sc_grad_nucl
21912 !-----------------------------------------------------------------------
21913       subroutine esb(esbloc)
21914 !C Calculate the local energy of a side chain and its derivatives in the
21915 !C corresponding virtual-bond valence angles THETA and the spherical angles
21916 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21917 !C added by Urszula Kozlowska. 07/11/2007
21918 !C
21919       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21920       real(kind=8),dimension(9):: x
21921      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21922       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21923       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21924       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21925        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21926        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21927        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21928        integer::it,nlobit,i,j,k
21929 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21930       delta=0.02d0*pi
21931       esbloc=0.0D0
21932       do i=loc_start_nucl,loc_end_nucl
21933         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21934         costtab(i+1) =dcos(theta(i+1))
21935         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21936         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21937         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21938         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21939         cosfac=dsqrt(cosfac2)
21940         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21941         sinfac=dsqrt(sinfac2)
21942         it=itype(i,2)
21943         if (it.eq.10) goto 1
21944
21945 !c
21946 !C  Compute the axes of tghe local cartesian coordinates system; store in
21947 !c   x_prime, y_prime and z_prime
21948 !c
21949         do j=1,3
21950           x_prime(j) = 0.00
21951           y_prime(j) = 0.00
21952           z_prime(j) = 0.00
21953         enddo
21954 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21955 !C     &   dc_norm(3,i+nres)
21956         do j = 1,3
21957           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21958           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21959         enddo
21960         do j = 1,3
21961           z_prime(j) = -uz(j,i-1)
21962 !           z_prime(j)=0.0
21963         enddo
21964
21965         xx=0.0d0
21966         yy=0.0d0
21967         zz=0.0d0
21968         do j = 1,3
21969           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21970           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21971           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21972         enddo
21973
21974         xxtab(i)=xx
21975         yytab(i)=yy
21976         zztab(i)=zz
21977          it=itype(i,2)
21978         do j = 1,9
21979           x(j) = sc_parmin_nucl(j,it)
21980         enddo
21981 #ifdef CHECK_COORD
21982 !Cc diagnostics - remove later
21983         xx1 = dcos(alph(2))
21984         yy1 = dsin(alph(2))*dcos(omeg(2))
21985         zz1 = -dsin(alph(2))*dsin(omeg(2))
21986         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21987          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21988          xx1,yy1,zz1
21989 !C,"  --- ", xx_w,yy_w,zz_w
21990 !c end diagnostics
21991 #endif
21992         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21993         esbloc = esbloc + sumene
21994         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21995 !        print *,"enecomp",sumene,sumene2
21996 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21997 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21998 #ifdef DEBUG
21999         write (2,*) "x",(x(k),k=1,9)
22000 !C
22001 !C This section to check the numerical derivatives of the energy of ith side
22002 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22003 !C #define DEBUG in the code to turn it on.
22004 !C
22005         write (2,*) "sumene               =",sumene
22006         aincr=1.0d-7
22007         xxsave=xx
22008         xx=xx+aincr
22009         write (2,*) xx,yy,zz
22010         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22011         de_dxx_num=(sumenep-sumene)/aincr
22012         xx=xxsave
22013         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22014         yysave=yy
22015         yy=yy+aincr
22016         write (2,*) xx,yy,zz
22017         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22018         de_dyy_num=(sumenep-sumene)/aincr
22019         yy=yysave
22020         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22021         zzsave=zz
22022         zz=zz+aincr
22023         write (2,*) xx,yy,zz
22024         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22025         de_dzz_num=(sumenep-sumene)/aincr
22026         zz=zzsave
22027         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22028         costsave=cost2tab(i+1)
22029         sintsave=sint2tab(i+1)
22030         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22031         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22032         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22033         de_dt_num=(sumenep-sumene)/aincr
22034         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22035         cost2tab(i+1)=costsave
22036         sint2tab(i+1)=sintsave
22037 !C End of diagnostics section.
22038 #endif
22039 !C
22040 !C Compute the gradient of esc
22041 !C
22042         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22043         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22044         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22045         de_dtt=0.0d0
22046 #ifdef DEBUG
22047         write (2,*) "x",(x(k),k=1,9)
22048         write (2,*) "xx",xx," yy",yy," zz",zz
22049         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22050           " de_zz   ",de_zz," de_tt   ",de_tt
22051         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22052           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22053 #endif
22054 !C
22055        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22056        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22057        cosfac2xx=cosfac2*xx
22058        sinfac2yy=sinfac2*yy
22059        do k = 1,3
22060          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22061            vbld_inv(i+1)
22062          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22063            vbld_inv(i)
22064          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22065          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22066 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22067 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22068 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22069 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22070          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22071          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22072          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22073          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22074          dZZ_Ci1(k)=0.0d0
22075          dZZ_Ci(k)=0.0d0
22076          do j=1,3
22077            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22078            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22079          enddo
22080
22081          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22082          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22083          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22084 !c
22085          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22086          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22087        enddo
22088
22089        do k=1,3
22090          dXX_Ctab(k,i)=dXX_Ci(k)
22091          dXX_C1tab(k,i)=dXX_Ci1(k)
22092          dYY_Ctab(k,i)=dYY_Ci(k)
22093          dYY_C1tab(k,i)=dYY_Ci1(k)
22094          dZZ_Ctab(k,i)=dZZ_Ci(k)
22095          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22096          dXX_XYZtab(k,i)=dXX_XYZ(k)
22097          dYY_XYZtab(k,i)=dYY_XYZ(k)
22098          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22099        enddo
22100        do k = 1,3
22101 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22102 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22103 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22104 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22105 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22106 !c     &    dt_dci(k)
22107 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22108 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22109          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22110          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22111          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22112          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22113          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22114          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22115 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22116        enddo
22117 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22118 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22119
22120 !C to check gradient call subroutine check_grad
22121
22122     1 continue
22123       enddo
22124       return
22125       end subroutine esb
22126 !=-------------------------------------------------------
22127       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22128 !      implicit none
22129       real(kind=8),dimension(9):: x(9)
22130        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22131       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22132       integer i
22133 !c      write (2,*) "enesc"
22134 !c      write (2,*) "x",(x(i),i=1,9)
22135 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22136       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22137         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22138         + x(9)*yy*zz
22139       enesc_nucl=sumene
22140       return
22141       end function enesc_nucl
22142 !-----------------------------------------------------------------------------
22143       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22144 #ifdef MPI
22145       include 'mpif.h'
22146       integer,parameter :: max_cont=2000
22147       integer,parameter:: max_dim=2*(8*3+6)
22148       integer, parameter :: msglen1=max_cont*max_dim
22149       integer,parameter :: msglen2=2*msglen1
22150       integer source,CorrelType,CorrelID,Error
22151       real(kind=8) :: buffer(max_cont,max_dim)
22152       integer status(MPI_STATUS_SIZE)
22153       integer :: ierror,nbytes
22154 #endif
22155       real(kind=8),dimension(3):: gx(3),gx1(3)
22156       real(kind=8) :: time00
22157       logical lprn,ldone
22158       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22159       real(kind=8) ecorr,ecorr3
22160       integer :: n_corr,n_corr1,mm,msglen
22161 !C Set lprn=.true. for debugging
22162       lprn=.false.
22163       n_corr=0
22164       n_corr1=0
22165 #ifdef MPI
22166       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22167
22168       if (nfgtasks.le.1) goto 30
22169       if (lprn) then
22170         write (iout,'(a)') 'Contact function values:'
22171         do i=nnt,nct-1
22172           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22173          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22174          j=1,num_cont_hb(i))
22175         enddo
22176       endif
22177 !C Caution! Following code assumes that electrostatic interactions concerning
22178 !C a given atom are split among at most two processors!
22179       CorrelType=477
22180       CorrelID=fg_rank+1
22181       ldone=.false.
22182       do i=1,max_cont
22183         do j=1,max_dim
22184           buffer(i,j)=0.0D0
22185         enddo
22186       enddo
22187       mm=mod(fg_rank,2)
22188 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22189       if (mm) 20,20,10
22190    10 continue
22191 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22192       if (fg_rank.gt.0) then
22193 !C Send correlation contributions to the preceding processor
22194         msglen=msglen1
22195         nn=num_cont_hb(iatel_s_nucl)
22196         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22197 !c        write (*,*) 'The BUFFER array:'
22198 !c        do i=1,nn
22199 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22200 !c        enddo
22201         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22202           msglen=msglen2
22203           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22204 !C Clear the contacts of the atom passed to the neighboring processor
22205         nn=num_cont_hb(iatel_s_nucl+1)
22206 !c        do i=1,nn
22207 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22208 !c        enddo
22209             num_cont_hb(iatel_s_nucl)=0
22210         endif
22211 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22212 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22213 !cd   & ' msglen=',msglen
22214 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22215 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22216 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22217         time00=MPI_Wtime()
22218         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22219          CorrelType,FG_COMM,IERROR)
22220         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22221 !cd      write (iout,*) 'Processor ',fg_rank,
22222 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22223 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22224 !c        write (*,*) 'Processor ',fg_rank,
22225 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22226 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22227 !c        msglen=msglen1
22228       endif ! (fg_rank.gt.0)
22229       if (ldone) goto 30
22230       ldone=.true.
22231    20 continue
22232 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22233       if (fg_rank.lt.nfgtasks-1) then
22234 !C Receive correlation contributions from the next processor
22235         msglen=msglen1
22236         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22237 !cd      write (iout,*) 'Processor',fg_rank,
22238 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22239 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22240 !c        write (*,*) 'Processor',fg_rank,
22241 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22242 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22243         time00=MPI_Wtime()
22244         nbytes=-1
22245         do while (nbytes.le.0)
22246           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22247           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22248         enddo
22249 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22250         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22251          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22252         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22253 !c        write (*,*) 'Processor',fg_rank,
22254 !c     &' has received correlation contribution from processor',fg_rank+1,
22255 !c     & ' msglen=',msglen,' nbytes=',nbytes
22256 !c        write (*,*) 'The received BUFFER array:'
22257 !c        do i=1,max_cont
22258 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22259 !c        enddo
22260         if (msglen.eq.msglen1) then
22261           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22262         else if (msglen.eq.msglen2)  then
22263           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22264           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22265         else
22266           write (iout,*) &
22267       'ERROR!!!! message length changed while processing correlations.'
22268           write (*,*) &
22269       'ERROR!!!! message length changed while processing correlations.'
22270           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22271         endif ! msglen.eq.msglen1
22272       endif ! fg_rank.lt.nfgtasks-1
22273       if (ldone) goto 30
22274       ldone=.true.
22275       goto 10
22276    30 continue
22277 #endif
22278       if (lprn) then
22279         write (iout,'(a)') 'Contact function values:'
22280         do i=nnt_molec(2),nct_molec(2)-1
22281           write (iout,'(2i3,50(1x,i2,f5.2))') &
22282          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22283          j=1,num_cont_hb(i))
22284         enddo
22285       endif
22286       ecorr=0.0D0
22287       ecorr3=0.0d0
22288 !C Remove the loop below after debugging !!!
22289 !      do i=nnt_molec(2),nct_molec(2)
22290 !        do j=1,3
22291 !          gradcorr_nucl(j,i)=0.0D0
22292 !          gradxorr_nucl(j,i)=0.0D0
22293 !          gradcorr3_nucl(j,i)=0.0D0
22294 !          gradxorr3_nucl(j,i)=0.0D0
22295 !        enddo
22296 !      enddo
22297 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22298 !C Calculate the local-electrostatic correlation terms
22299       do i=iatsc_s_nucl,iatsc_e_nucl
22300         i1=i+1
22301         num_conti=num_cont_hb(i)
22302         num_conti1=num_cont_hb(i+1)
22303 !        print *,i,num_conti,num_conti1
22304         do jj=1,num_conti
22305           j=jcont_hb(jj,i)
22306           do kk=1,num_conti1
22307             j1=jcont_hb(kk,i1)
22308 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22309 !c     &         ' jj=',jj,' kk=',kk
22310             if (j1.eq.j+1 .or. j1.eq.j-1) then
22311 !C
22312 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22313 !C The system gains extra energy.
22314 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22315 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22316 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22317 !C
22318               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22319               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22320                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22321               n_corr=n_corr+1
22322             else if (j1.eq.j) then
22323 !C
22324 !C Contacts I-J and I-(J+1) occur simultaneously.
22325 !C The system loses extra energy.
22326 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22327 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22328 !C Need to implement full formulas 32 from Liwo et al., 1998.
22329 !C
22330 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22331 !c     &         ' jj=',jj,' kk=',kk
22332               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22333             endif
22334           enddo ! kk
22335           do kk=1,num_conti
22336             j1=jcont_hb(kk,i)
22337 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22338 !c     &         ' jj=',jj,' kk=',kk
22339             if (j1.eq.j+1) then
22340 !C Contacts I-J and (I+1)-J occur simultaneously.
22341 !C The system loses extra energy.
22342               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22343             endif ! j1==j+1
22344           enddo ! kk
22345         enddo ! jj
22346       enddo ! i
22347       return
22348       end subroutine multibody_hb_nucl
22349 !-----------------------------------------------------------
22350       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22351 !      implicit real*8 (a-h,o-z)
22352 !      include 'DIMENSIONS'
22353 !      include 'COMMON.IOUNITS'
22354 !      include 'COMMON.DERIV'
22355 !      include 'COMMON.INTERACT'
22356 !      include 'COMMON.CONTACTS'
22357       real(kind=8),dimension(3) :: gx,gx1
22358       logical :: lprn
22359 !el local variables
22360       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22361       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22362                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22363                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22364                    rlocshield
22365
22366       lprn=.false.
22367       eij=facont_hb(jj,i)
22368       ekl=facont_hb(kk,k)
22369       ees0pij=ees0p(jj,i)
22370       ees0pkl=ees0p(kk,k)
22371       ees0mij=ees0m(jj,i)
22372       ees0mkl=ees0m(kk,k)
22373       ekont=eij*ekl
22374       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22375 !      print *,"ehbcorr_nucl",ekont,ees
22376 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22377 !C Following 4 lines for diagnostics.
22378 !cd    ees0pkl=0.0D0
22379 !cd    ees0pij=1.0D0
22380 !cd    ees0mkl=0.0D0
22381 !cd    ees0mij=1.0D0
22382 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22383 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22384 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22385 !C Calculate the multi-body contribution to energy.
22386 !      ecorr_nucl=ecorr_nucl+ekont*ees
22387 !C Calculate multi-body contributions to the gradient.
22388       coeffpees0pij=coeffp*ees0pij
22389       coeffmees0mij=coeffm*ees0mij
22390       coeffpees0pkl=coeffp*ees0pkl
22391       coeffmees0mkl=coeffm*ees0mkl
22392       do ll=1,3
22393         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22394        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22395        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22396         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22397         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22398         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22399         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22400         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22401         coeffmees0mij*gacontm_hb1(ll,kk,k))
22402         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22403         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22404         coeffmees0mij*gacontm_hb2(ll,kk,k))
22405         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22406           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22407           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22408         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22409         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22410         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22411           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22412           coeffmees0mij*gacontm_hb3(ll,kk,k))
22413         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22414         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22415         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22416         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22417         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22418         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22419       enddo
22420       ehbcorr_nucl=ekont*ees
22421       return
22422       end function ehbcorr_nucl
22423 !-------------------------------------------------------------------------
22424
22425      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22426 !      implicit real*8 (a-h,o-z)
22427 !      include 'DIMENSIONS'
22428 !      include 'COMMON.IOUNITS'
22429 !      include 'COMMON.DERIV'
22430 !      include 'COMMON.INTERACT'
22431 !      include 'COMMON.CONTACTS'
22432       real(kind=8),dimension(3) :: gx,gx1
22433       logical :: lprn
22434 !el local variables
22435       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22436       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22437                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22438                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22439                    rlocshield
22440
22441       lprn=.false.
22442       eij=facont_hb(jj,i)
22443       ekl=facont_hb(kk,k)
22444       ees0pij=ees0p(jj,i)
22445       ees0pkl=ees0p(kk,k)
22446       ees0mij=ees0m(jj,i)
22447       ees0mkl=ees0m(kk,k)
22448       ekont=eij*ekl
22449       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22450 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22451 !C Following 4 lines for diagnostics.
22452 !cd    ees0pkl=0.0D0
22453 !cd    ees0pij=1.0D0
22454 !cd    ees0mkl=0.0D0
22455 !cd    ees0mij=1.0D0
22456 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22457 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22458 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22459 !C Calculate the multi-body contribution to energy.
22460 !      ecorr=ecorr+ekont*ees
22461 !C Calculate multi-body contributions to the gradient.
22462       coeffpees0pij=coeffp*ees0pij
22463       coeffmees0mij=coeffm*ees0mij
22464       coeffpees0pkl=coeffp*ees0pkl
22465       coeffmees0mkl=coeffm*ees0mkl
22466       do ll=1,3
22467         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22468        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22469        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22470         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22471         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22472         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22473         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22474         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22475         coeffmees0mij*gacontm_hb1(ll,kk,k))
22476         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22477         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22478         coeffmees0mij*gacontm_hb2(ll,kk,k))
22479         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22480           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22481           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22482         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22483         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22484         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22485           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22486           coeffmees0mij*gacontm_hb3(ll,kk,k))
22487         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22488         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22489         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22490         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22491         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22492         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22493       enddo
22494       ehbcorr3_nucl=ekont*ees
22495       return
22496       end function ehbcorr3_nucl
22497 #ifdef MPI
22498       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22499       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22500       real(kind=8):: buffer(dimen1,dimen2)
22501       num_kont=num_cont_hb(atom)
22502       do i=1,num_kont
22503         do k=1,8
22504           do j=1,3
22505             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22506           enddo ! j
22507         enddo ! k
22508         buffer(i,indx+25)=facont_hb(i,atom)
22509         buffer(i,indx+26)=ees0p(i,atom)
22510         buffer(i,indx+27)=ees0m(i,atom)
22511         buffer(i,indx+28)=d_cont(i,atom)
22512         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22513       enddo ! i
22514       buffer(1,indx+30)=dfloat(num_kont)
22515       return
22516       end subroutine pack_buffer
22517 !c------------------------------------------------------------------------------
22518       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22519       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22520       real(kind=8):: buffer(dimen1,dimen2)
22521 !      double precision zapas
22522 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22523 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22524 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22525 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22526       num_kont=buffer(1,indx+30)
22527       num_kont_old=num_cont_hb(atom)
22528       num_cont_hb(atom)=num_kont+num_kont_old
22529       do i=1,num_kont
22530         ii=i+num_kont_old
22531         do k=1,8
22532           do j=1,3
22533             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22534           enddo ! j
22535         enddo ! k
22536         facont_hb(ii,atom)=buffer(i,indx+25)
22537         ees0p(ii,atom)=buffer(i,indx+26)
22538         ees0m(ii,atom)=buffer(i,indx+27)
22539         d_cont(i,atom)=buffer(i,indx+28)
22540         jcont_hb(ii,atom)=buffer(i,indx+29)
22541       enddo ! i
22542       return
22543       end subroutine unpack_buffer
22544 !c------------------------------------------------------------------------------
22545 #endif
22546       subroutine ecatcat(ecationcation)
22547         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22548         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22549         r7,r4,ecationcation,k0,rcal
22550         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22551         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22552         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22553         gg,r
22554
22555         ecationcation=0.0d0
22556         if (nres_molec(5).eq.0) return
22557         rcat0=3.472
22558         epscalc=0.05
22559         r06 = rcat0**6
22560         r012 = r06**2
22561         k0 = 332.0*(2.0*2.0)/80.0
22562         itmp=0
22563
22564         do i=1,4
22565         itmp=itmp+nres_molec(i)
22566         enddo
22567 !        write(iout,*) "itmp",itmp
22568         do i=itmp+1,itmp+nres_molec(5)-1
22569
22570         xi=c(1,i)
22571         yi=c(2,i)
22572         zi=c(3,i)
22573
22574           xi=mod(xi,boxxsize)
22575           if (xi.lt.0) xi=xi+boxxsize
22576           yi=mod(yi,boxysize)
22577           if (yi.lt.0) yi=yi+boxysize
22578           zi=mod(zi,boxzsize)
22579           if (zi.lt.0) zi=zi+boxzsize
22580
22581           do j=i+1,itmp+nres_molec(5)
22582 !           print *,i,j,'catcat'
22583            xj=c(1,j)
22584            yj=c(2,j)
22585            zj=c(3,j)
22586           xj=dmod(xj,boxxsize)
22587           if (xj.lt.0) xj=xj+boxxsize
22588           yj=dmod(yj,boxysize)
22589           if (yj.lt.0) yj=yj+boxysize
22590           zj=dmod(zj,boxzsize)
22591           if (zj.lt.0) zj=zj+boxzsize
22592 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22593       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22594       xj_safe=xj
22595       yj_safe=yj
22596       zj_safe=zj
22597       subchap=0
22598       do xshift=-1,1
22599       do yshift=-1,1
22600       do zshift=-1,1
22601           xj=xj_safe+xshift*boxxsize
22602           yj=yj_safe+yshift*boxysize
22603           zj=zj_safe+zshift*boxzsize
22604           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22605           if(dist_temp.lt.dist_init) then
22606             dist_init=dist_temp
22607             xj_temp=xj
22608             yj_temp=yj
22609             zj_temp=zj
22610             subchap=1
22611           endif
22612        enddo
22613        enddo
22614        enddo
22615        if (subchap.eq.1) then
22616           xj=xj_temp-xi
22617           yj=yj_temp-yi
22618           zj=zj_temp-zi
22619        else
22620           xj=xj_safe-xi
22621           yj=yj_safe-yi
22622           zj=zj_safe-zi
22623        endif
22624        rcal =xj**2+yj**2+zj**2
22625         ract=sqrt(rcal)
22626 !        rcat0=3.472
22627 !        epscalc=0.05
22628 !        r06 = rcat0**6
22629 !        r012 = r06**2
22630 !        k0 = 332*(2*2)/80
22631         Evan1cat=epscalc*(r012/rcal**6)
22632         Evan2cat=epscalc*2*(r06/rcal**3)
22633         Eeleccat=k0/ract
22634         r7 = rcal**7
22635         r4 = rcal**4
22636         r(1)=xj
22637         r(2)=yj
22638         r(3)=zj
22639         do k=1,3
22640           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22641           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22642           dEeleccat(k)=-k0*r(k)/ract**3
22643         enddo
22644         do k=1,3
22645           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22646           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22647           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22648         enddo
22649
22650 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22651         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22652        enddo
22653        enddo
22654        return
22655        end subroutine ecatcat
22656 !---------------------------------------------------------------------------
22657        subroutine ecat_prot(ecation_prot)
22658        integer i,j,k,subchap,itmp,inum
22659         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22660         r7,r4,ecationcation
22661         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22662         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22663         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22664         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22665         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22666         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22667         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22668         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22669         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22670         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22671         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22672         ndiv,ndivi
22673         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22674         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22675         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22676         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22677         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22678         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22679         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22680         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22681         dEvan1Cat
22682         real(kind=8),dimension(6) :: vcatprm
22683         ecation_prot=0.0d0
22684 ! first lets calculate interaction with peptide groups
22685         if (nres_molec(5).eq.0) return
22686         itmp=0
22687         do i=1,4
22688         itmp=itmp+nres_molec(i)
22689         enddo
22690 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22691         do i=ibond_start,ibond_end
22692 !         cycle
22693          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22694         xi=0.5d0*(c(1,i)+c(1,i+1))
22695         yi=0.5d0*(c(2,i)+c(2,i+1))
22696         zi=0.5d0*(c(3,i)+c(3,i+1))
22697           xi=mod(xi,boxxsize)
22698           if (xi.lt.0) xi=xi+boxxsize
22699           yi=mod(yi,boxysize)
22700           if (yi.lt.0) yi=yi+boxysize
22701           zi=mod(zi,boxzsize)
22702           if (zi.lt.0) zi=zi+boxzsize
22703
22704          do j=itmp+1,itmp+nres_molec(5)
22705 !           print *,"WTF",itmp,j,i
22706 ! all parameters were for Ca2+ to approximate single charge divide by two
22707          ndiv=1.0
22708          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22709          wconst=78*ndiv
22710         wdip =1.092777950857032D2
22711         wdip=wdip/wconst
22712         wmodquad=-2.174122713004870D4
22713         wmodquad=wmodquad/wconst
22714         wquad1 = 3.901232068562804D1
22715         wquad1=wquad1/wconst
22716         wquad2 = 3
22717         wquad2=wquad2/wconst
22718         wvan1 = 0.1
22719         wvan2 = 6
22720 !        itmp=0
22721
22722            xj=c(1,j)
22723            yj=c(2,j)
22724            zj=c(3,j)
22725           xj=dmod(xj,boxxsize)
22726           if (xj.lt.0) xj=xj+boxxsize
22727           yj=dmod(yj,boxysize)
22728           if (yj.lt.0) yj=yj+boxysize
22729           zj=dmod(zj,boxzsize)
22730           if (zj.lt.0) zj=zj+boxzsize
22731       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22732       xj_safe=xj
22733       yj_safe=yj
22734       zj_safe=zj
22735       subchap=0
22736       do xshift=-1,1
22737       do yshift=-1,1
22738       do zshift=-1,1
22739           xj=xj_safe+xshift*boxxsize
22740           yj=yj_safe+yshift*boxysize
22741           zj=zj_safe+zshift*boxzsize
22742           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22743           if(dist_temp.lt.dist_init) then
22744             dist_init=dist_temp
22745             xj_temp=xj
22746             yj_temp=yj
22747             zj_temp=zj
22748             subchap=1
22749           endif
22750        enddo
22751        enddo
22752        enddo
22753        if (subchap.eq.1) then
22754           xj=xj_temp-xi
22755           yj=yj_temp-yi
22756           zj=zj_temp-zi
22757        else
22758           xj=xj_safe-xi
22759           yj=yj_safe-yi
22760           zj=zj_safe-zi
22761        endif
22762 !       enddo
22763 !       enddo
22764        rcpm = sqrt(xj**2+yj**2+zj**2)
22765        drcp_norm(1)=xj/rcpm
22766        drcp_norm(2)=yj/rcpm
22767        drcp_norm(3)=zj/rcpm
22768        dcmag=0.0
22769        do k=1,3
22770        dcmag=dcmag+dc(k,i)**2
22771        enddo
22772        dcmag=dsqrt(dcmag)
22773        do k=1,3
22774          myd_norm(k)=dc(k,i)/dcmag
22775        enddo
22776         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22777         drcp_norm(3)*myd_norm(3)
22778         rsecp = rcpm**2
22779         Ir = 1.0d0/rcpm
22780         Irsecp = 1.0d0/rsecp
22781         Irthrp = Irsecp/rcpm
22782         Irfourp = Irthrp/rcpm
22783         Irfiftp = Irfourp/rcpm
22784         Irsistp=Irfiftp/rcpm
22785         Irseven=Irsistp/rcpm
22786         Irtwelv=Irsistp*Irsistp
22787         Irthir=Irtwelv/rcpm
22788         sin2thet = (1-costhet*costhet)
22789         sinthet=sqrt(sin2thet)
22790         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22791              *sin2thet
22792         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22793              2*wvan2**6*Irsistp)
22794         ecation_prot = ecation_prot+E1+E2
22795 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22796         dE1dr = -2*costhet*wdip*Irthrp-&
22797          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22798         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22799           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22800         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22801         do k=1,3
22802           drdpep(k) = -drcp_norm(k)
22803           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22804           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22805           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22806           dEddci(k) = dEdcos*dcosddci(k)
22807         enddo
22808         do k=1,3
22809         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22810         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22811         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22812         enddo
22813        enddo ! j
22814        enddo ! i
22815 !------------------------------------------sidechains
22816 !        do i=1,nres_molec(1)
22817         do i=ibond_start,ibond_end
22818          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22819 !         cycle
22820 !        print *,i,ecation_prot
22821         xi=(c(1,i+nres))
22822         yi=(c(2,i+nres))
22823         zi=(c(3,i+nres))
22824           xi=mod(xi,boxxsize)
22825           if (xi.lt.0) xi=xi+boxxsize
22826           yi=mod(yi,boxysize)
22827           if (yi.lt.0) yi=yi+boxysize
22828           zi=mod(zi,boxzsize)
22829           if (zi.lt.0) zi=zi+boxzsize
22830           do k=1,3
22831             cm1(k)=dc(k,i+nres)
22832           enddo
22833            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22834          do j=itmp+1,itmp+nres_molec(5)
22835          ndiv=1.0
22836          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22837
22838            xj=c(1,j)
22839            yj=c(2,j)
22840            zj=c(3,j)
22841           xj=dmod(xj,boxxsize)
22842           if (xj.lt.0) xj=xj+boxxsize
22843           yj=dmod(yj,boxysize)
22844           if (yj.lt.0) yj=yj+boxysize
22845           zj=dmod(zj,boxzsize)
22846           if (zj.lt.0) zj=zj+boxzsize
22847       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22848       xj_safe=xj
22849       yj_safe=yj
22850       zj_safe=zj
22851       subchap=0
22852       do xshift=-1,1
22853       do yshift=-1,1
22854       do zshift=-1,1
22855           xj=xj_safe+xshift*boxxsize
22856           yj=yj_safe+yshift*boxysize
22857           zj=zj_safe+zshift*boxzsize
22858           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22859           if(dist_temp.lt.dist_init) then
22860             dist_init=dist_temp
22861             xj_temp=xj
22862             yj_temp=yj
22863             zj_temp=zj
22864             subchap=1
22865           endif
22866        enddo
22867        enddo
22868        enddo
22869        if (subchap.eq.1) then
22870           xj=xj_temp-xi
22871           yj=yj_temp-yi
22872           zj=zj_temp-zi
22873        else
22874           xj=xj_safe-xi
22875           yj=yj_safe-yi
22876           zj=zj_safe-zi
22877        endif
22878 !       enddo
22879 !       enddo
22880 ! 15- Glu 16-Asp
22881          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
22882          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
22883          (itype(i,1).eq.25))) then
22884             if(itype(i,1).eq.16) then
22885             inum=1
22886             else
22887             inum=2
22888             endif
22889             do k=1,6
22890             vcatprm(k)=catprm(k,inum)
22891             enddo
22892             dASGL=catprm(7,inum)
22893 !             do k=1,3
22894 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22895                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
22896                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
22897                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
22898
22899 !                valpha(k)=c(k,i)
22900 !                vcat(k)=c(k,j)
22901                 if (subchap.eq.1) then
22902                  vcat(1)=xj_temp
22903                  vcat(2)=yj_temp
22904                  vcat(3)=zj_temp
22905                  else
22906                 vcat(1)=xj_safe
22907                 vcat(2)=yj_safe
22908                 vcat(3)=zj_safe
22909                  endif
22910                 valpha(1)=xi-c(1,i+nres)+c(1,i)
22911                 valpha(2)=yi-c(2,i+nres)+c(2,i)
22912                 valpha(3)=zi-c(3,i+nres)+c(3,i)
22913
22914 !              enddo
22915         do k=1,3
22916           dx(k) = vcat(k)-vcm(k)
22917         enddo
22918         do k=1,3
22919           v1(k)=(vcm(k)-valpha(k))
22920           v2(k)=(vcat(k)-valpha(k))
22921         enddo
22922         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22923         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22924         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22925
22926 !  The weights of the energy function calculated from
22927 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22928           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22929             ndivi=0.5
22930           else
22931             ndivi=1.0
22932           endif
22933          ndiv=1.0
22934          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22935
22936         wh2o=78*ndivi*ndiv
22937         wc = vcatprm(1)
22938         wc=wc/wh2o
22939         wdip =vcatprm(2)
22940         wdip=wdip/wh2o
22941         wquad1 =vcatprm(3)
22942         wquad1=wquad1/wh2o
22943         wquad2 = vcatprm(4)
22944         wquad2=wquad2/wh2o
22945         wquad2p = 1.0d0-wquad2
22946         wvan1 = vcatprm(5)
22947         wvan2 =vcatprm(6)
22948         opt = dx(1)**2+dx(2)**2
22949         rsecp = opt+dx(3)**2
22950         rs = sqrt(rsecp)
22951         rthrp = rsecp*rs
22952         rfourp = rthrp*rs
22953         rsixp = rfourp*rsecp
22954         reight=rsixp*rsecp
22955         Ir = 1.0d0/rs
22956         Irsecp = 1.0d0/rsecp
22957         Irthrp = Irsecp/rs
22958         Irfourp = Irthrp/rs
22959         Irsixp = 1.0d0/rsixp
22960         Ireight=1.0d0/reight
22961         Irtw=Irsixp*Irsixp
22962         Irthir=Irtw/rs
22963         Irfourt=Irthir/rs
22964         opt1 = (4*rs*dx(3)*wdip)
22965         opt2 = 6*rsecp*wquad1*opt
22966         opt3 = wquad1*wquad2p*Irsixp
22967         opt4 = (wvan1*wvan2**12)
22968         opt5 = opt4*12*Irfourt
22969         opt6 = 2*wvan1*wvan2**6
22970         opt7 = 6*opt6*Ireight
22971         opt8 = wdip/v1m
22972         opt10 = wdip/v2m
22973         opt11 = (rsecp*v2m)**2
22974         opt12 = (rsecp*v1m)**2
22975         opt14 = (v1m*v2m*rsecp)**2
22976         opt15 = -wquad1/v2m**2
22977         opt16 = (rthrp*(v1m*v2m)**2)**2
22978         opt17 = (v1m**2*rthrp)**2
22979         opt18 = -wquad1/rthrp
22980         opt19 = (v1m**2*v2m**2)**2
22981         Ec = wc*Ir
22982         do k=1,3
22983           dEcCat(k) = -(dx(k)*wc)*Irthrp
22984           dEcCm(k)=(dx(k)*wc)*Irthrp
22985           dEcCalp(k)=0.0d0
22986         enddo
22987         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22988         do k=1,3
22989           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22990                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22991           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22992                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22993           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22994                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22995                       *v1dpv2)/opt14
22996         enddo
22997         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22998         do k=1,3
22999           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23000                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23001                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23002           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23003                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23004                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23005           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23006                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23007                         v1dpv2**2)/opt19
23008         enddo
23009         Equad2=wquad1*wquad2p*Irthrp
23010         do k=1,3
23011           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23012           dEquad2Cm(k)=3*dx(k)*rs*opt3
23013           dEquad2Calp(k)=0.0d0
23014         enddo
23015         Evan1=opt4*Irtw
23016         do k=1,3
23017           dEvan1Cat(k)=-dx(k)*opt5
23018           dEvan1Cm(k)=dx(k)*opt5
23019           dEvan1Calp(k)=0.0d0
23020         enddo
23021         Evan2=-opt6*Irsixp
23022         do k=1,3
23023           dEvan2Cat(k)=dx(k)*opt7
23024           dEvan2Cm(k)=-dx(k)*opt7
23025           dEvan2Calp(k)=0.0d0
23026         enddo
23027         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23028 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23029
23030         do k=1,3
23031           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23032                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23033 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23034           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23035                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23036           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23037                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23038         enddo
23039             dscmag = 0.0d0
23040             do k=1,3
23041               dscvec(k) = dc(k,i+nres)
23042               dscmag = dscmag+dscvec(k)*dscvec(k)
23043             enddo
23044             dscmag3 = dscmag
23045             dscmag = sqrt(dscmag)
23046             dscmag3 = dscmag3*dscmag
23047             constA = 1.0d0+dASGL/dscmag
23048             constB = 0.0d0
23049             do k=1,3
23050               constB = constB+dscvec(k)*dEtotalCm(k)
23051             enddo
23052             constB = constB*dASGL/dscmag3
23053             do k=1,3
23054               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23055               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23056                constA*dEtotalCm(k)-constB*dscvec(k)
23057 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23058               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23059               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23060              enddo
23061         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23062            if(itype(i,1).eq.14) then
23063             inum=3
23064             else
23065             inum=4
23066             endif
23067             do k=1,6
23068             vcatprm(k)=catprm(k,inum)
23069             enddo
23070             dASGL=catprm(7,inum)
23071 !             do k=1,3
23072 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23073 !                valpha(k)=c(k,i)
23074 !                vcat(k)=c(k,j)
23075 !              enddo
23076                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23077                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23078                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23079                 if (subchap.eq.1) then
23080                  vcat(1)=xj_temp
23081                  vcat(2)=yj_temp
23082                  vcat(3)=zj_temp
23083                  else
23084                 vcat(1)=xj_safe
23085                 vcat(2)=yj_safe
23086                 vcat(3)=zj_safe
23087                 endif
23088                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23089                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23090                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23091
23092
23093         do k=1,3
23094           dx(k) = vcat(k)-vcm(k)
23095         enddo
23096         do k=1,3
23097           v1(k)=(vcm(k)-valpha(k))
23098           v2(k)=(vcat(k)-valpha(k))
23099         enddo
23100         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23101         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23102         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23103 !  The weights of the energy function calculated from
23104 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23105          ndiv=1.0
23106          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23107
23108         wh2o=78*ndiv
23109         wdip =vcatprm(2)
23110         wdip=wdip/wh2o
23111         wquad1 =vcatprm(3)
23112         wquad1=wquad1/wh2o
23113         wquad2 = vcatprm(4)
23114         wquad2=wquad2/wh2o
23115         wquad2p = 1-wquad2
23116         wvan1 = vcatprm(5)
23117         wvan2 =vcatprm(6)
23118         opt = dx(1)**2+dx(2)**2
23119         rsecp = opt+dx(3)**2
23120         rs = sqrt(rsecp)
23121         rthrp = rsecp*rs
23122         rfourp = rthrp*rs
23123         rsixp = rfourp*rsecp
23124         reight=rsixp*rsecp
23125         Ir = 1.0d0/rs
23126         Irsecp = 1/rsecp
23127         Irthrp = Irsecp/rs
23128         Irfourp = Irthrp/rs
23129         Irsixp = 1/rsixp
23130         Ireight=1/reight
23131         Irtw=Irsixp*Irsixp
23132         Irthir=Irtw/rs
23133         Irfourt=Irthir/rs
23134         opt1 = (4*rs*dx(3)*wdip)
23135         opt2 = 6*rsecp*wquad1*opt
23136         opt3 = wquad1*wquad2p*Irsixp
23137         opt4 = (wvan1*wvan2**12)
23138         opt5 = opt4*12*Irfourt
23139         opt6 = 2*wvan1*wvan2**6
23140         opt7 = 6*opt6*Ireight
23141         opt8 = wdip/v1m
23142         opt10 = wdip/v2m
23143         opt11 = (rsecp*v2m)**2
23144         opt12 = (rsecp*v1m)**2
23145         opt14 = (v1m*v2m*rsecp)**2
23146         opt15 = -wquad1/v2m**2
23147         opt16 = (rthrp*(v1m*v2m)**2)**2
23148         opt17 = (v1m**2*rthrp)**2
23149         opt18 = -wquad1/rthrp
23150         opt19 = (v1m**2*v2m**2)**2
23151         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23152         do k=1,3
23153           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23154                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23155          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23156                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23157           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23158                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23159                       *v1dpv2)/opt14
23160         enddo
23161         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23162         do k=1,3
23163           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23164                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23165                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23166           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23167                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23168                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23169           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23170                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23171                         v1dpv2**2)/opt19
23172         enddo
23173         Equad2=wquad1*wquad2p*Irthrp
23174         do k=1,3
23175           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23176           dEquad2Cm(k)=3*dx(k)*rs*opt3
23177           dEquad2Calp(k)=0.0d0
23178         enddo
23179         Evan1=opt4*Irtw
23180         do k=1,3
23181           dEvan1Cat(k)=-dx(k)*opt5
23182           dEvan1Cm(k)=dx(k)*opt5
23183           dEvan1Calp(k)=0.0d0
23184         enddo
23185         Evan2=-opt6*Irsixp
23186         do k=1,3
23187           dEvan2Cat(k)=dx(k)*opt7
23188           dEvan2Cm(k)=-dx(k)*opt7
23189           dEvan2Calp(k)=0.0d0
23190         enddo
23191          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23192         do k=1,3
23193           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23194                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23195           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23196                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23197           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23198                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23199         enddo
23200             dscmag = 0.0d0
23201             do k=1,3
23202               dscvec(k) = c(k,i+nres)-c(k,i)
23203 ! TU SPRAWDZ???
23204 !              dscvec(1) = xj
23205 !              dscvec(2) = yj
23206 !              dscvec(3) = zj
23207
23208               dscmag = dscmag+dscvec(k)*dscvec(k)
23209             enddo
23210             dscmag3 = dscmag
23211             dscmag = sqrt(dscmag)
23212             dscmag3 = dscmag3*dscmag
23213             constA = 1+dASGL/dscmag
23214             constB = 0.0d0
23215             do k=1,3
23216               constB = constB+dscvec(k)*dEtotalCm(k)
23217             enddo
23218             constB = constB*dASGL/dscmag3
23219             do k=1,3
23220               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23221               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23222                constA*dEtotalCm(k)-constB*dscvec(k)
23223               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23224               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23225              enddo
23226            else
23227             rcal = 0.0d0
23228             do k=1,3
23229 !              r(k) = c(k,j)-c(k,i+nres)
23230               r(1) = xj
23231               r(2) = yj
23232               r(3) = zj
23233               rcal = rcal+r(k)*r(k)
23234             enddo
23235             ract=sqrt(rcal)
23236             rocal=1.5
23237             epscalc=0.2
23238             r0p=0.5*(rocal+sig0(itype(i,1)))
23239             r06 = r0p**6
23240             r012 = r06*r06
23241             Evan1=epscalc*(r012/rcal**6)
23242             Evan2=epscalc*2*(r06/rcal**3)
23243             r4 = rcal**4
23244             r7 = rcal**7
23245             do k=1,3
23246               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23247               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23248             enddo
23249             do k=1,3
23250               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23251             enddo
23252                  ecation_prot = ecation_prot+ Evan1+Evan2
23253             do  k=1,3
23254                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23255                dEtotalCm(k)
23256               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23257               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23258              enddo
23259          endif ! 13-16 residues
23260        enddo !j
23261        enddo !i
23262        return
23263        end subroutine ecat_prot
23264
23265 !----------------------------------------------------------------------------
23266 !-----------------------------------------------------------------------------
23267 !-----------------------------------------------------------------------------
23268       subroutine eprot_sc_base(escbase)
23269       use calc_data
23270 !      implicit real*8 (a-h,o-z)
23271 !      include 'DIMENSIONS'
23272 !      include 'COMMON.GEO'
23273 !      include 'COMMON.VAR'
23274 !      include 'COMMON.LOCAL'
23275 !      include 'COMMON.CHAIN'
23276 !      include 'COMMON.DERIV'
23277 !      include 'COMMON.NAMES'
23278 !      include 'COMMON.INTERACT'
23279 !      include 'COMMON.IOUNITS'
23280 !      include 'COMMON.CALC'
23281 !      include 'COMMON.CONTROL'
23282 !      include 'COMMON.SBRIDGE'
23283       logical :: lprn
23284 !el local variables
23285       integer :: iint,itypi,itypi1,itypj,subchap
23286       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23287       real(kind=8) :: evdw,sig0ij
23288       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23289                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23290                     sslipi,sslipj,faclip
23291       integer :: ii
23292       real(kind=8) :: fracinbuf
23293        real (kind=8) :: escbase
23294        real (kind=8),dimension(4):: ener
23295        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23296        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23297         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23298         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23299         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23300         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23301         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23302         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23303        real(kind=8),dimension(3,2)::chead,erhead_tail
23304        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23305        integer troll
23306        eps_out=80.0d0
23307        escbase=0.0d0
23308 !       do i=1,nres_molec(1)
23309         do i=ibond_start,ibond_end
23310         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23311         itypi  = itype(i,1)
23312         dxi    = dc_norm(1,nres+i)
23313         dyi    = dc_norm(2,nres+i)
23314         dzi    = dc_norm(3,nres+i)
23315         dsci_inv = vbld_inv(i+nres)
23316         xi=c(1,nres+i)
23317         yi=c(2,nres+i)
23318         zi=c(3,nres+i)
23319         xi=mod(xi,boxxsize)
23320          if (xi.lt.0) xi=xi+boxxsize
23321         yi=mod(yi,boxysize)
23322          if (yi.lt.0) yi=yi+boxysize
23323         zi=mod(zi,boxzsize)
23324          if (zi.lt.0) zi=zi+boxzsize
23325          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23326            itypj= itype(j,2)
23327            if (itype(j,2).eq.ntyp1_molec(2))cycle
23328            xj=c(1,j+nres)
23329            yj=c(2,j+nres)
23330            zj=c(3,j+nres)
23331            xj=dmod(xj,boxxsize)
23332            if (xj.lt.0) xj=xj+boxxsize
23333            yj=dmod(yj,boxysize)
23334            if (yj.lt.0) yj=yj+boxysize
23335            zj=dmod(zj,boxzsize)
23336            if (zj.lt.0) zj=zj+boxzsize
23337           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23338           xj_safe=xj
23339           yj_safe=yj
23340           zj_safe=zj
23341           subchap=0
23342
23343           do xshift=-1,1
23344           do yshift=-1,1
23345           do zshift=-1,1
23346           xj=xj_safe+xshift*boxxsize
23347           yj=yj_safe+yshift*boxysize
23348           zj=zj_safe+zshift*boxzsize
23349           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23350           if(dist_temp.lt.dist_init) then
23351             dist_init=dist_temp
23352             xj_temp=xj
23353             yj_temp=yj
23354             zj_temp=zj
23355             subchap=1
23356           endif
23357           enddo
23358           enddo
23359           enddo
23360           if (subchap.eq.1) then
23361           xj=xj_temp-xi
23362           yj=yj_temp-yi
23363           zj=zj_temp-zi
23364           else
23365           xj=xj_safe-xi
23366           yj=yj_safe-yi
23367           zj=zj_safe-zi
23368           endif
23369           dxj = dc_norm( 1, nres+j )
23370           dyj = dc_norm( 2, nres+j )
23371           dzj = dc_norm( 3, nres+j )
23372 !          print *,i,j,itypi,itypj
23373           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23374           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23375 !          d1i=0.0d0
23376 !          d1j=0.0d0
23377 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23378 ! Gay-berne var's
23379           sig0ij = sigma_scbase( itypi,itypj )
23380           chi1   = chi_scbase( itypi, itypj,1 )
23381           chi2   = chi_scbase( itypi, itypj,2 )
23382 !          chi1=0.0d0
23383 !          chi2=0.0d0
23384           chi12  = chi1 * chi2
23385           chip1  = chipp_scbase( itypi, itypj,1 )
23386           chip2  = chipp_scbase( itypi, itypj,2 )
23387 !          chip1=0.0d0
23388 !          chip2=0.0d0
23389           chip12 = chip1 * chip2
23390 ! not used by momo potential, but needed by sc_angular which is shared
23391 ! by all energy_potential subroutines
23392           alf1   = 0.0d0
23393           alf2   = 0.0d0
23394           alf12  = 0.0d0
23395           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23396 !       a12sq = a12sq * a12sq
23397 ! charge of amino acid itypi is...
23398           chis1 = chis_scbase(itypi,itypj,1)
23399           chis2 = chis_scbase(itypi,itypj,2)
23400           chis12 = chis1 * chis2
23401           sig1 = sigmap1_scbase(itypi,itypj)
23402           sig2 = sigmap2_scbase(itypi,itypj)
23403 !       write (*,*) "sig1 = ", sig1
23404 !       write (*,*) "sig2 = ", sig2
23405 ! alpha factors from Fcav/Gcav
23406           b1 = alphasur_scbase(1,itypi,itypj)
23407 !          b1=0.0d0
23408           b2 = alphasur_scbase(2,itypi,itypj)
23409           b3 = alphasur_scbase(3,itypi,itypj)
23410           b4 = alphasur_scbase(4,itypi,itypj)
23411 ! used to determine whether we want to do quadrupole calculations
23412 ! used by Fgb
23413        eps_in = epsintab_scbase(itypi,itypj)
23414        if (eps_in.eq.0.0) eps_in=1.0
23415        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23416 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23417 !-------------------------------------------------------------------
23418 ! tail location and distance calculations
23419        DO k = 1,3
23420 ! location of polar head is computed by taking hydrophobic centre
23421 ! and moving by a d1 * dc_norm vector
23422 ! see unres publications for very informative images
23423         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23424         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23425 ! distance
23426 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23427 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23428         Rhead_distance(k) = chead(k,2) - chead(k,1)
23429        END DO
23430 ! pitagoras (root of sum of squares)
23431        Rhead = dsqrt( &
23432           (Rhead_distance(1)*Rhead_distance(1)) &
23433         + (Rhead_distance(2)*Rhead_distance(2)) &
23434         + (Rhead_distance(3)*Rhead_distance(3)))
23435 !-------------------------------------------------------------------
23436 ! zero everything that should be zero'ed
23437        evdwij = 0.0d0
23438        ECL = 0.0d0
23439        Elj = 0.0d0
23440        Equad = 0.0d0
23441        Epol = 0.0d0
23442        Fcav=0.0d0
23443        eheadtail = 0.0d0
23444        dGCLdOM1 = 0.0d0
23445        dGCLdOM2 = 0.0d0
23446        dGCLdOM12 = 0.0d0
23447        dPOLdOM1 = 0.0d0
23448        dPOLdOM2 = 0.0d0
23449           Fcav = 0.0d0
23450           dFdR = 0.0d0
23451           dCAVdOM1  = 0.0d0
23452           dCAVdOM2  = 0.0d0
23453           dCAVdOM12 = 0.0d0
23454           dscj_inv = vbld_inv(j+nres)
23455 !          print *,i,j,dscj_inv,dsci_inv
23456 ! rij holds 1/(distance of Calpha atoms)
23457           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23458           rij  = dsqrt(rrij)
23459 !----------------------------
23460           CALL sc_angular
23461 ! this should be in elgrad_init but om's are calculated by sc_angular
23462 ! which in turn is used by older potentials
23463 ! om = omega, sqom = om^2
23464           sqom1  = om1 * om1
23465           sqom2  = om2 * om2
23466           sqom12 = om12 * om12
23467
23468 ! now we calculate EGB - Gey-Berne
23469 ! It will be summed up in evdwij and saved in evdw
23470           sigsq     = 1.0D0  / sigsq
23471           sig       = sig0ij * dsqrt(sigsq)
23472 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23473           rij_shift = 1.0/rij - sig + sig0ij
23474           IF (rij_shift.le.0.0D0) THEN
23475            evdw = 1.0D20
23476            RETURN
23477           END IF
23478           sigder = -sig * sigsq
23479           rij_shift = 1.0D0 / rij_shift
23480           fac       = rij_shift**expon
23481           c1        = fac  * fac * aa_scbase(itypi,itypj)
23482 !          c1        = 0.0d0
23483           c2        = fac  * bb_scbase(itypi,itypj)
23484 !          c2        = 0.0d0
23485           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23486           eps2der   = eps3rt * evdwij
23487           eps3der   = eps2rt * evdwij
23488 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23489           evdwij    = eps2rt * eps3rt * evdwij
23490           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23491           fac    = -expon * (c1 + evdwij) * rij_shift
23492           sigder = fac * sigder
23493 !          fac    = rij * fac
23494 ! Calculate distance derivative
23495           gg(1) =  fac
23496           gg(2) =  fac
23497           gg(3) =  fac
23498 !          if (b2.gt.0.0) then
23499           fac = chis1 * sqom1 + chis2 * sqom2 &
23500           - 2.0d0 * chis12 * om1 * om2 * om12
23501 ! we will use pom later in Gcav, so dont mess with it!
23502           pom = 1.0d0 - chis1 * chis2 * sqom12
23503           Lambf = (1.0d0 - (fac / pom))
23504           Lambf = dsqrt(Lambf)
23505           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23506 !       write (*,*) "sparrow = ", sparrow
23507           Chif = 1.0d0/rij * sparrow
23508           ChiLambf = Chif * Lambf
23509           eagle = dsqrt(ChiLambf)
23510           bat = ChiLambf ** 11.0d0
23511           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23512           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23513           botsq = bot * bot
23514           Fcav = top / bot
23515 !          print *,i,j,Fcav
23516           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23517           dbot = 12.0d0 * b4 * bat * Lambf
23518           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23519 !       dFdR = 0.0d0
23520 !      write (*,*) "dFcav/dR = ", dFdR
23521           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23522           dbot = 12.0d0 * b4 * bat * Chif
23523           eagle = Lambf * pom
23524           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23525           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23526           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23527               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23528
23529           dFdL = ((dtop * bot - top * dbot) / botsq)
23530 !       dFdL = 0.0d0
23531           dCAVdOM1  = dFdL * ( dFdOM1 )
23532           dCAVdOM2  = dFdL * ( dFdOM2 )
23533           dCAVdOM12 = dFdL * ( dFdOM12 )
23534
23535           ertail(1) = xj*rij
23536           ertail(2) = yj*rij
23537           ertail(3) = zj*rij
23538 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23539 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23540 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23541 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23542 !           print *,"EOMY",eom1,eom2,eom12
23543 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23544 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23545 ! here dtail=0.0
23546 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23547 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23548        DO k = 1, 3
23549 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23550 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23551         pom = ertail(k)
23552 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23553         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23554                   - (( dFdR + gg(k) ) * pom)
23555 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23556 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23557 !     &             - ( dFdR * pom )
23558         pom = ertail(k)
23559 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23560         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23561                   + (( dFdR + gg(k) ) * pom)
23562 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23563 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23564 !c!     &             + ( dFdR * pom )
23565
23566         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23567                   - (( dFdR + gg(k) ) * ertail(k))
23568 !c!     &             - ( dFdR * ertail(k))
23569
23570         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23571                   + (( dFdR + gg(k) ) * ertail(k))
23572 !c!     &             + ( dFdR * ertail(k))
23573
23574         gg(k) = 0.0d0
23575 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23576 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23577       END DO
23578
23579 !          else
23580
23581 !          endif
23582 !Now dipole-dipole
23583          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23584        w1 = wdipdip_scbase(1,itypi,itypj)
23585        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23586        w3 = wdipdip_scbase(2,itypi,itypj)
23587 !c!-------------------------------------------------------------------
23588 !c! ECL
23589        fac = (om12 - 3.0d0 * om1 * om2)
23590        c1 = (w1 / (Rhead**3.0d0)) * fac
23591        c2 = (w2 / Rhead ** 6.0d0)  &
23592          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23593        c3= (w3/ Rhead ** 6.0d0)  &
23594          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23595        ECL = c1 - c2 + c3
23596 !c!       write (*,*) "w1 = ", w1
23597 !c!       write (*,*) "w2 = ", w2
23598 !c!       write (*,*) "om1 = ", om1
23599 !c!       write (*,*) "om2 = ", om2
23600 !c!       write (*,*) "om12 = ", om12
23601 !c!       write (*,*) "fac = ", fac
23602 !c!       write (*,*) "c1 = ", c1
23603 !c!       write (*,*) "c2 = ", c2
23604 !c!       write (*,*) "Ecl = ", Ecl
23605 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23606 !c!       write (*,*) "c2_2 = ",
23607 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23608 !c!-------------------------------------------------------------------
23609 !c! dervative of ECL is GCL...
23610 !c! dECL/dr
23611        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23612        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23613          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23614        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23615          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23616        dGCLdR = c1 - c2 + c3
23617 !c! dECL/dom1
23618        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23619        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23620          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23621        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23622        dGCLdOM1 = c1 - c2 + c3
23623 !c! dECL/dom2
23624        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23625        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23626          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23627        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23628        dGCLdOM2 = c1 - c2 + c3
23629 !c! dECL/dom12
23630        c1 = w1 / (Rhead ** 3.0d0)
23631        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23632        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23633        dGCLdOM12 = c1 - c2 + c3
23634        DO k= 1, 3
23635         erhead(k) = Rhead_distance(k)/Rhead
23636        END DO
23637        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23638        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23639        facd1 = d1i * vbld_inv(i+nres)
23640        facd2 = d1j * vbld_inv(j+nres)
23641        DO k = 1, 3
23642
23643         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23644         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23645                   - dGCLdR * pom
23646         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23647         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23648                   + dGCLdR * pom
23649
23650         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23651                   - dGCLdR * erhead(k)
23652         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23653                   + dGCLdR * erhead(k)
23654        END DO
23655        endif
23656 !now charge with dipole eg. ARG-dG
23657        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23658       alphapol1 = alphapol_scbase(itypi,itypj)
23659        w1        = wqdip_scbase(1,itypi,itypj)
23660        w2        = wqdip_scbase(2,itypi,itypj)
23661 !       w1=0.0d0
23662 !       w2=0.0d0
23663 !       pis       = sig0head_scbase(itypi,itypj)
23664 !       eps_head   = epshead_scbase(itypi,itypj)
23665 !c!-------------------------------------------------------------------
23666 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23667        R1 = 0.0d0
23668        DO k = 1, 3
23669 !c! Calculate head-to-tail distances tail is center of side-chain
23670         R1=R1+(c(k,j+nres)-chead(k,1))**2
23671        END DO
23672 !c! Pitagoras
23673        R1 = dsqrt(R1)
23674
23675 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23676 !c!     &        +dhead(1,1,itypi,itypj))**2))
23677 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23678 !c!     &        +dhead(2,1,itypi,itypj))**2))
23679
23680 !c!-------------------------------------------------------------------
23681 !c! ecl
23682        sparrow  = w1  *  om1
23683        hawk     = w2 *  (1.0d0 - sqom2)
23684        Ecl = sparrow / Rhead**2.0d0 &
23685            - hawk    / Rhead**4.0d0
23686 !c!-------------------------------------------------------------------
23687 !c! derivative of ecl is Gcl
23688 !c! dF/dr part
23689        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23690                 + 4.0d0 * hawk    / Rhead**5.0d0
23691 !c! dF/dom1
23692        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23693 !c! dF/dom2
23694        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23695 !c--------------------------------------------------------------------
23696 !c Polarization energy
23697 !c Epol
23698        MomoFac1 = (1.0d0 - chi1 * sqom2)
23699        RR1  = R1 * R1 / MomoFac1
23700        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23701        fgb1 = sqrt( RR1 + a12sq * ee1)
23702 !       eps_inout_fac=0.0d0
23703        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23704 ! derivative of Epol is Gpol...
23705        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23706                 / (fgb1 ** 5.0d0)
23707        dFGBdR1 = ( (R1 / MomoFac1) &
23708              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23709              / ( 2.0d0 * fgb1 )
23710        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23711                * (2.0d0 - 0.5d0 * ee1) ) &
23712                / (2.0d0 * fgb1)
23713        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23714 !       dPOLdR1 = 0.0d0
23715        dPOLdOM1 = 0.0d0
23716        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23717        DO k = 1, 3
23718         erhead(k) = Rhead_distance(k)/Rhead
23719         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23720        END DO
23721
23722        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23723        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23724        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23725 !       bat=0.0d0
23726        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23727        facd1 = d1i * vbld_inv(i+nres)
23728        facd2 = d1j * vbld_inv(j+nres)
23729 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23730
23731        DO k = 1, 3
23732         hawk = (erhead_tail(k,1) + &
23733         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23734 !        facd1=0.0d0
23735 !        facd2=0.0d0
23736         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23737         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23738                    - dGCLdR * pom &
23739                    - dPOLdR1 *  (erhead_tail(k,1))
23740 !     &             - dGLJdR * pom
23741
23742         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23743         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23744                    + dGCLdR * pom  &
23745                    + dPOLdR1 * (erhead_tail(k,1))
23746 !     &             + dGLJdR * pom
23747
23748
23749         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23750                   - dGCLdR * erhead(k) &
23751                   - dPOLdR1 * erhead_tail(k,1)
23752 !     &             - dGLJdR * erhead(k)
23753
23754         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23755                   + dGCLdR * erhead(k)  &
23756                   + dPOLdR1 * erhead_tail(k,1)
23757 !     &             + dGLJdR * erhead(k)
23758
23759        END DO
23760        endif
23761 !       print *,i,j,evdwij,epol,Fcav,ECL
23762        escbase=escbase+evdwij+epol+Fcav+ECL
23763        call sc_grad_scbase
23764          enddo
23765       enddo
23766
23767       return
23768       end subroutine eprot_sc_base
23769       SUBROUTINE sc_grad_scbase
23770       use calc_data
23771
23772        real (kind=8) :: dcosom1(3),dcosom2(3)
23773        eom1  =    &
23774               eps2der * eps2rt_om1   &
23775             - 2.0D0 * alf1 * eps3der &
23776             + sigder * sigsq_om1     &
23777             + dCAVdOM1               &
23778             + dGCLdOM1               &
23779             + dPOLdOM1
23780
23781        eom2  =  &
23782               eps2der * eps2rt_om2   &
23783             + 2.0D0 * alf2 * eps3der &
23784             + sigder * sigsq_om2     &
23785             + dCAVdOM2               &
23786             + dGCLdOM2               &
23787             + dPOLdOM2
23788
23789        eom12 =    &
23790               evdwij  * eps1_om12     &
23791             + eps2der * eps2rt_om12   &
23792             - 2.0D0 * alf12 * eps3der &
23793             + sigder *sigsq_om12      &
23794             + dCAVdOM12               &
23795             + dGCLdOM12
23796
23797 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23798 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23799 !               gg(1),gg(2),"rozne"
23800        DO k = 1, 3
23801         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23802         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23803         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23804         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23805                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23806                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23807         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23808                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23809                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23810         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23811         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23812        END DO
23813        RETURN
23814       END SUBROUTINE sc_grad_scbase
23815
23816
23817       subroutine epep_sc_base(epepbase)
23818       use calc_data
23819       logical :: lprn
23820 !el local variables
23821       integer :: iint,itypi,itypi1,itypj,subchap
23822       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23823       real(kind=8) :: evdw,sig0ij
23824       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23825                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23826                     sslipi,sslipj,faclip
23827       integer :: ii
23828       real(kind=8) :: fracinbuf
23829        real (kind=8) :: epepbase
23830        real (kind=8),dimension(4):: ener
23831        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23832        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23833         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23834         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23835         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23836         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23837         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23838         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23839        real(kind=8),dimension(3,2)::chead,erhead_tail
23840        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23841        integer troll
23842        eps_out=80.0d0
23843        epepbase=0.0d0
23844 !       do i=1,nres_molec(1)-1
23845         do i=ibond_start,ibond_end
23846         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23847 !C        itypi  = itype(i,1)
23848         dxi    = dc_norm(1,i)
23849         dyi    = dc_norm(2,i)
23850         dzi    = dc_norm(3,i)
23851 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23852         dsci_inv = vbld_inv(i+1)/2.0
23853         xi=(c(1,i)+c(1,i+1))/2.0
23854         yi=(c(2,i)+c(2,i+1))/2.0
23855         zi=(c(3,i)+c(3,i+1))/2.0
23856         xi=mod(xi,boxxsize)
23857          if (xi.lt.0) xi=xi+boxxsize
23858         yi=mod(yi,boxysize)
23859          if (yi.lt.0) yi=yi+boxysize
23860         zi=mod(zi,boxzsize)
23861          if (zi.lt.0) zi=zi+boxzsize
23862          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23863            itypj= itype(j,2)
23864            if (itype(j,2).eq.ntyp1_molec(2))cycle
23865            xj=c(1,j+nres)
23866            yj=c(2,j+nres)
23867            zj=c(3,j+nres)
23868            xj=dmod(xj,boxxsize)
23869            if (xj.lt.0) xj=xj+boxxsize
23870            yj=dmod(yj,boxysize)
23871            if (yj.lt.0) yj=yj+boxysize
23872            zj=dmod(zj,boxzsize)
23873            if (zj.lt.0) zj=zj+boxzsize
23874           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23875           xj_safe=xj
23876           yj_safe=yj
23877           zj_safe=zj
23878           subchap=0
23879
23880           do xshift=-1,1
23881           do yshift=-1,1
23882           do zshift=-1,1
23883           xj=xj_safe+xshift*boxxsize
23884           yj=yj_safe+yshift*boxysize
23885           zj=zj_safe+zshift*boxzsize
23886           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23887           if(dist_temp.lt.dist_init) then
23888             dist_init=dist_temp
23889             xj_temp=xj
23890             yj_temp=yj
23891             zj_temp=zj
23892             subchap=1
23893           endif
23894           enddo
23895           enddo
23896           enddo
23897           if (subchap.eq.1) then
23898           xj=xj_temp-xi
23899           yj=yj_temp-yi
23900           zj=zj_temp-zi
23901           else
23902           xj=xj_safe-xi
23903           yj=yj_safe-yi
23904           zj=zj_safe-zi
23905           endif
23906           dxj = dc_norm( 1, nres+j )
23907           dyj = dc_norm( 2, nres+j )
23908           dzj = dc_norm( 3, nres+j )
23909 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23910 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23911
23912 ! Gay-berne var's
23913           sig0ij = sigma_pepbase(itypj )
23914           chi1   = chi_pepbase(itypj,1 )
23915           chi2   = chi_pepbase(itypj,2 )
23916 !          chi1=0.0d0
23917 !          chi2=0.0d0
23918           chi12  = chi1 * chi2
23919           chip1  = chipp_pepbase(itypj,1 )
23920           chip2  = chipp_pepbase(itypj,2 )
23921 !          chip1=0.0d0
23922 !          chip2=0.0d0
23923           chip12 = chip1 * chip2
23924           chis1 = chis_pepbase(itypj,1)
23925           chis2 = chis_pepbase(itypj,2)
23926           chis12 = chis1 * chis2
23927           sig1 = sigmap1_pepbase(itypj)
23928           sig2 = sigmap2_pepbase(itypj)
23929 !       write (*,*) "sig1 = ", sig1
23930 !       write (*,*) "sig2 = ", sig2
23931        DO k = 1,3
23932 ! location of polar head is computed by taking hydrophobic centre
23933 ! and moving by a d1 * dc_norm vector
23934 ! see unres publications for very informative images
23935         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23936 ! + d1i * dc_norm(k, i+nres)
23937         chead(k,2) = c(k, j+nres)
23938 ! + d1j * dc_norm(k, j+nres)
23939 ! distance
23940 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23941 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23942         Rhead_distance(k) = chead(k,2) - chead(k,1)
23943 !        print *,gvdwc_pepbase(k,i)
23944
23945        END DO
23946        Rhead = dsqrt( &
23947           (Rhead_distance(1)*Rhead_distance(1)) &
23948         + (Rhead_distance(2)*Rhead_distance(2)) &
23949         + (Rhead_distance(3)*Rhead_distance(3)))
23950
23951 ! alpha factors from Fcav/Gcav
23952           b1 = alphasur_pepbase(1,itypj)
23953 !          b1=0.0d0
23954           b2 = alphasur_pepbase(2,itypj)
23955           b3 = alphasur_pepbase(3,itypj)
23956           b4 = alphasur_pepbase(4,itypj)
23957           alf1   = 0.0d0
23958           alf2   = 0.0d0
23959           alf12  = 0.0d0
23960           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23961 !          print *,i,j,rrij
23962           rij  = dsqrt(rrij)
23963 !----------------------------
23964        evdwij = 0.0d0
23965        ECL = 0.0d0
23966        Elj = 0.0d0
23967        Equad = 0.0d0
23968        Epol = 0.0d0
23969        Fcav=0.0d0
23970        eheadtail = 0.0d0
23971        dGCLdOM1 = 0.0d0
23972        dGCLdOM2 = 0.0d0
23973        dGCLdOM12 = 0.0d0
23974        dPOLdOM1 = 0.0d0
23975        dPOLdOM2 = 0.0d0
23976           Fcav = 0.0d0
23977           dFdR = 0.0d0
23978           dCAVdOM1  = 0.0d0
23979           dCAVdOM2  = 0.0d0
23980           dCAVdOM12 = 0.0d0
23981           dscj_inv = vbld_inv(j+nres)
23982           CALL sc_angular
23983 ! this should be in elgrad_init but om's are calculated by sc_angular
23984 ! which in turn is used by older potentials
23985 ! om = omega, sqom = om^2
23986           sqom1  = om1 * om1
23987           sqom2  = om2 * om2
23988           sqom12 = om12 * om12
23989
23990 ! now we calculate EGB - Gey-Berne
23991 ! It will be summed up in evdwij and saved in evdw
23992           sigsq     = 1.0D0  / sigsq
23993           sig       = sig0ij * dsqrt(sigsq)
23994           rij_shift = 1.0/rij - sig + sig0ij
23995           IF (rij_shift.le.0.0D0) THEN
23996            evdw = 1.0D20
23997            RETURN
23998           END IF
23999           sigder = -sig * sigsq
24000           rij_shift = 1.0D0 / rij_shift
24001           fac       = rij_shift**expon
24002           c1        = fac  * fac * aa_pepbase(itypj)
24003 !          c1        = 0.0d0
24004           c2        = fac  * bb_pepbase(itypj)
24005 !          c2        = 0.0d0
24006           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24007           eps2der   = eps3rt * evdwij
24008           eps3der   = eps2rt * evdwij
24009 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24010           evdwij    = eps2rt * eps3rt * evdwij
24011           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24012           fac    = -expon * (c1 + evdwij) * rij_shift
24013           sigder = fac * sigder
24014 !          fac    = rij * fac
24015 ! Calculate distance derivative
24016           gg(1) =  fac
24017           gg(2) =  fac
24018           gg(3) =  fac
24019           fac = chis1 * sqom1 + chis2 * sqom2 &
24020           - 2.0d0 * chis12 * om1 * om2 * om12
24021 ! we will use pom later in Gcav, so dont mess with it!
24022           pom = 1.0d0 - chis1 * chis2 * sqom12
24023           Lambf = (1.0d0 - (fac / pom))
24024           Lambf = dsqrt(Lambf)
24025           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24026 !       write (*,*) "sparrow = ", sparrow
24027           Chif = 1.0d0/rij * sparrow
24028           ChiLambf = Chif * Lambf
24029           eagle = dsqrt(ChiLambf)
24030           bat = ChiLambf ** 11.0d0
24031           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24032           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24033           botsq = bot * bot
24034           Fcav = top / bot
24035 !          print *,i,j,Fcav
24036           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24037           dbot = 12.0d0 * b4 * bat * Lambf
24038           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24039 !       dFdR = 0.0d0
24040 !      write (*,*) "dFcav/dR = ", dFdR
24041           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24042           dbot = 12.0d0 * b4 * bat * Chif
24043           eagle = Lambf * pom
24044           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24045           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24046           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24047               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24048
24049           dFdL = ((dtop * bot - top * dbot) / botsq)
24050 !       dFdL = 0.0d0
24051           dCAVdOM1  = dFdL * ( dFdOM1 )
24052           dCAVdOM2  = dFdL * ( dFdOM2 )
24053           dCAVdOM12 = dFdL * ( dFdOM12 )
24054
24055           ertail(1) = xj*rij
24056           ertail(2) = yj*rij
24057           ertail(3) = zj*rij
24058        DO k = 1, 3
24059 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24060 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24061         pom = ertail(k)
24062 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24063         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24064                   - (( dFdR + gg(k) ) * pom)/2.0
24065 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24066 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24067 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24068 !     &             - ( dFdR * pom )
24069         pom = ertail(k)
24070 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24071         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24072                   + (( dFdR + gg(k) ) * pom)
24073 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24074 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24075 !c!     &             + ( dFdR * pom )
24076
24077         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24078                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24079 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24080
24081 !c!     &             - ( dFdR * ertail(k))
24082
24083         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24084                   + (( dFdR + gg(k) ) * ertail(k))
24085 !c!     &             + ( dFdR * ertail(k))
24086
24087         gg(k) = 0.0d0
24088 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24089 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24090       END DO
24091
24092
24093        w1 = wdipdip_pepbase(1,itypj)
24094        w2 = -wdipdip_pepbase(3,itypj)/2.0
24095        w3 = wdipdip_pepbase(2,itypj)
24096 !       w1=0.0d0
24097 !       w2=0.0d0
24098 !c!-------------------------------------------------------------------
24099 !c! ECL
24100 !       w3=0.0d0
24101        fac = (om12 - 3.0d0 * om1 * om2)
24102        c1 = (w1 / (Rhead**3.0d0)) * fac
24103        c2 = (w2 / Rhead ** 6.0d0)  &
24104          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24105        c3= (w3/ Rhead ** 6.0d0)  &
24106          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24107
24108        ECL = c1 - c2 + c3
24109
24110        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24111        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24112          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24113        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24114          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24115
24116        dGCLdR = c1 - c2 + c3
24117 !c! dECL/dom1
24118        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24119        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24120          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24121        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24122        dGCLdOM1 = c1 - c2 + c3
24123 !c! dECL/dom2
24124        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24125        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24126          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24127        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24128
24129        dGCLdOM2 = c1 - c2 + c3
24130 !c! dECL/dom12
24131        c1 = w1 / (Rhead ** 3.0d0)
24132        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24133        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24134        dGCLdOM12 = c1 - c2 + c3
24135        DO k= 1, 3
24136         erhead(k) = Rhead_distance(k)/Rhead
24137        END DO
24138        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24139        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24140 !       facd1 = d1 * vbld_inv(i+nres)
24141 !       facd2 = d2 * vbld_inv(j+nres)
24142        DO k = 1, 3
24143
24144 !        pom = erhead(k)
24145 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24146 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24147 !                  - dGCLdR * pom
24148         pom = erhead(k)
24149 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24150         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24151                   + dGCLdR * pom
24152
24153         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24154                   - dGCLdR * erhead(k)/2.0d0
24155 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24156         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24157                   - dGCLdR * erhead(k)/2.0d0
24158 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24159         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24160                   + dGCLdR * erhead(k)
24161        END DO
24162 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24163        epepbase=epepbase+evdwij+Fcav+ECL
24164        call sc_grad_pepbase
24165        enddo
24166        enddo
24167       END SUBROUTINE epep_sc_base
24168       SUBROUTINE sc_grad_pepbase
24169       use calc_data
24170
24171        real (kind=8) :: dcosom1(3),dcosom2(3)
24172        eom1  =    &
24173               eps2der * eps2rt_om1   &
24174             - 2.0D0 * alf1 * eps3der &
24175             + sigder * sigsq_om1     &
24176             + dCAVdOM1               &
24177             + dGCLdOM1               &
24178             + dPOLdOM1
24179
24180        eom2  =  &
24181               eps2der * eps2rt_om2   &
24182             + 2.0D0 * alf2 * eps3der &
24183             + sigder * sigsq_om2     &
24184             + dCAVdOM2               &
24185             + dGCLdOM2               &
24186             + dPOLdOM2
24187
24188        eom12 =    &
24189               evdwij  * eps1_om12     &
24190             + eps2der * eps2rt_om12   &
24191             - 2.0D0 * alf12 * eps3der &
24192             + sigder *sigsq_om12      &
24193             + dCAVdOM12               &
24194             + dGCLdOM12
24195 !        om12=0.0
24196 !        eom12=0.0
24197 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24198 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24199 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24200 !                 *dsci_inv*2.0
24201 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24202 !               gg(1),gg(2),"rozne"
24203        DO k = 1, 3
24204         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24205         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24206         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24207         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24208                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24209                  *dsci_inv*2.0 &
24210                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24211         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24212                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24213                  *dsci_inv*2.0 &
24214                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24215 !         print *,eom12,eom2,om12,om2
24216 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24217 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24218         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24219                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24220                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24221         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24222        END DO
24223        RETURN
24224       END SUBROUTINE sc_grad_pepbase
24225       subroutine eprot_sc_phosphate(escpho)
24226       use calc_data
24227 !      implicit real*8 (a-h,o-z)
24228 !      include 'DIMENSIONS'
24229 !      include 'COMMON.GEO'
24230 !      include 'COMMON.VAR'
24231 !      include 'COMMON.LOCAL'
24232 !      include 'COMMON.CHAIN'
24233 !      include 'COMMON.DERIV'
24234 !      include 'COMMON.NAMES'
24235 !      include 'COMMON.INTERACT'
24236 !      include 'COMMON.IOUNITS'
24237 !      include 'COMMON.CALC'
24238 !      include 'COMMON.CONTROL'
24239 !      include 'COMMON.SBRIDGE'
24240       logical :: lprn
24241 !el local variables
24242       integer :: iint,itypi,itypi1,itypj,subchap
24243       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24244       real(kind=8) :: evdw,sig0ij
24245       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24246                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24247                     sslipi,sslipj,faclip,alpha_sco
24248       integer :: ii
24249       real(kind=8) :: fracinbuf
24250        real (kind=8) :: escpho
24251        real (kind=8),dimension(4):: ener
24252        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24253        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24254         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24255         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24256         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24257         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24258         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24259         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24260        real(kind=8),dimension(3,2)::chead,erhead_tail
24261        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24262        integer troll
24263        eps_out=80.0d0
24264        escpho=0.0d0
24265 !       do i=1,nres_molec(1)
24266         do i=ibond_start,ibond_end
24267         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24268         itypi  = itype(i,1)
24269         dxi    = dc_norm(1,nres+i)
24270         dyi    = dc_norm(2,nres+i)
24271         dzi    = dc_norm(3,nres+i)
24272         dsci_inv = vbld_inv(i+nres)
24273         xi=c(1,nres+i)
24274         yi=c(2,nres+i)
24275         zi=c(3,nres+i)
24276         xi=mod(xi,boxxsize)
24277          if (xi.lt.0) xi=xi+boxxsize
24278         yi=mod(yi,boxysize)
24279          if (yi.lt.0) yi=yi+boxysize
24280         zi=mod(zi,boxzsize)
24281          if (zi.lt.0) zi=zi+boxzsize
24282          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24283            itypj= itype(j,2)
24284            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24285             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24286            xj=(c(1,j)+c(1,j+1))/2.0
24287            yj=(c(2,j)+c(2,j+1))/2.0
24288            zj=(c(3,j)+c(3,j+1))/2.0
24289            xj=dmod(xj,boxxsize)
24290            if (xj.lt.0) xj=xj+boxxsize
24291            yj=dmod(yj,boxysize)
24292            if (yj.lt.0) yj=yj+boxysize
24293            zj=dmod(zj,boxzsize)
24294            if (zj.lt.0) zj=zj+boxzsize
24295           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24296           xj_safe=xj
24297           yj_safe=yj
24298           zj_safe=zj
24299           subchap=0
24300           do xshift=-1,1
24301           do yshift=-1,1
24302           do zshift=-1,1
24303           xj=xj_safe+xshift*boxxsize
24304           yj=yj_safe+yshift*boxysize
24305           zj=zj_safe+zshift*boxzsize
24306           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24307           if(dist_temp.lt.dist_init) then
24308             dist_init=dist_temp
24309             xj_temp=xj
24310             yj_temp=yj
24311             zj_temp=zj
24312             subchap=1
24313           endif
24314           enddo
24315           enddo
24316           enddo
24317           if (subchap.eq.1) then
24318           xj=xj_temp-xi
24319           yj=yj_temp-yi
24320           zj=zj_temp-zi
24321           else
24322           xj=xj_safe-xi
24323           yj=yj_safe-yi
24324           zj=zj_safe-zi
24325           endif
24326           dxj = dc_norm( 1,j )
24327           dyj = dc_norm( 2,j )
24328           dzj = dc_norm( 3,j )
24329           dscj_inv = vbld_inv(j+1)
24330
24331 ! Gay-berne var's
24332           sig0ij = sigma_scpho(itypi )
24333           chi1   = chi_scpho(itypi,1 )
24334           chi2   = chi_scpho(itypi,2 )
24335 !          chi1=0.0d0
24336 !          chi2=0.0d0
24337           chi12  = chi1 * chi2
24338           chip1  = chipp_scpho(itypi,1 )
24339           chip2  = chipp_scpho(itypi,2 )
24340 !          chip1=0.0d0
24341 !          chip2=0.0d0
24342           chip12 = chip1 * chip2
24343           chis1 = chis_scpho(itypi,1)
24344           chis2 = chis_scpho(itypi,2)
24345           chis12 = chis1 * chis2
24346           sig1 = sigmap1_scpho(itypi)
24347           sig2 = sigmap2_scpho(itypi)
24348 !       write (*,*) "sig1 = ", sig1
24349 !       write (*,*) "sig1 = ", sig1
24350 !       write (*,*) "sig2 = ", sig2
24351 ! alpha factors from Fcav/Gcav
24352           alf1   = 0.0d0
24353           alf2   = 0.0d0
24354           alf12  = 0.0d0
24355           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24356
24357           b1 = alphasur_scpho(1,itypi)
24358 !          b1=0.0d0
24359           b2 = alphasur_scpho(2,itypi)
24360           b3 = alphasur_scpho(3,itypi)
24361           b4 = alphasur_scpho(4,itypi)
24362 ! used to determine whether we want to do quadrupole calculations
24363 ! used by Fgb
24364        eps_in = epsintab_scpho(itypi)
24365        if (eps_in.eq.0.0) eps_in=1.0
24366        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24367 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24368 !-------------------------------------------------------------------
24369 ! tail location and distance calculations
24370           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24371           d1j = 0.0
24372        DO k = 1,3
24373 ! location of polar head is computed by taking hydrophobic centre
24374 ! and moving by a d1 * dc_norm vector
24375 ! see unres publications for very informative images
24376         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24377         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24378 ! distance
24379 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24380 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24381         Rhead_distance(k) = chead(k,2) - chead(k,1)
24382        END DO
24383 ! pitagoras (root of sum of squares)
24384        Rhead = dsqrt( &
24385           (Rhead_distance(1)*Rhead_distance(1)) &
24386         + (Rhead_distance(2)*Rhead_distance(2)) &
24387         + (Rhead_distance(3)*Rhead_distance(3)))
24388        Rhead_sq=Rhead**2.0
24389 !-------------------------------------------------------------------
24390 ! zero everything that should be zero'ed
24391        evdwij = 0.0d0
24392        ECL = 0.0d0
24393        Elj = 0.0d0
24394        Equad = 0.0d0
24395        Epol = 0.0d0
24396        Fcav=0.0d0
24397        eheadtail = 0.0d0
24398        dGCLdR=0.0d0
24399        dGCLdOM1 = 0.0d0
24400        dGCLdOM2 = 0.0d0
24401        dGCLdOM12 = 0.0d0
24402        dPOLdOM1 = 0.0d0
24403        dPOLdOM2 = 0.0d0
24404           Fcav = 0.0d0
24405           dFdR = 0.0d0
24406           dCAVdOM1  = 0.0d0
24407           dCAVdOM2  = 0.0d0
24408           dCAVdOM12 = 0.0d0
24409           dscj_inv = vbld_inv(j+1)/2.0
24410 !dhead_scbasej(itypi,itypj)
24411 !          print *,i,j,dscj_inv,dsci_inv
24412 ! rij holds 1/(distance of Calpha atoms)
24413           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24414           rij  = dsqrt(rrij)
24415 !----------------------------
24416           CALL sc_angular
24417 ! this should be in elgrad_init but om's are calculated by sc_angular
24418 ! which in turn is used by older potentials
24419 ! om = omega, sqom = om^2
24420           sqom1  = om1 * om1
24421           sqom2  = om2 * om2
24422           sqom12 = om12 * om12
24423
24424 ! now we calculate EGB - Gey-Berne
24425 ! It will be summed up in evdwij and saved in evdw
24426           sigsq     = 1.0D0  / sigsq
24427           sig       = sig0ij * dsqrt(sigsq)
24428 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24429           rij_shift = 1.0/rij - sig + sig0ij
24430           IF (rij_shift.le.0.0D0) THEN
24431            evdw = 1.0D20
24432            RETURN
24433           END IF
24434           sigder = -sig * sigsq
24435           rij_shift = 1.0D0 / rij_shift
24436           fac       = rij_shift**expon
24437           c1        = fac  * fac * aa_scpho(itypi)
24438 !          c1        = 0.0d0
24439           c2        = fac  * bb_scpho(itypi)
24440 !          c2        = 0.0d0
24441           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24442           eps2der   = eps3rt * evdwij
24443           eps3der   = eps2rt * evdwij
24444 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24445           evdwij    = eps2rt * eps3rt * evdwij
24446           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24447           fac    = -expon * (c1 + evdwij) * rij_shift
24448           sigder = fac * sigder
24449 !          fac    = rij * fac
24450 ! Calculate distance derivative
24451           gg(1) =  fac
24452           gg(2) =  fac
24453           gg(3) =  fac
24454           fac = chis1 * sqom1 + chis2 * sqom2 &
24455           - 2.0d0 * chis12 * om1 * om2 * om12
24456 ! we will use pom later in Gcav, so dont mess with it!
24457           pom = 1.0d0 - chis1 * chis2 * sqom12
24458           Lambf = (1.0d0 - (fac / pom))
24459           Lambf = dsqrt(Lambf)
24460           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24461 !       write (*,*) "sparrow = ", sparrow
24462           Chif = 1.0d0/rij * sparrow
24463           ChiLambf = Chif * Lambf
24464           eagle = dsqrt(ChiLambf)
24465           bat = ChiLambf ** 11.0d0
24466           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24467           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24468           botsq = bot * bot
24469           Fcav = top / bot
24470           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24471           dbot = 12.0d0 * b4 * bat * Lambf
24472           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24473 !       dFdR = 0.0d0
24474 !      write (*,*) "dFcav/dR = ", dFdR
24475           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24476           dbot = 12.0d0 * b4 * bat * Chif
24477           eagle = Lambf * pom
24478           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24479           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24480           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24481               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24482
24483           dFdL = ((dtop * bot - top * dbot) / botsq)
24484 !       dFdL = 0.0d0
24485           dCAVdOM1  = dFdL * ( dFdOM1 )
24486           dCAVdOM2  = dFdL * ( dFdOM2 )
24487           dCAVdOM12 = dFdL * ( dFdOM12 )
24488
24489           ertail(1) = xj*rij
24490           ertail(2) = yj*rij
24491           ertail(3) = zj*rij
24492        DO k = 1, 3
24493 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24494 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24495 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24496
24497         pom = ertail(k)
24498 !        print *,pom,gg(k),dFdR
24499 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24500         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24501                   - (( dFdR + gg(k) ) * pom)
24502 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24503 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24504 !     &             - ( dFdR * pom )
24505 !        pom = ertail(k)
24506 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24507 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24508 !                  + (( dFdR + gg(k) ) * pom)
24509 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24510 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24511 !c!     &             + ( dFdR * pom )
24512
24513         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24514                   - (( dFdR + gg(k) ) * ertail(k))
24515 !c!     &             - ( dFdR * ertail(k))
24516
24517         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24518                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24519
24520         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24521                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24522
24523 !c!     &             + ( dFdR * ertail(k))
24524
24525         gg(k) = 0.0d0
24526         ENDDO
24527 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24528 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24529 !      alphapol1 = alphapol_scpho(itypi)
24530        if (wqq_scpho(itypi).ne.0.0) then
24531        Qij=wqq_scpho(itypi)/eps_in
24532        alpha_sco=1.d0/alphi_scpho(itypi)
24533 !       Qij=0.0
24534        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24535 !c! derivative of Ecl is Gcl...
24536        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24537                 (Rhead*alpha_sco+1) ) / Rhead_sq
24538        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24539        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24540        w1        = wqdip_scpho(1,itypi)
24541        w2        = wqdip_scpho(2,itypi)
24542 !       w1=0.0d0
24543 !       w2=0.0d0
24544 !       pis       = sig0head_scbase(itypi,itypj)
24545 !       eps_head   = epshead_scbase(itypi,itypj)
24546 !c!-------------------------------------------------------------------
24547
24548 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24549 !c!     &        +dhead(1,1,itypi,itypj))**2))
24550 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24551 !c!     &        +dhead(2,1,itypi,itypj))**2))
24552
24553 !c!-------------------------------------------------------------------
24554 !c! ecl
24555        sparrow  = w1  *  om1
24556        hawk     = w2 *  (1.0d0 - sqom2)
24557        Ecl = sparrow / Rhead**2.0d0 &
24558            - hawk    / Rhead**4.0d0
24559 !c!-------------------------------------------------------------------
24560        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24561            1.0/rij,sparrow
24562
24563 !c! derivative of ecl is Gcl
24564 !c! dF/dr part
24565        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24566                 + 4.0d0 * hawk    / Rhead**5.0d0
24567 !c! dF/dom1
24568        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24569 !c! dF/dom2
24570        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24571        endif
24572
24573 !c--------------------------------------------------------------------
24574 !c Polarization energy
24575 !c Epol
24576        R1 = 0.0d0
24577        DO k = 1, 3
24578 !c! Calculate head-to-tail distances tail is center of side-chain
24579         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24580        END DO
24581 !c! Pitagoras
24582        R1 = dsqrt(R1)
24583
24584       alphapol1 = alphapol_scpho(itypi)
24585 !      alphapol1=0.0
24586        MomoFac1 = (1.0d0 - chi2 * sqom1)
24587        RR1  = R1 * R1 / MomoFac1
24588        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24589 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24590        fgb1 = sqrt( RR1 + a12sq * ee1)
24591 !       eps_inout_fac=0.0d0
24592        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24593 ! derivative of Epol is Gpol...
24594        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24595                 / (fgb1 ** 5.0d0)
24596        dFGBdR1 = ( (R1 / MomoFac1) &
24597              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24598              / ( 2.0d0 * fgb1 )
24599        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24600                * (2.0d0 - 0.5d0 * ee1) ) &
24601                / (2.0d0 * fgb1)
24602        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24603 !       dPOLdR1 = 0.0d0
24604 !       dPOLdOM1 = 0.0d0
24605        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24606                * (2.0d0 - 0.5d0 * ee1) ) &
24607                / (2.0d0 * fgb1)
24608
24609        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24610        dPOLdOM2 = 0.0
24611        DO k = 1, 3
24612         erhead(k) = Rhead_distance(k)/Rhead
24613         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24614        END DO
24615
24616        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24617        erdxj = scalar( erhead(1), dC_norm(1,j) )
24618        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24619 !       bat=0.0d0
24620        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24621        facd1 = d1i * vbld_inv(i+nres)
24622        facd2 = d1j * vbld_inv(j)
24623 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24624
24625        DO k = 1, 3
24626         hawk = (erhead_tail(k,1) + &
24627         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24628 !        facd1=0.0d0
24629 !        facd2=0.0d0
24630 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24631 !                pom,(erhead_tail(k,1))
24632
24633 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24634         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24635         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24636                    - dGCLdR * pom &
24637                    - dPOLdR1 *  (erhead_tail(k,1))
24638 !     &             - dGLJdR * pom
24639
24640         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24641 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24642 !                   + dGCLdR * pom  &
24643 !                   + dPOLdR1 * (erhead_tail(k,1))
24644 !     &             + dGLJdR * pom
24645
24646
24647         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24648                   - dGCLdR * erhead(k) &
24649                   - dPOLdR1 * erhead_tail(k,1)
24650 !     &             - dGLJdR * erhead(k)
24651
24652         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24653                   + (dGCLdR * erhead(k)  &
24654                   + dPOLdR1 * erhead_tail(k,1))/2.0
24655         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24656                   + (dGCLdR * erhead(k)  &
24657                   + dPOLdR1 * erhead_tail(k,1))/2.0
24658
24659 !     &             + dGLJdR * erhead(k)
24660 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24661
24662        END DO
24663 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24664        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24665         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24666        escpho=escpho+evdwij+epol+Fcav+ECL
24667        call sc_grad_scpho
24668          enddo
24669
24670       enddo
24671
24672       return
24673       end subroutine eprot_sc_phosphate
24674       SUBROUTINE sc_grad_scpho
24675       use calc_data
24676
24677        real (kind=8) :: dcosom1(3),dcosom2(3)
24678        eom1  =    &
24679               eps2der * eps2rt_om1   &
24680             - 2.0D0 * alf1 * eps3der &
24681             + sigder * sigsq_om1     &
24682             + dCAVdOM1               &
24683             + dGCLdOM1               &
24684             + dPOLdOM1
24685
24686        eom2  =  &
24687               eps2der * eps2rt_om2   &
24688             + 2.0D0 * alf2 * eps3der &
24689             + sigder * sigsq_om2     &
24690             + dCAVdOM2               &
24691             + dGCLdOM2               &
24692             + dPOLdOM2
24693
24694        eom12 =    &
24695               evdwij  * eps1_om12     &
24696             + eps2der * eps2rt_om12   &
24697             - 2.0D0 * alf12 * eps3der &
24698             + sigder *sigsq_om12      &
24699             + dCAVdOM12               &
24700             + dGCLdOM12
24701 !        om12=0.0
24702 !        eom12=0.0
24703 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24704 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24705 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24706 !                 *dsci_inv*2.0
24707 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24708 !               gg(1),gg(2),"rozne"
24709        DO k = 1, 3
24710         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24711         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24712         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24713         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24714                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24715                  *dscj_inv*2.0 &
24716                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24717         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24718                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24719                  *dscj_inv*2.0 &
24720                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24721         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24722                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24723                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24724
24725 !         print *,eom12,eom2,om12,om2
24726 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24727 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24728 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24729 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24730 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24731         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24732        END DO
24733        RETURN
24734       END SUBROUTINE sc_grad_scpho
24735       subroutine eprot_pep_phosphate(epeppho)
24736       use calc_data
24737 !      implicit real*8 (a-h,o-z)
24738 !      include 'DIMENSIONS'
24739 !      include 'COMMON.GEO'
24740 !      include 'COMMON.VAR'
24741 !      include 'COMMON.LOCAL'
24742 !      include 'COMMON.CHAIN'
24743 !      include 'COMMON.DERIV'
24744 !      include 'COMMON.NAMES'
24745 !      include 'COMMON.INTERACT'
24746 !      include 'COMMON.IOUNITS'
24747 !      include 'COMMON.CALC'
24748 !      include 'COMMON.CONTROL'
24749 !      include 'COMMON.SBRIDGE'
24750       logical :: lprn
24751 !el local variables
24752       integer :: iint,itypi,itypi1,itypj,subchap
24753       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24754       real(kind=8) :: evdw,sig0ij
24755       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24756                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24757                     sslipi,sslipj,faclip
24758       integer :: ii
24759       real(kind=8) :: fracinbuf
24760        real (kind=8) :: epeppho
24761        real (kind=8),dimension(4):: ener
24762        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24763        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24764         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24765         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24766         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24767         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24768         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24769         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24770        real(kind=8),dimension(3,2)::chead,erhead_tail
24771        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24772        integer troll
24773        real (kind=8) :: dcosom1(3),dcosom2(3)
24774        epeppho=0.0d0
24775 !       do i=1,nres_molec(1)
24776         do i=ibond_start,ibond_end
24777         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24778         itypi  = itype(i,1)
24779         dsci_inv = vbld_inv(i+1)/2.0
24780         dxi    = dc_norm(1,i)
24781         dyi    = dc_norm(2,i)
24782         dzi    = dc_norm(3,i)
24783         xi=(c(1,i)+c(1,i+1))/2.0
24784         yi=(c(2,i)+c(2,i+1))/2.0
24785         zi=(c(3,i)+c(3,i+1))/2.0
24786         xi=mod(xi,boxxsize)
24787          if (xi.lt.0) xi=xi+boxxsize
24788         yi=mod(yi,boxysize)
24789          if (yi.lt.0) yi=yi+boxysize
24790         zi=mod(zi,boxzsize)
24791          if (zi.lt.0) zi=zi+boxzsize
24792          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24793            itypj= itype(j,2)
24794            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24795             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24796            xj=(c(1,j)+c(1,j+1))/2.0
24797            yj=(c(2,j)+c(2,j+1))/2.0
24798            zj=(c(3,j)+c(3,j+1))/2.0
24799            xj=dmod(xj,boxxsize)
24800            if (xj.lt.0) xj=xj+boxxsize
24801            yj=dmod(yj,boxysize)
24802            if (yj.lt.0) yj=yj+boxysize
24803            zj=dmod(zj,boxzsize)
24804            if (zj.lt.0) zj=zj+boxzsize
24805           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24806           xj_safe=xj
24807           yj_safe=yj
24808           zj_safe=zj
24809           subchap=0
24810           do xshift=-1,1
24811           do yshift=-1,1
24812           do zshift=-1,1
24813           xj=xj_safe+xshift*boxxsize
24814           yj=yj_safe+yshift*boxysize
24815           zj=zj_safe+zshift*boxzsize
24816           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24817           if(dist_temp.lt.dist_init) then
24818             dist_init=dist_temp
24819             xj_temp=xj
24820             yj_temp=yj
24821             zj_temp=zj
24822             subchap=1
24823           endif
24824           enddo
24825           enddo
24826           enddo
24827           if (subchap.eq.1) then
24828           xj=xj_temp-xi
24829           yj=yj_temp-yi
24830           zj=zj_temp-zi
24831           else
24832           xj=xj_safe-xi
24833           yj=yj_safe-yi
24834           zj=zj_safe-zi
24835           endif
24836           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24837           rij  = dsqrt(rrij)
24838           dxj = dc_norm( 1,j )
24839           dyj = dc_norm( 2,j )
24840           dzj = dc_norm( 3,j )
24841           dscj_inv = vbld_inv(j+1)/2.0
24842 ! Gay-berne var's
24843           sig0ij = sigma_peppho
24844 !          chi1=0.0d0
24845 !          chi2=0.0d0
24846           chi12  = chi1 * chi2
24847 !          chip1=0.0d0
24848 !          chip2=0.0d0
24849           chip12 = chip1 * chip2
24850 !          chis1 = 0.0d0
24851 !          chis2 = 0.0d0
24852           chis12 = chis1 * chis2
24853           sig1 = sigmap1_peppho
24854           sig2 = sigmap2_peppho
24855 !       write (*,*) "sig1 = ", sig1
24856 !       write (*,*) "sig1 = ", sig1
24857 !       write (*,*) "sig2 = ", sig2
24858 ! alpha factors from Fcav/Gcav
24859           alf1   = 0.0d0
24860           alf2   = 0.0d0
24861           alf12  = 0.0d0
24862           b1 = alphasur_peppho(1)
24863 !          b1=0.0d0
24864           b2 = alphasur_peppho(2)
24865           b3 = alphasur_peppho(3)
24866           b4 = alphasur_peppho(4)
24867           CALL sc_angular
24868        sqom1=om1*om1
24869        evdwij = 0.0d0
24870        ECL = 0.0d0
24871        Elj = 0.0d0
24872        Equad = 0.0d0
24873        Epol = 0.0d0
24874        Fcav=0.0d0
24875        eheadtail = 0.0d0
24876        dGCLdR=0.0d0
24877        dGCLdOM1 = 0.0d0
24878        dGCLdOM2 = 0.0d0
24879        dGCLdOM12 = 0.0d0
24880        dPOLdOM1 = 0.0d0
24881        dPOLdOM2 = 0.0d0
24882           Fcav = 0.0d0
24883           dFdR = 0.0d0
24884           dCAVdOM1  = 0.0d0
24885           dCAVdOM2  = 0.0d0
24886           dCAVdOM12 = 0.0d0
24887           rij_shift = rij
24888           fac       = rij_shift**expon
24889           c1        = fac  * fac * aa_peppho
24890 !          c1        = 0.0d0
24891           c2        = fac  * bb_peppho
24892 !          c2        = 0.0d0
24893           evdwij    =  c1 + c2
24894 ! Now cavity....................
24895        eagle = dsqrt(1.0/rij_shift)
24896        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24897           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24898           botsq = bot * bot
24899           Fcav = top / bot
24900           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24901           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24902           dFdR = ((dtop * bot - top * dbot) / botsq)
24903        w1        = wqdip_peppho(1)
24904        w2        = wqdip_peppho(2)
24905 !       w1=0.0d0
24906 !       w2=0.0d0
24907 !       pis       = sig0head_scbase(itypi,itypj)
24908 !       eps_head   = epshead_scbase(itypi,itypj)
24909 !c!-------------------------------------------------------------------
24910
24911 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24912 !c!     &        +dhead(1,1,itypi,itypj))**2))
24913 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24914 !c!     &        +dhead(2,1,itypi,itypj))**2))
24915
24916 !c!-------------------------------------------------------------------
24917 !c! ecl
24918        sparrow  = w1  *  om1
24919        hawk     = w2 *  (1.0d0 - sqom1)
24920        Ecl = sparrow * rij_shift**2.0d0 &
24921            - hawk    * rij_shift**4.0d0
24922 !c!-------------------------------------------------------------------
24923 !c! derivative of ecl is Gcl
24924 !c! dF/dr part
24925 !       rij_shift=5.0
24926        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24927                 + 4.0d0 * hawk    * rij_shift**5.0d0
24928 !c! dF/dom1
24929        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24930 !c! dF/dom2
24931        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24932        eom1  =    dGCLdOM1+dGCLdOM2
24933        eom2  =    0.0
24934
24935           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24936 !          fac=0.0
24937           gg(1) =  fac*xj*rij
24938           gg(2) =  fac*yj*rij
24939           gg(3) =  fac*zj*rij
24940          do k=1,3
24941          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24942          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24943          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24944          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24945          gg(k)=0.0
24946          enddo
24947
24948       DO k = 1, 3
24949         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24950         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24951         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24952         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24953 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24954         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24955 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24956         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24957                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24958         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24959                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24960         enddo
24961        epeppho=epeppho+evdwij+Fcav+ECL
24962 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24963        enddo
24964        enddo
24965       end subroutine eprot_pep_phosphate
24966 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24967       subroutine emomo(evdw)
24968       use calc_data
24969       use comm_momo
24970 !      implicit real*8 (a-h,o-z)
24971 !      include 'DIMENSIONS'
24972 !      include 'COMMON.GEO'
24973 !      include 'COMMON.VAR'
24974 !      include 'COMMON.LOCAL'
24975 !      include 'COMMON.CHAIN'
24976 !      include 'COMMON.DERIV'
24977 !      include 'COMMON.NAMES'
24978 !      include 'COMMON.INTERACT'
24979 !      include 'COMMON.IOUNITS'
24980 !      include 'COMMON.CALC'
24981 !      include 'COMMON.CONTROL'
24982 !      include 'COMMON.SBRIDGE'
24983       logical :: lprn
24984 !el local variables
24985       integer :: iint,itypi1,subchap,isel
24986       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24987       real(kind=8) :: evdw
24988       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24989                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24990                     sslipi,sslipj,faclip,alpha_sco
24991       integer :: ii
24992       real(kind=8) :: fracinbuf
24993        real (kind=8) :: escpho
24994        real (kind=8),dimension(4):: ener
24995        real(kind=8) :: b1,b2,egb
24996        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24997         Lambf,&
24998         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24999         dFdOM2,dFdL,dFdOM12,&
25000         federmaus,&
25001         d1i,d1j
25002 !       real(kind=8),dimension(3,2)::erhead_tail
25003 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25004        real(kind=8) ::  facd4, adler, Fgb, facd3
25005        integer troll,jj,istate
25006        real (kind=8) :: dcosom1(3),dcosom2(3)
25007        eps_out=80.0d0
25008        sss_ele_cut=1.0d0
25009 !       print *,"EVDW KURW",evdw,nres
25010       do i=iatsc_s,iatsc_e
25011 !        print *,"I am in EVDW",i
25012         itypi=iabs(itype(i,1))
25013 !        if (i.ne.47) cycle
25014         if (itypi.eq.ntyp1) cycle
25015         itypi1=iabs(itype(i+1,1))
25016         xi=c(1,nres+i)
25017         yi=c(2,nres+i)
25018         zi=c(3,nres+i)
25019           xi=dmod(xi,boxxsize)
25020           if (xi.lt.0) xi=xi+boxxsize
25021           yi=dmod(yi,boxysize)
25022           if (yi.lt.0) yi=yi+boxysize
25023           zi=dmod(zi,boxzsize)
25024           if (zi.lt.0) zi=zi+boxzsize
25025
25026        if ((zi.gt.bordlipbot)  &
25027         .and.(zi.lt.bordliptop)) then
25028 !C the energy transfer exist
25029         if (zi.lt.buflipbot) then
25030 !C what fraction I am in
25031          fracinbuf=1.0d0-  &
25032               ((zi-bordlipbot)/lipbufthick)
25033 !C lipbufthick is thickenes of lipid buffore
25034          sslipi=sscalelip(fracinbuf)
25035          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25036         elseif (zi.gt.bufliptop) then
25037          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25038          sslipi=sscalelip(fracinbuf)
25039          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25040         else
25041          sslipi=1.0d0
25042          ssgradlipi=0.0
25043         endif
25044        else
25045          sslipi=0.0d0
25046          ssgradlipi=0.0
25047        endif
25048 !       print *, sslipi,ssgradlipi
25049         dxi=dc_norm(1,nres+i)
25050         dyi=dc_norm(2,nres+i)
25051         dzi=dc_norm(3,nres+i)
25052 !        dsci_inv=dsc_inv(itypi)
25053         dsci_inv=vbld_inv(i+nres)
25054 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25055 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25056 !
25057 ! Calculate SC interaction energy.
25058 !
25059         do iint=1,nint_gr(i)
25060           do j=istart(i,iint),iend(i,iint)
25061 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25062             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25063               call dyn_ssbond_ene(i,j,evdwij)
25064               evdw=evdw+evdwij
25065               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25066                               'evdw',i,j,evdwij,' ss'
25067 !              if (energy_dec) write (iout,*) &
25068 !                              'evdw',i,j,evdwij,' ss'
25069              do k=j+1,iend(i,iint)
25070 !C search over all next residues
25071               if (dyn_ss_mask(k)) then
25072 !C check if they are cysteins
25073 !C              write(iout,*) 'k=',k
25074
25075 !c              write(iout,*) "PRZED TRI", evdwij
25076 !               evdwij_przed_tri=evdwij
25077               call triple_ssbond_ene(i,j,k,evdwij)
25078 !c               if(evdwij_przed_tri.ne.evdwij) then
25079 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25080 !c               endif
25081
25082 !c              write(iout,*) "PO TRI", evdwij
25083 !C call the energy function that removes the artifical triple disulfide
25084 !C bond the soubroutine is located in ssMD.F
25085               evdw=evdw+evdwij
25086               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25087                             'evdw',i,j,evdwij,'tss'
25088               endif!dyn_ss_mask(k)
25089              enddo! k
25090             ELSE
25091 !el            ind=ind+1
25092             itypj=iabs(itype(j,1))
25093             if (itypj.eq.ntyp1) cycle
25094              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25095
25096 !             if (j.ne.78) cycle
25097 !            dscj_inv=dsc_inv(itypj)
25098             dscj_inv=vbld_inv(j+nres)
25099            xj=c(1,j+nres)
25100            yj=c(2,j+nres)
25101            zj=c(3,j+nres)
25102            xj=dmod(xj,boxxsize)
25103            if (xj.lt.0) xj=xj+boxxsize
25104            yj=dmod(yj,boxysize)
25105            if (yj.lt.0) yj=yj+boxysize
25106            zj=dmod(zj,boxzsize)
25107            if (zj.lt.0) zj=zj+boxzsize
25108           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25109           xj_safe=xj
25110           yj_safe=yj
25111           zj_safe=zj
25112           subchap=0
25113
25114           do xshift=-1,1
25115           do yshift=-1,1
25116           do zshift=-1,1
25117           xj=xj_safe+xshift*boxxsize
25118           yj=yj_safe+yshift*boxysize
25119           zj=zj_safe+zshift*boxzsize
25120           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25121           if(dist_temp.lt.dist_init) then
25122             dist_init=dist_temp
25123             xj_temp=xj
25124             yj_temp=yj
25125             zj_temp=zj
25126             subchap=1
25127           endif
25128           enddo
25129           enddo
25130           enddo
25131           if (subchap.eq.1) then
25132           xj=xj_temp-xi
25133           yj=yj_temp-yi
25134           zj=zj_temp-zi
25135           else
25136           xj=xj_safe-xi
25137           yj=yj_safe-yi
25138           zj=zj_safe-zi
25139           endif
25140           dxj = dc_norm( 1, nres+j )
25141           dyj = dc_norm( 2, nres+j )
25142           dzj = dc_norm( 3, nres+j )
25143 !          print *,i,j,itypi,itypj
25144 !          d1i=0.0d0
25145 !          d1j=0.0d0
25146 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25147 ! Gay-berne var's
25148 !1!          sig0ij = sigma_scsc( itypi,itypj )
25149 !          chi1=0.0d0
25150 !          chi2=0.0d0
25151 !          chip1=0.0d0
25152 !          chip2=0.0d0
25153 ! not used by momo potential, but needed by sc_angular which is shared
25154 ! by all energy_potential subroutines
25155           alf1   = 0.0d0
25156           alf2   = 0.0d0
25157           alf12  = 0.0d0
25158           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25159 !       a12sq = a12sq * a12sq
25160 ! charge of amino acid itypi is...
25161           chis1 = chis(itypi,itypj)
25162           chis2 = chis(itypj,itypi)
25163           chis12 = chis1 * chis2
25164           sig1 = sigmap1(itypi,itypj)
25165           sig2 = sigmap2(itypi,itypj)
25166 !       write (*,*) "sig1 = ", sig1
25167 !          chis1=0.0
25168 !          chis2=0.0
25169 !                    chis12 = chis1 * chis2
25170 !          sig1=0.0
25171 !          sig2=0.0
25172 !       write (*,*) "sig2 = ", sig2
25173 ! alpha factors from Fcav/Gcav
25174           b1cav = alphasur(1,itypi,itypj)
25175 !          b1cav=0.0d0
25176           b2cav = alphasur(2,itypi,itypj)
25177           b3cav = alphasur(3,itypi,itypj)
25178           b4cav = alphasur(4,itypi,itypj)
25179 ! used to determine whether we want to do quadrupole calculations
25180        eps_in = epsintab(itypi,itypj)
25181        if (eps_in.eq.0.0) eps_in=1.0
25182
25183        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25184        Rtail = 0.0d0
25185 !       dtail(1,itypi,itypj)=0.0
25186 !       dtail(2,itypi,itypj)=0.0
25187
25188        DO k = 1, 3
25189         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25190         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25191        END DO
25192 !c! tail distances will be themselves usefull elswhere
25193 !c1 (in Gcav, for example)
25194        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25195        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25196        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25197        Rtail = dsqrt( &
25198           (Rtail_distance(1)*Rtail_distance(1)) &
25199         + (Rtail_distance(2)*Rtail_distance(2)) &
25200         + (Rtail_distance(3)*Rtail_distance(3)))
25201
25202 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25203 !-------------------------------------------------------------------
25204 ! tail location and distance calculations
25205        d1 = dhead(1, 1, itypi, itypj)
25206        d2 = dhead(2, 1, itypi, itypj)
25207
25208        DO k = 1,3
25209 ! location of polar head is computed by taking hydrophobic centre
25210 ! and moving by a d1 * dc_norm vector
25211 ! see unres publications for very informative images
25212         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25213         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25214 ! distance
25215 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25216 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25217         Rhead_distance(k) = chead(k,2) - chead(k,1)
25218        END DO
25219 ! pitagoras (root of sum of squares)
25220        Rhead = dsqrt( &
25221           (Rhead_distance(1)*Rhead_distance(1)) &
25222         + (Rhead_distance(2)*Rhead_distance(2)) &
25223         + (Rhead_distance(3)*Rhead_distance(3)))
25224 !-------------------------------------------------------------------
25225 ! zero everything that should be zero'ed
25226        evdwij = 0.0d0
25227        ECL = 0.0d0
25228        Elj = 0.0d0
25229        Equad = 0.0d0
25230        Epol = 0.0d0
25231        Fcav=0.0d0
25232        eheadtail = 0.0d0
25233        dGCLdOM1 = 0.0d0
25234        dGCLdOM2 = 0.0d0
25235        dGCLdOM12 = 0.0d0
25236        dPOLdOM1 = 0.0d0
25237        dPOLdOM2 = 0.0d0
25238           Fcav = 0.0d0
25239           dFdR = 0.0d0
25240           dCAVdOM1  = 0.0d0
25241           dCAVdOM2  = 0.0d0
25242           dCAVdOM12 = 0.0d0
25243           dscj_inv = vbld_inv(j+nres)
25244 !          print *,i,j,dscj_inv,dsci_inv
25245 ! rij holds 1/(distance of Calpha atoms)
25246           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25247           rij  = dsqrt(rrij)
25248 !----------------------------
25249           CALL sc_angular
25250 ! this should be in elgrad_init but om's are calculated by sc_angular
25251 ! which in turn is used by older potentials
25252 ! om = omega, sqom = om^2
25253           sqom1  = om1 * om1
25254           sqom2  = om2 * om2
25255           sqom12 = om12 * om12
25256
25257 ! now we calculate EGB - Gey-Berne
25258 ! It will be summed up in evdwij and saved in evdw
25259           sigsq     = 1.0D0  / sigsq
25260           sig       = sig0ij * dsqrt(sigsq)
25261 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25262           rij_shift = Rtail - sig + sig0ij
25263           IF (rij_shift.le.0.0D0) THEN
25264            evdw = 1.0D20
25265            RETURN
25266           END IF
25267           sigder = -sig * sigsq
25268           rij_shift = 1.0D0 / rij_shift
25269           fac       = rij_shift**expon
25270           c1        = fac  * fac * aa_aq(itypi,itypj)
25271 !          print *,"ADAM",aa_aq(itypi,itypj)
25272
25273 !          c1        = 0.0d0
25274           c2        = fac  * bb_aq(itypi,itypj)
25275 !          c2        = 0.0d0
25276           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25277           eps2der   = eps3rt * evdwij
25278           eps3der   = eps2rt * evdwij
25279 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25280           evdwij    = eps2rt * eps3rt * evdwij
25281 !#ifdef TSCSC
25282 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25283 !           evdw_p = evdw_p + evdwij
25284 !          ELSE
25285 !           evdw_m = evdw_m + evdwij
25286 !          END IF
25287 !#else
25288           evdw = evdw  &
25289               + evdwij
25290 !#endif
25291
25292           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25293           fac    = -expon * (c1 + evdwij) * rij_shift
25294           sigder = fac * sigder
25295 !          fac    = rij * fac
25296 ! Calculate distance derivative
25297           gg(1) =  fac
25298           gg(2) =  fac
25299           gg(3) =  fac
25300 !          if (b2.gt.0.0) then
25301           fac = chis1 * sqom1 + chis2 * sqom2 &
25302           - 2.0d0 * chis12 * om1 * om2 * om12
25303 ! we will use pom later in Gcav, so dont mess with it!
25304           pom = 1.0d0 - chis1 * chis2 * sqom12
25305           Lambf = (1.0d0 - (fac / pom))
25306 !          print *,"fac,pom",fac,pom,Lambf
25307           Lambf = dsqrt(Lambf)
25308           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25309 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25310 !       write (*,*) "sparrow = ", sparrow
25311           Chif = Rtail * sparrow
25312 !           print *,"rij,sparrow",rij , sparrow
25313           ChiLambf = Chif * Lambf
25314           eagle = dsqrt(ChiLambf)
25315           bat = ChiLambf ** 11.0d0
25316           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25317           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25318           botsq = bot * bot
25319 !          print *,top,bot,"bot,top",ChiLambf,Chif
25320           Fcav = top / bot
25321
25322        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25323        dbot = 12.0d0 * b4cav * bat * Lambf
25324        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25325
25326           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25327           dbot = 12.0d0 * b4cav * bat * Chif
25328           eagle = Lambf * pom
25329           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25330           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25331           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25332               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25333
25334           dFdL = ((dtop * bot - top * dbot) / botsq)
25335 !       dFdL = 0.0d0
25336           dCAVdOM1  = dFdL * ( dFdOM1 )
25337           dCAVdOM2  = dFdL * ( dFdOM2 )
25338           dCAVdOM12 = dFdL * ( dFdOM12 )
25339
25340        DO k= 1, 3
25341         ertail(k) = Rtail_distance(k)/Rtail
25342        END DO
25343        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25344        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25345        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25346        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25347        DO k = 1, 3
25348 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25349 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25350         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25351         gvdwx(k,i) = gvdwx(k,i) &
25352                   - (( dFdR + gg(k) ) * pom)
25353 !c!     &             - ( dFdR * pom )
25354         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25355         gvdwx(k,j) = gvdwx(k,j)   &
25356                   + (( dFdR + gg(k) ) * pom)
25357 !c!     &             + ( dFdR * pom )
25358
25359         gvdwc(k,i) = gvdwc(k,i)  &
25360                   - (( dFdR + gg(k) ) * ertail(k))
25361 !c!     &             - ( dFdR * ertail(k))
25362
25363         gvdwc(k,j) = gvdwc(k,j) &
25364                   + (( dFdR + gg(k) ) * ertail(k))
25365 !c!     &             + ( dFdR * ertail(k))
25366
25367         gg(k) = 0.0d0
25368 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25369 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25370       END DO
25371
25372
25373 !c! Compute head-head and head-tail energies for each state
25374
25375           isel = iabs(Qi) + iabs(Qj)
25376 ! double charge for Phophorylated! itype - 25,27,27
25377 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25378 !            Qi=Qi*2
25379 !            Qij=Qij*2
25380 !           endif
25381 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25382 !            Qj=Qj*2
25383 !            Qij=Qij*2
25384 !           endif
25385
25386 !          isel=0
25387           IF (isel.eq.0) THEN
25388 !c! No charges - do nothing
25389            eheadtail = 0.0d0
25390
25391           ELSE IF (isel.eq.4) THEN
25392 !c! Calculate dipole-dipole interactions
25393            CALL edd(ecl)
25394            eheadtail = ECL
25395 !           eheadtail = 0.0d0
25396
25397           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25398 !c! Charge-nonpolar interactions
25399           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25400             Qi=Qi*2
25401             Qij=Qij*2
25402            endif
25403           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25404             Qj=Qj*2
25405             Qij=Qij*2
25406            endif
25407
25408            CALL eqn(epol)
25409            eheadtail = epol
25410 !           eheadtail = 0.0d0
25411
25412           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25413 !c! Nonpolar-charge interactions
25414           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25415             Qi=Qi*2
25416             Qij=Qij*2
25417            endif
25418           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25419             Qj=Qj*2
25420             Qij=Qij*2
25421            endif
25422
25423            CALL enq(epol)
25424            eheadtail = epol
25425 !           eheadtail = 0.0d0
25426
25427           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25428 !c! Charge-dipole interactions
25429           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25430             Qi=Qi*2
25431             Qij=Qij*2
25432            endif
25433           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25434             Qj=Qj*2
25435             Qij=Qij*2
25436            endif
25437
25438            CALL eqd(ecl, elj, epol)
25439            eheadtail = ECL + elj + epol
25440 !           eheadtail = 0.0d0
25441
25442           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25443 !c! Dipole-charge interactions
25444           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25445             Qi=Qi*2
25446             Qij=Qij*2
25447            endif
25448           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25449             Qj=Qj*2
25450             Qij=Qij*2
25451            endif
25452            CALL edq(ecl, elj, epol)
25453           eheadtail = ECL + elj + epol
25454 !           eheadtail = 0.0d0
25455
25456           ELSE IF ((isel.eq.2.and.   &
25457                iabs(Qi).eq.1).and.  &
25458                nstate(itypi,itypj).eq.1) THEN
25459 !c! Same charge-charge interaction ( +/+ or -/- )
25460           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25461             Qi=Qi*2
25462             Qij=Qij*2
25463            endif
25464           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25465             Qj=Qj*2
25466             Qij=Qij*2
25467            endif
25468
25469            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25470            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25471 !           eheadtail = 0.0d0
25472
25473           ELSE IF ((isel.eq.2.and.  &
25474                iabs(Qi).eq.1).and. &
25475                nstate(itypi,itypj).ne.1) THEN
25476 !c! Different charge-charge interaction ( +/- or -/+ )
25477           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25478             Qi=Qi*2
25479             Qij=Qij*2
25480            endif
25481           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25482             Qj=Qj*2
25483             Qij=Qij*2
25484            endif
25485
25486            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25487           END IF
25488        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25489       evdw = evdw  + Fcav + eheadtail
25490
25491        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25492         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25493         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25494         Equad,evdwij+Fcav+eheadtail,evdw
25495 !       evdw = evdw  + Fcav  + eheadtail
25496
25497         iF (nstate(itypi,itypj).eq.1) THEN
25498         CALL sc_grad
25499        END IF
25500 !c!-------------------------------------------------------------------
25501 !c! NAPISY KONCOWE
25502          END DO   ! j
25503         END DO    ! iint
25504        END DO     ! i
25505 !c      write (iout,*) "Number of loop steps in EGB:",ind
25506 !c      energy_dec=.false.
25507 !              print *,"EVDW KURW",evdw,nres
25508
25509        RETURN
25510       END SUBROUTINE emomo
25511 !C------------------------------------------------------------------------------------
25512       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25513       use calc_data
25514       use comm_momo
25515        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25516          Ecl,Egb,Epol,Fisocav,Elj,Fgb
25517 !       integer :: k
25518 !c! Epol and Gpol analytical parameters
25519        alphapol1 = alphapol(itypi,itypj)
25520        alphapol2 = alphapol(itypj,itypi)
25521 !c! Fisocav and Gisocav analytical parameters
25522        al1  = alphiso(1,itypi,itypj)
25523        al2  = alphiso(2,itypi,itypj)
25524        al3  = alphiso(3,itypi,itypj)
25525        al4  = alphiso(4,itypi,itypj)
25526        csig = (1.0d0  &
25527            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25528            + sigiso2(itypi,itypj)**2.0d0))
25529 !c!
25530        pis  = sig0head(itypi,itypj)
25531        eps_head = epshead(itypi,itypj)
25532        Rhead_sq = Rhead * Rhead
25533 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25534 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25535        R1 = 0.0d0
25536        R2 = 0.0d0
25537        DO k = 1, 3
25538 !c! Calculate head-to-tail distances needed by Epol
25539         R1=R1+(ctail(k,2)-chead(k,1))**2
25540         R2=R2+(chead(k,2)-ctail(k,1))**2
25541        END DO
25542 !c! Pitagoras
25543        R1 = dsqrt(R1)
25544        R2 = dsqrt(R2)
25545
25546 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25547 !c!     &        +dhead(1,1,itypi,itypj))**2))
25548 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25549 !c!     &        +dhead(2,1,itypi,itypj))**2))
25550
25551 !c!-------------------------------------------------------------------
25552 !c! Coulomb electrostatic interaction
25553        Ecl = (332.0d0 * Qij) / Rhead
25554 !c! derivative of Ecl is Gcl...
25555        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25556        dGCLdOM1 = 0.0d0
25557        dGCLdOM2 = 0.0d0
25558        dGCLdOM12 = 0.0d0
25559        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25560        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25561        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25562 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25563 !c! Derivative of Egb is Ggb...
25564        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25565        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25566        dGGBdR = dGGBdFGB * dFGBdR
25567 !c!-------------------------------------------------------------------
25568 !c! Fisocav - isotropic cavity creation term
25569 !c! or "how much energy it costs to put charged head in water"
25570        pom = Rhead * csig
25571        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25572        bot = (1.0d0 + al4 * pom**12.0d0)
25573        botsq = bot * bot
25574        FisoCav = top / bot
25575 !      write (*,*) "Rhead = ",Rhead
25576 !      write (*,*) "csig = ",csig
25577 !      write (*,*) "pom = ",pom
25578 !      write (*,*) "al1 = ",al1
25579 !      write (*,*) "al2 = ",al2
25580 !      write (*,*) "al3 = ",al3
25581 !      write (*,*) "al4 = ",al4
25582 !        write (*,*) "top = ",top
25583 !        write (*,*) "bot = ",bot
25584 !c! Derivative of Fisocav is GCV...
25585        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25586        dbot = 12.0d0 * al4 * pom ** 11.0d0
25587        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25588 !c!-------------------------------------------------------------------
25589 !c! Epol
25590 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25591        MomoFac1 = (1.0d0 - chi1 * sqom2)
25592        MomoFac2 = (1.0d0 - chi2 * sqom1)
25593        RR1  = ( R1 * R1 ) / MomoFac1
25594        RR2  = ( R2 * R2 ) / MomoFac2
25595        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25596        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25597        fgb1 = sqrt( RR1 + a12sq * ee1 )
25598        fgb2 = sqrt( RR2 + a12sq * ee2 )
25599        epol = 332.0d0 * eps_inout_fac * ( &
25600       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25601 !c!       epol = 0.0d0
25602        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25603                / (fgb1 ** 5.0d0)
25604        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25605                / (fgb2 ** 5.0d0)
25606        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25607              / ( 2.0d0 * fgb1 )
25608        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25609              / ( 2.0d0 * fgb2 )
25610        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25611                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25612        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25613                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25614        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25615 !c!       dPOLdR1 = 0.0d0
25616        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25617 !c!       dPOLdR2 = 0.0d0
25618        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25619 !c!       dPOLdOM1 = 0.0d0
25620        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25621 !c!       dPOLdOM2 = 0.0d0
25622 !c!-------------------------------------------------------------------
25623 !c! Elj
25624 !c! Lennard-Jones 6-12 interaction between heads
25625        pom = (pis / Rhead)**6.0d0
25626        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25627 !c! derivative of Elj is Glj
25628        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25629              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25630 !c!-------------------------------------------------------------------
25631 !c! Return the results
25632 !c! These things do the dRdX derivatives, that is
25633 !c! allow us to change what we see from function that changes with
25634 !c! distance to function that changes with LOCATION (of the interaction
25635 !c! site)
25636        DO k = 1, 3
25637         erhead(k) = Rhead_distance(k)/Rhead
25638         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25639         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25640        END DO
25641
25642        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25643        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25644        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25645        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25646        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25647        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25648        facd1 = d1 * vbld_inv(i+nres)
25649        facd2 = d2 * vbld_inv(j+nres)
25650        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25651        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25652
25653 !c! Now we add appropriate partial derivatives (one in each dimension)
25654        DO k = 1, 3
25655         hawk   = (erhead_tail(k,1) + &
25656         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25657         condor = (erhead_tail(k,2) + &
25658         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25659
25660         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25661         gvdwx(k,i) = gvdwx(k,i) &
25662                   - dGCLdR * pom&
25663                   - dGGBdR * pom&
25664                   - dGCVdR * pom&
25665                   - dPOLdR1 * hawk&
25666                   - dPOLdR2 * (erhead_tail(k,2)&
25667       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25668                   - dGLJdR * pom
25669
25670         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25671         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25672                    + dGGBdR * pom+ dGCVdR * pom&
25673                   + dPOLdR1 * (erhead_tail(k,1)&
25674       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25675                   + dPOLdR2 * condor + dGLJdR * pom
25676
25677         gvdwc(k,i) = gvdwc(k,i)  &
25678                   - dGCLdR * erhead(k)&
25679                   - dGGBdR * erhead(k)&
25680                   - dGCVdR * erhead(k)&
25681                   - dPOLdR1 * erhead_tail(k,1)&
25682                   - dPOLdR2 * erhead_tail(k,2)&
25683                   - dGLJdR * erhead(k)
25684
25685         gvdwc(k,j) = gvdwc(k,j)         &
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        END DO
25694        RETURN
25695       END SUBROUTINE eqq
25696 !c!-------------------------------------------------------------------
25697       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25698       use comm_momo
25699       use calc_data
25700
25701        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25702        double precision ener(4)
25703        double precision dcosom1(3),dcosom2(3)
25704 !c! used in Epol derivatives
25705        double precision facd3, facd4
25706        double precision federmaus, adler
25707        integer istate,ii,jj
25708        real (kind=8) :: Fgb
25709 !       print *,"CALLING EQUAD"
25710 !c! Epol and Gpol analytical parameters
25711        alphapol1 = alphapol(itypi,itypj)
25712        alphapol2 = alphapol(itypj,itypi)
25713 !c! Fisocav and Gisocav analytical parameters
25714        al1  = alphiso(1,itypi,itypj)
25715        al2  = alphiso(2,itypi,itypj)
25716        al3  = alphiso(3,itypi,itypj)
25717        al4  = alphiso(4,itypi,itypj)
25718        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25719             + sigiso2(itypi,itypj)**2.0d0))
25720 !c!
25721        w1   = wqdip(1,itypi,itypj)
25722        w2   = wqdip(2,itypi,itypj)
25723        pis  = sig0head(itypi,itypj)
25724        eps_head = epshead(itypi,itypj)
25725 !c! First things first:
25726 !c! We need to do sc_grad's job with GB and Fcav
25727        eom1  = eps2der * eps2rt_om1 &
25728              - 2.0D0 * alf1 * eps3der&
25729              + sigder * sigsq_om1&
25730              + dCAVdOM1
25731        eom2  = eps2der * eps2rt_om2 &
25732              + 2.0D0 * alf2 * eps3der&
25733              + sigder * sigsq_om2&
25734              + dCAVdOM2
25735        eom12 =  evdwij  * eps1_om12 &
25736              + eps2der * eps2rt_om12 &
25737              - 2.0D0 * alf12 * eps3der&
25738              + sigder *sigsq_om12&
25739              + dCAVdOM12
25740 !c! now some magical transformations to project gradient into
25741 !c! three cartesian vectors
25742        DO k = 1, 3
25743         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25744         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25745         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25746 !c! this acts on hydrophobic center of interaction
25747         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25748                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25749                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25750         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25751                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25752                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25753 !c! this acts on Calpha
25754         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25755         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25756        END DO
25757 !c! sc_grad is done, now we will compute
25758        eheadtail = 0.0d0
25759        eom1 = 0.0d0
25760        eom2 = 0.0d0
25761        eom12 = 0.0d0
25762        DO istate = 1, nstate(itypi,itypj)
25763 !c*************************************************************
25764         IF (istate.ne.1) THEN
25765          IF (istate.lt.3) THEN
25766           ii = 1
25767          ELSE
25768           ii = 2
25769          END IF
25770         jj = istate/ii
25771         d1 = dhead(1,ii,itypi,itypj)
25772         d2 = dhead(2,jj,itypi,itypj)
25773         DO k = 1,3
25774          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25775          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25776          Rhead_distance(k) = chead(k,2) - chead(k,1)
25777         END DO
25778 !c! pitagoras (root of sum of squares)
25779         Rhead = dsqrt( &
25780                (Rhead_distance(1)*Rhead_distance(1))  &
25781              + (Rhead_distance(2)*Rhead_distance(2))  &
25782              + (Rhead_distance(3)*Rhead_distance(3)))
25783         END IF
25784         Rhead_sq = Rhead * Rhead
25785
25786 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25787 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25788         R1 = 0.0d0
25789         R2 = 0.0d0
25790         DO k = 1, 3
25791 !c! Calculate head-to-tail distances
25792          R1=R1+(ctail(k,2)-chead(k,1))**2
25793          R2=R2+(chead(k,2)-ctail(k,1))**2
25794         END DO
25795 !c! Pitagoras
25796         R1 = dsqrt(R1)
25797         R2 = dsqrt(R2)
25798         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25799 !c!        Ecl = 0.0d0
25800 !c!        write (*,*) "Ecl = ", Ecl
25801 !c! derivative of Ecl is Gcl...
25802         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25803 !c!        dGCLdR = 0.0d0
25804         dGCLdOM1 = 0.0d0
25805         dGCLdOM2 = 0.0d0
25806         dGCLdOM12 = 0.0d0
25807 !c!-------------------------------------------------------------------
25808 !c! Generalised Born Solvent Polarization
25809         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25810         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25811         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25812 !c!        Egb = 0.0d0
25813 !c!      write (*,*) "a1*a2 = ", a12sq
25814 !c!      write (*,*) "Rhead = ", Rhead
25815 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25816 !c!      write (*,*) "ee = ", ee
25817 !c!      write (*,*) "Fgb = ", Fgb
25818 !c!      write (*,*) "fac = ", eps_inout_fac
25819 !c!      write (*,*) "Qij = ", Qij
25820 !c!      write (*,*) "Egb = ", Egb
25821 !c! Derivative of Egb is Ggb...
25822 !c! dFGBdR is used by Quad's later...
25823         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25824         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25825                / ( 2.0d0 * Fgb )
25826         dGGBdR = dGGBdFGB * dFGBdR
25827 !c!        dGGBdR = 0.0d0
25828 !c!-------------------------------------------------------------------
25829 !c! Fisocav - isotropic cavity creation term
25830         pom = Rhead * csig
25831         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25832         bot = (1.0d0 + al4 * pom**12.0d0)
25833         botsq = bot * bot
25834         FisoCav = top / bot
25835         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25836         dbot = 12.0d0 * al4 * pom ** 11.0d0
25837         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25838 !c!        dGCVdR = 0.0d0
25839 !c!-------------------------------------------------------------------
25840 !c! Polarization energy
25841 !c! Epol
25842         MomoFac1 = (1.0d0 - chi1 * sqom2)
25843         MomoFac2 = (1.0d0 - chi2 * sqom1)
25844         RR1  = ( R1 * R1 ) / MomoFac1
25845         RR2  = ( R2 * R2 ) / MomoFac2
25846         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25847         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25848         fgb1 = sqrt( RR1 + a12sq * ee1 )
25849         fgb2 = sqrt( RR2 + a12sq * ee2 )
25850         epol = 332.0d0 * eps_inout_fac * (&
25851         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25852 !c!        epol = 0.0d0
25853 !c! derivative of Epol is Gpol...
25854         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25855                   / (fgb1 ** 5.0d0)
25856         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25857                   / (fgb2 ** 5.0d0)
25858         dFGBdR1 = ( (R1 / MomoFac1) &
25859                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25860                 / ( 2.0d0 * fgb1 )
25861         dFGBdR2 = ( (R2 / MomoFac2) &
25862                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25863                 / ( 2.0d0 * fgb2 )
25864         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25865                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25866                  / ( 2.0d0 * fgb1 )
25867         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25868                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25869                  / ( 2.0d0 * fgb2 )
25870         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25871 !c!        dPOLdR1 = 0.0d0
25872         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25873 !c!        dPOLdR2 = 0.0d0
25874         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25875 !c!        dPOLdOM1 = 0.0d0
25876         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25877         pom = (pis / Rhead)**6.0d0
25878         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25879 !c!        Elj = 0.0d0
25880 !c! derivative of Elj is Glj
25881         dGLJdR = 4.0d0 * eps_head &
25882             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25883             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25884 !c!        dGLJdR = 0.0d0
25885 !c!-------------------------------------------------------------------
25886 !c! Equad
25887        IF (Wqd.ne.0.0d0) THEN
25888         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25889              - 37.5d0  * ( sqom1 + sqom2 ) &
25890              + 157.5d0 * ( sqom1 * sqom2 ) &
25891              - 45.0d0  * om1*om2*om12
25892         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25893         Equad = fac * Beta1
25894 !c!        Equad = 0.0d0
25895 !c! derivative of Equad...
25896         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25897 !c!        dQUADdR = 0.0d0
25898         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25899 !c!        dQUADdOM1 = 0.0d0
25900         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25901 !c!        dQUADdOM2 = 0.0d0
25902         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25903        ELSE
25904          Beta1 = 0.0d0
25905          Equad = 0.0d0
25906         END IF
25907 !c!-------------------------------------------------------------------
25908 !c! Return the results
25909 !c! Angular stuff
25910         eom1 = dPOLdOM1 + dQUADdOM1
25911         eom2 = dPOLdOM2 + dQUADdOM2
25912         eom12 = dQUADdOM12
25913 !c! now some magical transformations to project gradient into
25914 !c! three cartesian vectors
25915         DO k = 1, 3
25916          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25917          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25918          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25919         END DO
25920 !c! Radial stuff
25921         DO k = 1, 3
25922          erhead(k) = Rhead_distance(k)/Rhead
25923          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25924          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25925         END DO
25926         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25927         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25928         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25929         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25930         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25931         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25932         facd1 = d1 * vbld_inv(i+nres)
25933         facd2 = d2 * vbld_inv(j+nres)
25934         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25935         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25936         DO k = 1, 3
25937          hawk   = erhead_tail(k,1) + &
25938          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25939          condor = erhead_tail(k,2) + &
25940          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25941
25942          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25943 !c! this acts on hydrophobic center of interaction
25944          gheadtail(k,1,1) = gheadtail(k,1,1) &
25945                          - dGCLdR * pom &
25946                          - dGGBdR * pom &
25947                          - dGCVdR * pom &
25948                          - dPOLdR1 * hawk &
25949                          - dPOLdR2 * (erhead_tail(k,2) &
25950       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25951                          - dGLJdR * pom &
25952                          - dQUADdR * pom&
25953                          - tuna(k) &
25954                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25955                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25956
25957          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25958 !c! this acts on hydrophobic center of interaction
25959          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25960                          + dGCLdR * pom      &
25961                          + dGGBdR * pom      &
25962                          + dGCVdR * pom      &
25963                          + dPOLdR1 * (erhead_tail(k,1) &
25964       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25965                          + dPOLdR2 * condor &
25966                          + dGLJdR * pom &
25967                          + dQUADdR * pom &
25968                          + tuna(k) &
25969                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25970                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25971
25972 !c! this acts on Calpha
25973          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25974                          - dGCLdR * erhead(k)&
25975                          - dGGBdR * erhead(k)&
25976                          - dGCVdR * erhead(k)&
25977                          - dPOLdR1 * erhead_tail(k,1)&
25978                          - dPOLdR2 * erhead_tail(k,2)&
25979                          - dGLJdR * erhead(k) &
25980                          - dQUADdR * erhead(k)&
25981                          - tuna(k)
25982 !c! this acts on Calpha
25983          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25984                           + dGCLdR * erhead(k) &
25985                           + dGGBdR * erhead(k) &
25986                           + dGCVdR * erhead(k) &
25987                           + dPOLdR1 * erhead_tail(k,1) &
25988                           + dPOLdR2 * erhead_tail(k,2) &
25989                           + dGLJdR * erhead(k) &
25990                           + dQUADdR * erhead(k)&
25991                           + tuna(k)
25992         END DO
25993         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25994         eheadtail = eheadtail &
25995                   + wstate(istate, itypi, itypj) &
25996                   * dexp(-betaT * ener(istate))
25997 !c! foreach cartesian dimension
25998         DO k = 1, 3
25999 !c! foreach of two gvdwx and gvdwc
26000          DO l = 1, 4
26001           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26002                            + wstate( istate, itypi, itypj ) &
26003                            * dexp(-betaT * ener(istate)) &
26004                            * gheadtail(k,l,1)
26005           gheadtail(k,l,1) = 0.0d0
26006          END DO
26007         END DO
26008        END DO
26009 !c! Here ended the gigantic DO istate = 1, 4, which starts
26010 !c! at the beggining of the subroutine
26011
26012        DO k = 1, 3
26013         DO l = 1, 4
26014          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26015         END DO
26016         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26017         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26018         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26019         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26020         DO l = 1, 4
26021          gheadtail(k,l,1) = 0.0d0
26022          gheadtail(k,l,2) = 0.0d0
26023         END DO
26024        END DO
26025        eheadtail = (-dlog(eheadtail)) / betaT
26026        dPOLdOM1 = 0.0d0
26027        dPOLdOM2 = 0.0d0
26028        dQUADdOM1 = 0.0d0
26029        dQUADdOM2 = 0.0d0
26030        dQUADdOM12 = 0.0d0
26031        RETURN
26032       END SUBROUTINE energy_quad
26033 !!-----------------------------------------------------------
26034       SUBROUTINE eqn(Epol)
26035       use comm_momo
26036       use calc_data
26037
26038       double precision  facd4, federmaus,epol
26039       alphapol1 = alphapol(itypi,itypj)
26040 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26041        R1 = 0.0d0
26042        DO k = 1, 3
26043 !c! Calculate head-to-tail distances
26044         R1=R1+(ctail(k,2)-chead(k,1))**2
26045        END DO
26046 !c! Pitagoras
26047        R1 = dsqrt(R1)
26048
26049 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26050 !c!     &        +dhead(1,1,itypi,itypj))**2))
26051 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26052 !c!     &        +dhead(2,1,itypi,itypj))**2))
26053 !c--------------------------------------------------------------------
26054 !c Polarization energy
26055 !c Epol
26056        MomoFac1 = (1.0d0 - chi1 * sqom2)
26057        RR1  = R1 * R1 / MomoFac1
26058        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26059        fgb1 = sqrt( RR1 + a12sq * ee1)
26060        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26061        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26062                / (fgb1 ** 5.0d0)
26063        dFGBdR1 = ( (R1 / MomoFac1) &
26064               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26065               / ( 2.0d0 * fgb1 )
26066        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26067                 * (2.0d0 - 0.5d0 * ee1) ) &
26068                 / (2.0d0 * fgb1)
26069        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26070 !c!       dPOLdR1 = 0.0d0
26071        dPOLdOM1 = 0.0d0
26072        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26073        DO k = 1, 3
26074         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26075        END DO
26076        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26077        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26078        facd1 = d1 * vbld_inv(i+nres)
26079        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26080
26081        DO k = 1, 3
26082         hawk = (erhead_tail(k,1) + &
26083         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26084
26085         gvdwx(k,i) = gvdwx(k,i) &
26086                    - dPOLdR1 * hawk
26087         gvdwx(k,j) = gvdwx(k,j) &
26088                    + dPOLdR1 * (erhead_tail(k,1) &
26089        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26090
26091         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26092         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26093
26094        END DO
26095        RETURN
26096       END SUBROUTINE eqn
26097       SUBROUTINE enq(Epol)
26098       use calc_data
26099       use comm_momo
26100        double precision facd3, adler,epol
26101        alphapol2 = alphapol(itypj,itypi)
26102 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26103        R2 = 0.0d0
26104        DO k = 1, 3
26105 !c! Calculate head-to-tail distances
26106         R2=R2+(chead(k,2)-ctail(k,1))**2
26107        END DO
26108 !c! Pitagoras
26109        R2 = dsqrt(R2)
26110
26111 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26112 !c!     &        +dhead(1,1,itypi,itypj))**2))
26113 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26114 !c!     &        +dhead(2,1,itypi,itypj))**2))
26115 !c------------------------------------------------------------------------
26116 !c Polarization energy
26117        MomoFac2 = (1.0d0 - chi2 * sqom1)
26118        RR2  = R2 * R2 / MomoFac2
26119        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26120        fgb2 = sqrt(RR2  + a12sq * ee2)
26121        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26122        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26123                 / (fgb2 ** 5.0d0)
26124        dFGBdR2 = ( (R2 / MomoFac2)  &
26125               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26126               / (2.0d0 * fgb2)
26127        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26128                 * (2.0d0 - 0.5d0 * ee2) ) &
26129                 / (2.0d0 * fgb2)
26130        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26131 !c!       dPOLdR2 = 0.0d0
26132        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26133 !c!       dPOLdOM1 = 0.0d0
26134        dPOLdOM2 = 0.0d0
26135 !c!-------------------------------------------------------------------
26136 !c! Return the results
26137 !c! (See comments in Eqq)
26138        DO k = 1, 3
26139         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26140        END DO
26141        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26142        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26143        facd2 = d2 * vbld_inv(j+nres)
26144        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26145        DO k = 1, 3
26146         condor = (erhead_tail(k,2) &
26147        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26148
26149         gvdwx(k,i) = gvdwx(k,i) &
26150                    - dPOLdR2 * (erhead_tail(k,2) &
26151        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26152         gvdwx(k,j) = gvdwx(k,j)   &
26153                    + dPOLdR2 * condor
26154
26155         gvdwc(k,i) = gvdwc(k,i) &
26156                    - dPOLdR2 * erhead_tail(k,2)
26157         gvdwc(k,j) = gvdwc(k,j) &
26158                    + dPOLdR2 * erhead_tail(k,2)
26159
26160        END DO
26161       RETURN
26162       END SUBROUTINE enq
26163       SUBROUTINE eqd(Ecl,Elj,Epol)
26164       use calc_data
26165       use comm_momo
26166        double precision  facd4, federmaus,ecl,elj,epol
26167        alphapol1 = alphapol(itypi,itypj)
26168        w1        = wqdip(1,itypi,itypj)
26169        w2        = wqdip(2,itypi,itypj)
26170        pis       = sig0head(itypi,itypj)
26171        eps_head   = epshead(itypi,itypj)
26172 !c!-------------------------------------------------------------------
26173 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26174        R1 = 0.0d0
26175        DO k = 1, 3
26176 !c! Calculate head-to-tail distances
26177         R1=R1+(ctail(k,2)-chead(k,1))**2
26178        END DO
26179 !c! Pitagoras
26180        R1 = dsqrt(R1)
26181
26182 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26183 !c!     &        +dhead(1,1,itypi,itypj))**2))
26184 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26185 !c!     &        +dhead(2,1,itypi,itypj))**2))
26186
26187 !c!-------------------------------------------------------------------
26188 !c! ecl
26189        sparrow  = w1 * Qi * om1
26190        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26191        Ecl = sparrow / Rhead**2.0d0 &
26192            - hawk    / Rhead**4.0d0
26193        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26194                  + 4.0d0 * hawk    / Rhead**5.0d0
26195 !c! dF/dom1
26196        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26197 !c! dF/dom2
26198        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26199 !c--------------------------------------------------------------------
26200 !c Polarization energy
26201 !c Epol
26202        MomoFac1 = (1.0d0 - chi1 * sqom2)
26203        RR1  = R1 * R1 / MomoFac1
26204        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26205        fgb1 = sqrt( RR1 + a12sq * ee1)
26206        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26207 !c!       epol = 0.0d0
26208 !c!------------------------------------------------------------------
26209 !c! derivative of Epol is Gpol...
26210        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26211                / (fgb1 ** 5.0d0)
26212        dFGBdR1 = ( (R1 / MomoFac1)  &
26213              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26214              / ( 2.0d0 * fgb1 )
26215        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26216                * (2.0d0 - 0.5d0 * ee1) ) &
26217                / (2.0d0 * fgb1)
26218        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26219 !c!       dPOLdR1 = 0.0d0
26220        dPOLdOM1 = 0.0d0
26221        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26222 !c!       dPOLdOM2 = 0.0d0
26223 !c!-------------------------------------------------------------------
26224 !c! Elj
26225        pom = (pis / Rhead)**6.0d0
26226        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26227 !c! derivative of Elj is Glj
26228        dGLJdR = 4.0d0 * eps_head &
26229           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26230           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26231        DO k = 1, 3
26232         erhead(k) = Rhead_distance(k)/Rhead
26233         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26234        END DO
26235
26236        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26237        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26238        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26239        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26240        facd1 = d1 * vbld_inv(i+nres)
26241        facd2 = d2 * vbld_inv(j+nres)
26242        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26243
26244        DO k = 1, 3
26245         hawk = (erhead_tail(k,1) +  &
26246         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26247
26248         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26249         gvdwx(k,i) = gvdwx(k,i)  &
26250                    - dGCLdR * pom&
26251                    - dPOLdR1 * hawk &
26252                    - dGLJdR * pom
26253
26254         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26255         gvdwx(k,j) = gvdwx(k,j)    &
26256                    + dGCLdR * pom  &
26257                    + dPOLdR1 * (erhead_tail(k,1) &
26258        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26259                    + dGLJdR * pom
26260
26261
26262         gvdwc(k,i) = gvdwc(k,i)          &
26263                    - dGCLdR * erhead(k)  &
26264                    - dPOLdR1 * erhead_tail(k,1) &
26265                    - dGLJdR * erhead(k)
26266
26267         gvdwc(k,j) = gvdwc(k,j)          &
26268                    + dGCLdR * erhead(k)  &
26269                    + dPOLdR1 * erhead_tail(k,1) &
26270                    + dGLJdR * erhead(k)
26271
26272        END DO
26273        RETURN
26274       END SUBROUTINE eqd
26275       SUBROUTINE edq(Ecl,Elj,Epol)
26276 !       IMPLICIT NONE
26277        use comm_momo
26278       use calc_data
26279
26280       double precision  facd3, adler,ecl,elj,epol
26281        alphapol2 = alphapol(itypj,itypi)
26282        w1        = wqdip(1,itypi,itypj)
26283        w2        = wqdip(2,itypi,itypj)
26284        pis       = sig0head(itypi,itypj)
26285        eps_head  = epshead(itypi,itypj)
26286 !c!-------------------------------------------------------------------
26287 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26288        R2 = 0.0d0
26289        DO k = 1, 3
26290 !c! Calculate head-to-tail distances
26291         R2=R2+(chead(k,2)-ctail(k,1))**2
26292        END DO
26293 !c! Pitagoras
26294        R2 = dsqrt(R2)
26295
26296 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26297 !c!     &        +dhead(1,1,itypi,itypj))**2))
26298 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26299 !c!     &        +dhead(2,1,itypi,itypj))**2))
26300
26301
26302 !c!-------------------------------------------------------------------
26303 !c! ecl
26304        sparrow  = w1 * Qi * om1
26305        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26306        ECL = sparrow / Rhead**2.0d0 &
26307            - hawk    / Rhead**4.0d0
26308 !c!-------------------------------------------------------------------
26309 !c! derivative of ecl is Gcl
26310 !c! dF/dr part
26311        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26312                  + 4.0d0 * hawk    / Rhead**5.0d0
26313 !c! dF/dom1
26314        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26315 !c! dF/dom2
26316        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26317 !c--------------------------------------------------------------------
26318 !c Polarization energy
26319 !c Epol
26320        MomoFac2 = (1.0d0 - chi2 * sqom1)
26321        RR2  = R2 * R2 / MomoFac2
26322        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26323        fgb2 = sqrt(RR2  + a12sq * ee2)
26324        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26325        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26326                / (fgb2 ** 5.0d0)
26327        dFGBdR2 = ( (R2 / MomoFac2)  &
26328                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26329                / (2.0d0 * fgb2)
26330        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26331                 * (2.0d0 - 0.5d0 * ee2) ) &
26332                 / (2.0d0 * fgb2)
26333        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26334 !c!       dPOLdR2 = 0.0d0
26335        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26336 !c!       dPOLdOM1 = 0.0d0
26337        dPOLdOM2 = 0.0d0
26338 !c!-------------------------------------------------------------------
26339 !c! Elj
26340        pom = (pis / Rhead)**6.0d0
26341        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26342 !c! derivative of Elj is Glj
26343        dGLJdR = 4.0d0 * eps_head &
26344            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26345            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26346 !c!-------------------------------------------------------------------
26347 !c! Return the results
26348 !c! (see comments in Eqq)
26349        DO k = 1, 3
26350         erhead(k) = Rhead_distance(k)/Rhead
26351         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26352        END DO
26353        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26354        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26355        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26356        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26357        facd1 = d1 * vbld_inv(i+nres)
26358        facd2 = d2 * vbld_inv(j+nres)
26359        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26360        DO k = 1, 3
26361         condor = (erhead_tail(k,2) &
26362        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26363
26364         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26365         gvdwx(k,i) = gvdwx(k,i) &
26366                   - dGCLdR * pom &
26367                   - dPOLdR2 * (erhead_tail(k,2) &
26368        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26369                   - dGLJdR * pom
26370
26371         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26372         gvdwx(k,j) = gvdwx(k,j) &
26373                   + dGCLdR * pom &
26374                   + dPOLdR2 * condor &
26375                   + dGLJdR * pom
26376
26377
26378         gvdwc(k,i) = gvdwc(k,i) &
26379                   - dGCLdR * erhead(k) &
26380                   - dPOLdR2 * erhead_tail(k,2) &
26381                   - dGLJdR * erhead(k)
26382
26383         gvdwc(k,j) = gvdwc(k,j) &
26384                   + dGCLdR * erhead(k) &
26385                   + dPOLdR2 * erhead_tail(k,2) &
26386                   + dGLJdR * erhead(k)
26387
26388        END DO
26389        RETURN
26390       END SUBROUTINE edq
26391       SUBROUTINE edd(ECL)
26392 !       IMPLICIT NONE
26393        use comm_momo
26394       use calc_data
26395
26396        double precision ecl
26397 !c!       csig = sigiso(itypi,itypj)
26398        w1 = wqdip(1,itypi,itypj)
26399        w2 = wqdip(2,itypi,itypj)
26400 !c!-------------------------------------------------------------------
26401 !c! ECL
26402        fac = (om12 - 3.0d0 * om1 * om2)
26403        c1 = (w1 / (Rhead**3.0d0)) * fac
26404        c2 = (w2 / Rhead ** 6.0d0) &
26405           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26406        ECL = c1 - c2
26407 !c!       write (*,*) "w1 = ", w1
26408 !c!       write (*,*) "w2 = ", w2
26409 !c!       write (*,*) "om1 = ", om1
26410 !c!       write (*,*) "om2 = ", om2
26411 !c!       write (*,*) "om12 = ", om12
26412 !c!       write (*,*) "fac = ", fac
26413 !c!       write (*,*) "c1 = ", c1
26414 !c!       write (*,*) "c2 = ", c2
26415 !c!       write (*,*) "Ecl = ", Ecl
26416 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26417 !c!       write (*,*) "c2_2 = ",
26418 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26419 !c!-------------------------------------------------------------------
26420 !c! dervative of ECL is GCL...
26421 !c! dECL/dr
26422        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26423        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26424           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26425        dGCLdR = c1 - c2
26426 !c! dECL/dom1
26427        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26428        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26429           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26430        dGCLdOM1 = c1 - c2
26431 !c! dECL/dom2
26432        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26433        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26434           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26435        dGCLdOM2 = c1 - c2
26436 !c! dECL/dom12
26437        c1 = w1 / (Rhead ** 3.0d0)
26438        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26439        dGCLdOM12 = c1 - c2
26440 !c!-------------------------------------------------------------------
26441 !c! Return the results
26442 !c! (see comments in Eqq)
26443        DO k= 1, 3
26444         erhead(k) = Rhead_distance(k)/Rhead
26445        END DO
26446        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26447        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26448        facd1 = d1 * vbld_inv(i+nres)
26449        facd2 = d2 * vbld_inv(j+nres)
26450        DO k = 1, 3
26451
26452         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26453         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26454         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26455         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26456
26457         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26458         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26459        END DO
26460        RETURN
26461       END SUBROUTINE edd
26462       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26463 !       IMPLICIT NONE
26464        use comm_momo
26465       use calc_data
26466
26467        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26468        eps_out=80.0d0
26469        itypi = itype(i,1)
26470        itypj = itype(j,1)
26471 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26472 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26473 !c!       t_bath = 300
26474 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26475        Rb=0.001986d0
26476        BetaT = 1.0d0 / (298.0d0 * Rb)
26477 !c! Gay-berne var's
26478        sig0ij = sigma( itypi,itypj )
26479        chi1   = chi( itypi, itypj )
26480        chi2   = chi( itypj, itypi )
26481        chi12  = chi1 * chi2
26482        chip1  = chipp( itypi, itypj )
26483        chip2  = chipp( itypj, itypi )
26484        chip12 = chip1 * chip2
26485 !       chi1=0.0
26486 !       chi2=0.0
26487 !       chi12=0.0
26488 !       chip1=0.0
26489 !       chip2=0.0
26490 !       chip12=0.0
26491 !c! not used by momo potential, but needed by sc_angular which is shared
26492 !c! by all energy_potential subroutines
26493        alf1   = 0.0d0
26494        alf2   = 0.0d0
26495        alf12  = 0.0d0
26496 !c! location, location, location
26497 !       xj  = c( 1, nres+j ) - xi
26498 !       yj  = c( 2, nres+j ) - yi
26499 !       zj  = c( 3, nres+j ) - zi
26500        dxj = dc_norm( 1, nres+j )
26501        dyj = dc_norm( 2, nres+j )
26502        dzj = dc_norm( 3, nres+j )
26503 !c! distance from center of chain(?) to polar/charged head
26504 !c!       write (*,*) "istate = ", 1
26505 !c!       write (*,*) "ii = ", 1
26506 !c!       write (*,*) "jj = ", 1
26507        d1 = dhead(1, 1, itypi, itypj)
26508        d2 = dhead(2, 1, itypi, itypj)
26509 !c! ai*aj from Fgb
26510        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26511 !c!       a12sq = a12sq * a12sq
26512 !c! charge of amino acid itypi is...
26513        Qi  = icharge(itypi)
26514        Qj  = icharge(itypj)
26515        Qij = Qi * Qj
26516 !c! chis1,2,12
26517        chis1 = chis(itypi,itypj)
26518        chis2 = chis(itypj,itypi)
26519        chis12 = chis1 * chis2
26520        sig1 = sigmap1(itypi,itypj)
26521        sig2 = sigmap2(itypi,itypj)
26522 !c!       write (*,*) "sig1 = ", sig1
26523 !c!       write (*,*) "sig2 = ", sig2
26524 !c! alpha factors from Fcav/Gcav
26525        b1cav = alphasur(1,itypi,itypj)
26526 !       b1cav=0.0
26527        b2cav = alphasur(2,itypi,itypj)
26528        b3cav = alphasur(3,itypi,itypj)
26529        b4cav = alphasur(4,itypi,itypj)
26530        wqd = wquad(itypi, itypj)
26531 !c! used by Fgb
26532        eps_in = epsintab(itypi,itypj)
26533        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26534 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
26535 !c!-------------------------------------------------------------------
26536 !c! tail location and distance calculations
26537        Rtail = 0.0d0
26538        DO k = 1, 3
26539         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26540         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26541        END DO
26542 !c! tail distances will be themselves usefull elswhere
26543 !c1 (in Gcav, for example)
26544        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26545        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26546        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26547        Rtail = dsqrt(  &
26548           (Rtail_distance(1)*Rtail_distance(1))  &
26549         + (Rtail_distance(2)*Rtail_distance(2))  &
26550         + (Rtail_distance(3)*Rtail_distance(3)))
26551 !c!-------------------------------------------------------------------
26552 !c! Calculate location and distance between polar heads
26553 !c! distance between heads
26554 !c! for each one of our three dimensional space...
26555        d1 = dhead(1, 1, itypi, itypj)
26556        d2 = dhead(2, 1, itypi, itypj)
26557
26558        DO k = 1,3
26559 !c! location of polar head is computed by taking hydrophobic centre
26560 !c! and moving by a d1 * dc_norm vector
26561 !c! see unres publications for very informative images
26562         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26563         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26564 !c! distance
26565 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26566 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26567         Rhead_distance(k) = chead(k,2) - chead(k,1)
26568        END DO
26569 !c! pitagoras (root of sum of squares)
26570        Rhead = dsqrt(   &
26571           (Rhead_distance(1)*Rhead_distance(1)) &
26572         + (Rhead_distance(2)*Rhead_distance(2)) &
26573         + (Rhead_distance(3)*Rhead_distance(3)))
26574 !c!-------------------------------------------------------------------
26575 !c! zero everything that should be zero'ed
26576        Egb = 0.0d0
26577        ECL = 0.0d0
26578        Elj = 0.0d0
26579        Equad = 0.0d0
26580        Epol = 0.0d0
26581        eheadtail = 0.0d0
26582        dGCLdOM1 = 0.0d0
26583        dGCLdOM2 = 0.0d0
26584        dGCLdOM12 = 0.0d0
26585        dPOLdOM1 = 0.0d0
26586        dPOLdOM2 = 0.0d0
26587        RETURN
26588       END SUBROUTINE elgrad_init
26589
26590       double precision function tschebyshev(m,n,x,y)
26591       implicit none
26592       integer i,m,n
26593       double precision x(n),y,yy(0:maxvar),aux
26594 !c Tschebyshev polynomial. Note that the first term is omitted
26595 !c m=0: the constant term is included
26596 !c m=1: the constant term is not included
26597       yy(0)=1.0d0
26598       yy(1)=y
26599       do i=2,n
26600         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
26601       enddo
26602       aux=0.0d0
26603       do i=m,n
26604         aux=aux+x(i)*yy(i)
26605       enddo
26606       tschebyshev=aux
26607       return
26608       end function tschebyshev
26609 !C--------------------------------------------------------------------------
26610       double precision function gradtschebyshev(m,n,x,y)
26611       implicit none
26612       integer i,m,n
26613       double precision x(n+1),y,yy(0:maxvar),aux
26614 !c Tschebyshev polynomial. Note that the first term is omitted
26615 !c m=0: the constant term is included
26616 !c m=1: the constant term is not included
26617       yy(0)=1.0d0
26618       yy(1)=2.0d0*y
26619       do i=2,n
26620         yy(i)=2*y*yy(i-1)-yy(i-2)
26621       enddo
26622       aux=0.0d0
26623       do i=m,n
26624         aux=aux+x(i+1)*yy(i)*(i+1)
26625 !C        print *, x(i+1),yy(i),i
26626       enddo
26627       gradtschebyshev=aux
26628       return
26629       end function gradtschebyshev
26630
26631
26632
26633
26634
26635       end module energy